Implement lambda-lists properly.

1 files changed, 145 insertions, 24 deletions

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 4ccd1ae..ec15ef9 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -437,6 +437,31 @@
         (dolist (form* body* result)
           (setq result (funcall (the eval-closure form*) env)))))))
 
+(defun lambda-binding-vars (entry)
+  (etypecase entry
+    (cons   (list (first entry)
+                  (if (cddr entry)
+                      (third entry)
+                      (gensym))))
+    (symbol (list entry (gensym)))))
+
+(defun lambda-simple-binding-vars (entry)
+  (etypecase entry
+    (cons   (list (first entry)))
+    (symbol (list entry))))
+
+(defun lambda-binding-default (entry)
+  (etypecase entry
+    (cons   (second entry))
+    (symbol nil)))
+
+(defun lambda-key (entry)
+  (flet ((keywordify (sym)
+           (intern (symbol-name sym) "KEYWORD")))
+    (etypecase entry
+      (cons   (keywordify (first entry)))
+      (symbol (keywordify entry)))))
+
 (declaim (ftype (function (list context) eval-closure) prepare-lambda))
 (defun prepare-lambda (lambda-form context)
   (destructuring-bind (lambda-list &rest body) lambda-form
@@ -444,34 +469,120 @@
     (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
                           morep more-context more-count)
         (sb-int:parse-lambda-list lambda-list)
-      (declare (ignorable required optional restp rest keyp keys allowp auxp aux
-                          morep more-context more-count))
-      (when (or optional restp keyp allowp auxp morep)
-        (return-from prepare-lambda (lambda (env) (lambda (&rest args) (error "NYI")))))
-      (let* ((argvars lambda-list)    ;fixme
-             (n (length (the list lambda-list)))
+      (declare (ignore more-context more-count))
+      (declare (ignorable allowp auxp))
+      (when morep
+        (error "The interpreter does not support the lambda-list keyword ~D"
+               'sb-int:&more))
+      (let* ((argvars (append required
+                              (mapcan #'lambda-binding-vars optional)
+                              (mapcan #'lambda-binding-vars keys)
+                              (mapcan #'lambda-simple-binding-vars aux)
+                              (and restp (list rest))))
+             (keywords (mapcar #'lambda-key keys))
+             #+(or) (simplep (not (or optional restp keyp allowp auxp)))
+             (required-num (length required))
+             (optional-num (length optional))
+             (key-num (length keys))
+             (aux-num (length aux))
+             (varnum (length argvars))
              (envp (maybe-closes-over-p `(progn ,@body) argvars))
              (new-context (if envp
                               (context-add-env-lexicals context argvars)
                               (context-add-stack-lexicals context argvars)))
-             (body* (prepare-progn body new-context)))
-        (if envp
-            (lambda (env)
-              (lambda (&rest args)
-                (declare (dynamic-extent args))
-                (let ((new-env (make-environment env n)))
-                  ;; This is not as inefficient as it looks.  SBCL
-                  ;; transforms &rest into &more here.
-                  (dotimes (i n)
-                    (setf (environment-value new-env 0 i) (elt args i)))
-                  (funcall body* new-env))))
-            (lambda (env)
-              (lambda (&rest args)
-                (declare (dynamic-extent args))
-                (with-stack-frame n
-                  (dotimes (i n)
-                    (setf (stack-ref 0 i) (elt args i)))
-                  (funcall body* env)))))))))
+             (default-values (append (mapcar #'lambda-binding-default optional)
+                                     (mapcar #'lambda-binding-default keys)
+                                     (mapcar #'lambda-binding-default aux)))
+             (default-values*
+               (mapcar (lambda (x) (prepare-form x new-context)) default-values))
+             (body* (prepare-progn body new-context))
+             (unbound (gensym)))
+        (macrolet ((handle-arguments (args env-ref env)
+                     ;; All this ELT and LENGTH stuff is not as
+                     ;; inefficient as it looks.  SBCL transforms
+                     ;; &rest into &more here.
+                     `(let ((rest
+                              (when (or restp keyp)
+                                (loop for i
+                                      from (+ required-num optional-num)
+                                      below (length ,args)
+                                      collect (elt ,args i)))))
+                        (prog ((argi 0)
+                               (vari 0))
+                           (declare (type fixnum argi vari))
+                         positional
+                           (when (>= argi (length ,args))
+                             (go missing-optionals))
+                           (when (>= argi (the fixnum (+ required-num optional-num)))
+                             (go keys))
+                           (setf (,@env-ref 0 vari) (elt ,args argi))
+                           (when (>= argi required-num)
+                             (pop default-values*)
+                             (incf vari)
+                             (setf (,@env-ref 0 vari) t))
+                           (incf vari)
+                           (incf argi)
+                           (go positional)
+                         missing-optionals
+                           (assert (>= argi required-num))
+                           (when (>= vari (the fixnum (+ required-num (the fixnum (* 2 optional-num)))))
+                             (go keys))
+                           (let ((val* (pop default-values*)))
+                             (setf (,@env-ref 0 vari)
+                                   (funcall (the eval-closure val*) ,env)
+                                   (,@env-ref 0 (1+ vari))
+                                   nil))
+                           (incf vari 2)
+                           (go missing-optionals)
+                         keys
+                           (when (>= vari
+                                     (the fixnum
+                                          (+ required-num (* 2 (+ optional-num key-num)))))
+                             (go aux))
+                           (let* ((key  (the keyword (pop keywords)))
+                                  (val* (pop default-values*))
+                                  (x    (getf rest key unbound)))
+                             (if (eq unbound x)
+                                 (setf (,@env-ref 0 vari)
+                                       (funcall (the eval-closure val*) ,env)
+                                       (,@env-ref 0 (1+ vari))
+                                       nil)
+                                 (setf (,@env-ref 0 vari)
+                                       x
+                                       (,@env-ref 0 (1+ vari))
+                                       t)))
+                           (incf vari 2)
+                           (go keys)
+                         aux
+                           (when (>= vari
+                                     (the fixnum
+                                          (+ required-num
+                                             (the fixnum (* 2 (+ optional-num key-num)))
+                                             aux-num)))
+                             (go rest))
+                           (let ((val* (pop default-values*)))
+                             (setf (,@env-ref 0 vari)
+                                   (funcall (the eval-closure val*) ,env)))
+                           (incf vari)
+                           (go aux)
+                         rest
+                           (assert (null default-values*))
+                           (when restp
+                             (setf (,@env-ref 0 (1- varnum))
+                                   rest))))))
+          (if envp
+              (lambda (env)
+                (lambda (&rest args)
+                  (declare (dynamic-extent args))
+                  (let ((new-env (make-environment env varnum)))
+                    (handle-arguments args (environment-value new-env) new-env)
+                    (funcall body* new-env))))
+              (lambda (env)
+                (lambda (&rest args)
+                  (declare (dynamic-extent args))
+                  (with-stack-frame varnum
+                    (handle-arguments args (stack-ref) env)
+                    (funcall body* env))))))))))
 
 
 (defun context->native-environment (context)
@@ -869,3 +980,13 @@
                          5 7)
                        (make-null-context))
          (make-null-environment))
+
+#+(or)
+(with-stack ()
+  (funcall (funcall
+            (prepare-form
+             '(lambda (a b &optional c (d 10 dp) &rest r &key e (f 12 fp) (g 12 gp) &aux (h 1) (i 2))
+               (list a b c d dp e f fp g gp r h i)))
+            (make-null-environment))
+           1 2 3 4 :f 5 :e 6))
+;; => (1 2 3 4 T 6 5 T 12 NIL (:F 5 :E 6) 1 2)