case-lambda.lisp

;;; case-lambda

;;; consider (case-lambda ((x y) (+ x y)) ((a b c d) (+ a b c d)))
;;; it would be nice that expand to

;;; (lambda (&rest g0)
;;;   (if (null g0)
;;;     (error "case-lambda match failure") ; <-- no argument
;;;     (let ((g1 (car g0)))
;;;       (setq g0 (cdr g0))
;;;       (if (null g0)
;;;         (error "case-lambda match failure") ; <-- only one argument
;;;         (let ((g2 (car g0)))
;;;           (setq g0 (cdr g0))
;;;           (if (null g0)
;;;             (let ((x g1) (y g2)) ; <-- first case, two arguments
;;;               (+ x y))
;;;             (let ((g3 (car g0)))
;;;               (setq g0 (cdr g0))
;;;               (if (null g0)
;;;                 (error "case-lambda match failure") ; <-- three arguments
;;;                 (let ((g4 (car g0)))
;;;                   (setq g0 (cdr g0))
;;;                   (if (null g0)
;;;                     (let ((a g1) (b g2) (c g3) (d g4)) ; <-- second case,
;;;                       (+ a b c d))                     ; four arguments
;;;                     (error "case-lambda match failure")))))))))))

;;; By inspecting the expression above, we can see that it is essentially a
;;; nested form of the following pattern.

;;; (if (null g0)
;;;   match-success-or-failure
;;;   bind-rest-or-failure)

;;; where match-success-or-failure is either (error ...) or (let ...)
;;; bind-rest-or-failure is either (let ((gN (car g0))) (setq g0 (cdr g0)) ...)
;;;   or (error ...)
;;; which may build through a recursive routine easily, but could also build
;;; reversed, from the deepest (error ...) form to the top (if ...) form

;;; then, let's involve &rest, consider
;;; (case-lambda ((x) x) ((i j k) (list i j k)) ((a &rest b) (list a b)))
;;; the failure form would be the rest clause if possible, like

;;; (lambda (&rest g0)
;;;   (if (null g0)
;;;     (error "case-lambda match failure") ; <-- failure form that raise an
;;;                                         ;     error
;;;     (let ((g1 (car g0)))
;;;       (setq g0 (cdr g0))
;;;       (let ((rest0 g0)) ; <-- preserve for the rest variable b
;;;         (if (null g0)
;;;           (let ((x g1)) x) ; <-- case 1
;;;           (let ((g2 (car g0)))
;;;             (setq g0 (cdr g0))
;;;             (if (null g0)
;;;               (let ((a g1) (b rest0)) ; <-- note that this is actually a
;;;                 (list a b))           ;     failure form, with rest clause
;;;                                       ;     involved and applied
;;;               (let ((g3 (car g0)))
;;;                 (setq g0 (cdr g0))
;;;                 (if (null g0)
;;;                   (let ((i g1) (j g2) (k g3)) ; <-- the last case
;;;                     (list i j k))
;;;                   (let ((a g1) (b rest0)) ; <-- still the rest clause
;;;                     (list a b)))))))))))

;;; finally, consider this (case-lambda ((x) 1) ((&rest xs) xs)), this should
;;; construct (let ((rest0 g0)) ...) before any expression

(eval-when (:compile-toplevel :execute)
(defun case-lambda--pure-list-p (x)
  (do ((x x (cdr x)))
      ((not (consp x)) (null x))))

(defun case-lambda--check-syntax (clauses)
  ;; assume clauses is generate by reader so that it couldn't be non-pure list
  (assert (case-lambda--pure-list-p clauses))
  (dolist (c clauses)
    (unless (consp c)
      (error "bad case-lambda syntax"))
    (let ((arglist (car c))
          (body (cdr c)))
      (when (or (not (case-lambda--pure-list-p arglist))
                (not (case-lambda--pure-list-p body)))
        (error "bad case-lambda syntax"))
      (when (let* ((rest-form (member '&rest arglist))
                   (len (length rest-form)))
              (and (/= 0 len) (/= 2 len)))
        (error "bad case-lambda syntax")))))

;; case-lambda clause descriptor
(defun case-lambda--make-clamcd (restp n-regular regular-arglist body)
  "make a case-lambda clause descriptor
RESTP should be either rest argument name or nil
N-REGULAR is how many regular arguments
REGUAR-ARGLIST is regular arguments form"
  (cons (cons restp n-regular) (cons regular-arglist body)))
(defmacro clamcd--restp (x)
  `(caar ,x))
(defmacro clamcd--restvar (x)
  `(caar ,x))
(defmacro clamcd--n-regular (x)
  `(cdar ,x))
(defmacro clamcd--regular-arglist (x)
  `(cadr ,x))
(defmacro clamcd--body (x)
  `(cddr ,x))

(defun case-lambda--analyze-clauses (clauses)
  "return reversed clause descriptors that unreachable clauses are removed"
  (let ((result nil) (max-n-regular -1) (already-restp nil))
    (dolist (c clauses result) ; note function result is declared here
      (let* ((arglist (car c))
             (restp (member '&rest arglist))
             (restvar (and restp (cadr restp)))
             (n-regular (if restp (- (length arglist) 2) (length arglist)))
             (regulars (subseq arglist 0 n-regular))
             (body (cdr c)))
        (when (and (not already-restp)
                   (or restp (> n-regular max-n-regular)))
          (when restp (setq already-restp restp))
          (setq max-n-regular (max n-regular max-n-regular))
          (push (case-lambda--make-clamcd restvar n-regular regulars body)
                result))))))

;; you should read the section comments above before read this function
(defun case-lambda--build-main-form (clamcds)
  ;; note that clamcds is now reversed, so the max-n-regular clause or
  ;; the rest clause is sit on the top
  (let* ((first-clamcd (car clamcds))
         (second-clamcd (cadr clamcds))
         (restp (clamcd--restp first-clamcd))
         (rest-clamcd (and restp first-clamcd))
         (restvar (and restp (clamcd--restvar rest-clamcd)))
         (rest-n-regular (and restp (clamcd--n-regular rest-clamcd)))
         ;; n-regular of rest clause could smaller than max-n-regular
         (max-n-regular (max (clamcd--n-regular first-clamcd)
                             (clamcd--n-regular second-clamcd)))
         ;; gensyms
         (input-tmp (gensym "INPUT"))
         (regular-tmps
          (let ((res nil))
            (dotimes (_ max-n-regular res)
              (push (gensym "G") res))))
         (rest-tmp (gensym "REST"))
         ;; the failure-form
         (failure-form
          (if (not restp)
            '(error "case-lambda match failure")
            (let ((rest-clause-regular-arglist (clamcd--regular-arglist rest-clamcd)))
              `(let (,@(mapcar 'list rest-clause-regular-arglist regular-tmps)
                     (,restvar ,rest-tmp))
                 ,@(clamcd--body first-clamcd)))))
         (resform failure-form))
    (do ((clamcds clamcds (cdr clamcds)))
        ((null clamcds)
         `(lambda (&rest ,input-tmp) ; <-- see, the result
            ,(if (and restp (= 0 (clamcd--n-regular first-clamcd)))
              `(let ((,rest-tmp ,input-tmp))
                 ,resform)
              resform)))
      (let* ((clamcd (car clamcds))
             (next-clamcd (cadr clamcds))
             (n-regular (if (and restp (eq clamcd rest-clamcd))
                          max-n-regular
                          (clamcd--n-regular clamcd)))
             (next-n-regular
               (if (null next-clamcd) -1 (clamcd--n-regular next-clamcd))))
        ;; note that if the rest clause and the previous clause has same number
        ;; of regular arguments, this do loop will simply skip the rest clause
        (do ((i n-regular (- i 1)))
            ((= i next-n-regular))
          (when (and restp (= i (- rest-n-regular 1)))
            (setq failure-form '(error "case-lambda match failure"))
            (setq resform
              `(let ((,rest-tmp ,input-tmp))
                 ,resform)))
          (setq resform
            `(if (null ,input-tmp)
               ,(if (= i n-regular)
                  `(let (,@(mapcar 'list (clamcd--regular-arglist clamcd) regular-tmps)
                         ,@(if (and restp (= i max-n-regular)
                                    (= rest-n-regular max-n-regular)
                                    (/= rest-n-regular (clamcd--n-regular second-clamcd)))
                             ;; if it is the deepest form, and it has the most
                             ;; of regular arguments, and previous clause
                             ;; doesn't has the same number of arguments with
                             ;; this clause (which is rest clause),
                             ;; which is, if the rest clause has the most of
                             ;; regular arguments, and no other clauses have
                             ;; the most of regular arguments
                             `((,restvar ,rest-tmp))
                             nil))
                     ,@(clamcd--body clamcd))
                  failure-form)
               ,(if (= i max-n-regular)
                  failure-form
                  `(let ((,(nth i regular-tmps) (car ,input-tmp)))
                     (setq ,input-tmp (cdr ,input-tmp))
                     ,resform)))))))))
) ; end of eval-when

(defmacro case-lambda (&rest clauses)
  (case-lambda--check-syntax clauses)
  (let ((clamcds (case-lambda--analyze-clauses clauses)))
    (case (length clamcds)
      (0 '(lambda () nil))
      (1 (let ((d (car clamcds)))
           (if (clamcd--restp d)
             `(lambda (,@(clamcd--regular-arglist d) &rest ,(clamcd--restvar d))
                ,@(clamcd--body d))
             (cons 'lambda (cons (clamcd--regular-arglist d) (clamcd--body d))))))
      (otherwise
       (case-lambda--build-main-form clamcds)))))

(defmacro case-defun (name &rest clauses)
  `(progn
     (declaim (ftype (function (&rest t) (values &rest t)) ,name))
     (setf (symbol-function ',name) (case-lambda ,@clauses))))

(defmacro case-defmacro (name &rest clauses)
  (let ((xs (gensym)))
    `(defmacro ,name (&rest ,xs)
       (apply (case-lambda ,@clauses) ,xs))))

; (case-defun range
;   ((m) (range 0 m 1))
;   ((m n) (range m n 1))
;   ((m n k)
;    (loop for i from m below n by k collect i)))

; (macroexpand '(case-lambda))
; (macroexpand '(case-lambda ((x y) (+ x y))))
; (macroexpand '(case-lambda (() 1) ((x y) (+ x y))))
; (macroexpand '(case-lambda ((x y) (+ x y)) ((x y z) (- x y z))))
; (macroexpand '(case-lambda ((x y z) (+ x y z)) ((w x y z) (- w x y z))))
; (macroexpand '(case-lambda ((x y) (+ x y)) ((w x y z) (- w x y z))))
; (macroexpand '(case-lambda ((x y z) (- x y z)) ((&rest xs) (cons 1 xs))))
; (macroexpand '(case-lambda ((x y z) (- x y z)) ((x &rest xs) (list 1 x xs))))
; (macroexpand '(case-lambda ((x y z) (- x y z)) ((x y z &rest xs) (list 1 x xs))))
; (macroexpand '(case-lambda
;                 ((x y z) (- x y z))
;                 ((a b c d e &rest xs) (list a b c d e xs))))

;  (case-defun map*
;    ((f xs)
;     (if (null xs)
;       nil
;       (let* ((res (cons (funcall f (car xs)) nil))
;              (cur res))
;         (dolist (x (cdr xs) res)
;           (rplacd cur (cons (funcall f x) nil))
;           (setq cur (cdr cur))))))
;    ((f xs ys)
;     (if (or (null xs) (null ys))
;       nil
;       (let* ((res (cons (funcall f (car xs) (car ys)) nil))
;              (cur res))
;         (do ((xs (cdr xs) (cdr xs))
;              (ys (cdr ys) (cdr ys)))
;             ((or (null xs) (null ys))
;              res)
;           (rplacd cur (cons (funcall f (car xs) (car ys)) nil))
;           (setq cur (cdr cur))))))
;    ((f xs ys zs)
;     (if (or (null xs) (null ys) (null zs))
;       nil
;       (let* ((res (cons (funcall f (car xs) (car ys) (car zs)) nil))
;              (cur res))
;         (do ((xs (cdr xs) (cdr xs))
;              (ys (cdr ys) (cdr ys))
;              (zs (cdr zs) (cdr zs)))
;             ((or (null xs) (null ys) (null zs))
;              res)
;           (rplacd cur (cons (funcall f (car xs) (car ys) (car zs)) nil))
;           (setq cur (cdr cur))))))
;    ((f ws xs ys &rest zs)
;     (declare (inline map* some))
;     (if (or (null ws) (null xs) (null ys)
;             (some #'null zs))
;       nil
;       (let* ((res (cons (apply f (car ws) (car xs) (car ys) (map* #'car zs)) nil))
;              (cur res))
;         (do ((ws (cdr ws) (cdr ws))
;              (xs (cdr xs) (cdr xs))
;              (ys (cdr ys) (cdr ys))
;              (zs (map* #'cdr zs) (map* #'cdr zs)))
;             ((or (null ws) (null xs) (null ys) (some #'null zs))
;              res)
;           (rplacd cur (cons (apply f (car ws) (car xs) (car ys)
;                                    (map* #'car zs))
;                             nil))
;           (setq cur (cdr cur)))))))