From 18485764942e5b214fec6ce95ec7ba33a6dc1b31 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Tue, 16 Jul 2013 23:24:33 +0200
Subject: Reimplement LET* using progressive context extension.

---
 sb-eval2.lisp | 61 +++++++++++++++++++++++++++++++++++------------------------
 1 file changed, 36 insertions(+), 25 deletions(-)

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 4c18ee3..b6cef70 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -612,17 +612,12 @@
                      (varnum (length vars))
                      (envp (or (> varnum +stack-max+)
                                (maybe-closes-over-p `(progn ,@body) vars)))
-                     (binding-context context)
-                     (bindings* (mapcar (lambda (form)
-                                          (cons (car form)
-                                                (prepare-form (cdr form)
-                                                              binding-context)))
-                                        real-bindings))
                      (n (length (the list bindings)))
-                     (values* (mapcar #'cdr bindings*))
                      (new-context
-                       (context-add-env-lexicals context
-                                                 (mapcar #'first bindings*)))
+                       (context-add-env-lexicals context (list)))
+                     (values* (loop for (var . value-form) in real-bindings
+                                    collect (prepare-form value-form context)
+                                    do (context-add-env-lexical! context var)))
                      (body*
                        (prepare-progn body new-context)))
                 (if envp
@@ -643,22 +638,38 @@
            ((let*)
             ;; FIXME: SPECIAL declarations!
             (destructuring-bind (bindings &rest body) (rest form)
-              (labels ((prepare-let* (bindings context)
-                         (the (values eval-closure &rest nil)
-                           (if (endp bindings)
-                               (prepare-progn body context)
-                               (destructuring-bind (binding . rest-bindings) bindings
-                                 (let* ((var  (if (listp binding) (first binding) binding))
-                                        (val  (if (listp binding) (prepare-form (second binding) context) (prepare-nil)))
-                                      
-                                        (new-context (context-add-env-lexicals context (list var)))
-                                        (more (prepare-let* rest-bindings new-context)))
-                                   (lambda (env)
-                                     (let ((new-env (make-environment env 1)))
-                                       (setf (environment-value new-env 0 0)
-                                             (funcall val env))
-                                       (funcall more new-env)))))))))
-                (prepare-let* bindings context))))
+              (let* ((real-bindings (mapcar (lambda (form)
+                                              (if (listp form)
+                                                  (cons (first form) (second form))
+                                                  (cons form nil)))
+                                            bindings))
+                     (vars (mapcar #'car real-bindings))
+                     (varnum (length vars))
+                     (envp (or (> varnum +stack-max+)
+                               (maybe-closes-over-p `(progn ,@body) vars)))
+                     (n (length (the list bindings)))
+                     (new-context
+                       (context-add-env-lexicals context (list)))
+                     (values* (loop for (var . value-form) in real-bindings
+                                    collect (prepare-form value-form new-context)
+                                    do (context-add-env-lexical! context var)))
+                     (body*
+                       (prepare-progn body new-context)))
+                (if envp
+                    (lambda (env)
+                      (let ((new-env (make-environment env n)))
+                        (loop for i from 0 below n
+                              for val* in values*
+                              do (setf (environment-value new-env 0 i)
+                                       (funcall (the eval-closure val*) new-env)))
+                        (funcall body* new-env)))
+                    (lambda (env)
+                      (with-dynamic-extent-environment (new-env env n)
+                        (loop for i from 0 below n
+                              for val* in values*
+                              do (setf (environment-value new-env 0 i)
+                                       (funcall (the eval-closure val*) new-env)))
+                        (funcall body* new-env)))))))
            ((load-time-value)
             (let ((load-form (cadr form)))
               ;; FIXME
-- 
cgit v1.2.3