From 7c1d97ef0ad8c56fc1d7a2ec240d0b3b2cd466c7 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Fri, 19 Jul 2013 15:51:22 +0200
Subject: LAMBDA: Simplify.

---
 sb-eval2.lisp | 35 ++++++++++++++++++++---------------
 1 file changed, 20 insertions(+), 15 deletions(-)

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 5032662..6ff39d1 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -480,17 +480,19 @@
                (body* (prepare-progn body new-context))
                (unbound (gensym)))
           (setq varspecs (nreverse varspecs))
-          (macrolet ((handle-arguments (args env)
+          (let (*new-env*)
+            (declare (special *new-env*))
+            (flet ((handle-arguments (&rest args)
                        ;; All this ELT and LENGTH stuff is not as
                        ;; inefficient as it looks.  SBCL transforms
                        ;; &rest into &more here.
-                       `(let* ((restnum 0)
+                        (let* ((restnum 0)
                                (rest
                                  (when (or restp keyp)
                                    (loop for i
                                          from (+ required-num optional-num)
-                                         below (length ,args)
-                                         collect (elt ,args i)
+                                         below (length args)
+                                         collect (elt args i)
                                          do (incf restnum))))
                                (keys-checked-p nil)
                                (my-default-values* default-values*)
@@ -513,7 +515,7 @@
                                                 (if (eq varspec :lexical)
                                                     (progn
                                                       (setf
-                                                       (environment-value ,env 0 vari)
+                                                       (environment-value *new-env* 0 vari)
                                                        value)
                                                       (incf vari))
                                                     (progn
@@ -530,7 +532,7 @@
                                    (declare (inline push-args))
                                    (tagbody
                                     positional
-                                      (when (>= argi (length ,args))
+                                      (when (>= argi (length args))
                                         (go missing-optionals))
                                       (when (>= argi (the fixnum
                                                           (+ required-num optional-num)))
@@ -538,8 +540,8 @@
                                       (if (>= argi required-num)
                                         (progn
                                           (pop my-default-values*)
-                                          (push-args (elt ,args (incff argi)) t))
-                                        (push-args (elt ,args (incff argi))))
+                                          (push-args (elt args (incff argi)) t))
+                                        (push-args (elt args (incff argi))))
                                       (go positional)
                                     missing-optionals
                                       (unless (>= argi required-num)
@@ -551,7 +553,7 @@
                                         (go keys))
                                       (let ((val* (pop my-default-values*)))
                                         (push-args (funcall (the eval-closure val*)
-                                                            ,env)
+                                                            *new-env*)
                                                    nil))
                                       (go missing-optionals)
                                     keys
@@ -603,7 +605,7 @@
                                         (go rest))
                                       (let ((val* (pop my-default-values*)))
                                         (push-args (funcall (the eval-closure val*)
-                                                            ,env)))
+                                                            *new-env*)))
                                       (go aux)
                                     rest
                                       (assert (null my-default-values*))
@@ -611,20 +613,23 @@
                                         (push-args rest))
                                     final-call
                                       (return-from iter
-                                        (funcall body* ,env))))))
+                                        (funcall body* *new-env*))))))
                             (iter)))))
+            ;;(declare (inline handle-arguments))
             (if envp
                 (lambda (env)
                   (lambda (&rest args)
                     (declare (dynamic-extent args))
-                    (let ((new-env (make-environment env varnum)))
-                      (handle-arguments args new-env))))
+                    (let ((*new-env* (make-environment env varnum)))
+                      (declare (special *new-env*))
+                      (apply #'handle-arguments args))))
                 (lambda (env)
                   (lambda (&rest args)
                     (declare (dynamic-extent args))
                     ;;XXX VARNUM is too big--- need only lexicals
-                    (with-dynamic-extent-environment (new-env env varnum)
-                      (handle-arguments args new-env)))))))))))
+                    (with-dynamic-extent-environment (*new-env* env varnum)
+                      (declare (special *new-env*))
+                      (apply #'handle-arguments args))))))))))))
 
 (defun context->native-environment (context)
   ;;FIXME
-- 
cgit v1.2.3