From 81e0a70255027d394127e56e2cd9b7bc888463a5 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Sun, 14 Jul 2013 23:48:26 +0200
Subject: Introduce a stack for variables not closed over.

---
 sb-eval2.lisp | 327 +++++++++++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 268 insertions(+), 59 deletions(-)

(limited to 'sb-eval2.lisp')

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 7fb09b2..af29739 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -8,6 +8,12 @@
 #+(or)
 (setq SB-EXT:*EVALUATOR-MODE* :interpret)
 
+(defvar *stack*)
+(defvar *fp*)
+
+(deftype stack ()
+  `(array t (*)))
+
 (defstruct (environment (:constructor make-environment (parent
                                                         &optional (size 0)
                                                         &aux (data
@@ -17,13 +23,68 @@
   (data nil :type simple-vector))
 (defun make-null-environment () (make-environment nil 0))
 
-(defstruct (lexical (:constructor make-lexical (name offset &optional (nesting nil))))
-  (name nil :type (or symbol list))
-  nesting
-  offset)
+(defclass lexical ()
+  ((name    :accessor lexical-name    :initarg :name    :type (or symbol list))))
+
+(defclass env-lexical (lexical)
+  ((offset  :accessor lexical-offset  :initarg :offset  :type fixnum)
+   (nesting :accessor lexical-nesting :initarg :nesting :type fixnum)))
+
+(defclass stack-lexical (lexical)
+  ((offset  :accessor lexical-offset  :initarg :offset  :type fixnum)
+   (nesting :accessor lexical-nesting :initarg :nesting :type fixnum)))
 
-(defun lexical-with-nesting (lexical nesting)
-  (make-lexical (lexical-name lexical) (lexical-offset lexical) nesting))
+(defun make-stack-lexical (name offset &optional (nesting -1))
+  (make-instance 'stack-lexical :name name :offset offset :nesting nesting))
+(defun make-env-lexical (name offset &optional (nesting -1))
+  (make-instance 'env-lexical :name name :offset offset :nesting nesting))
+
+(defmethod lexical-with-nesting ((lexical stack-lexical) nesting)
+  (make-stack-lexical (lexical-name lexical) (lexical-offset lexical) nesting))
+(defmethod lexical-with-nesting ((lexical env-lexical) nesting)
+  (make-env-lexical (lexical-name lexical) (lexical-offset lexical) nesting))
+
+(defun maybe-references-p (form vars)
+  ;; Use `(function ,name) for local functions.
+  ;;
+  ;; FIXME: This doesn't do macro expansion, so it's probably
+  ;; incorrect.
+  (typecase form
+    (symbol
+     (member form vars :test #'equal))
+    (cons
+     (destructuring-bind (a . b) form
+       (or (maybe-references-p a vars)
+           (maybe-references-p b vars))))
+    (t
+     nil)))
+
+(defun maybe-closes-over-p (form vars)
+  ;; Use `(function ,name) for local functions.
+  ;;
+  ;; NOTE: This is a *very* simplistic algorithm with a *lot* of false
+  ;; positives.
+  ;;
+  ;; FIXME: This doesn't do macro expansion, so it's probably
+  ;; incorrect.
+  (typecase form
+    (symbol
+     nil)
+    (cons
+     (destructuring-bind (a . b) form
+       (case a
+         ((lambda)
+          (maybe-references-p form vars))
+         ((flet labels)
+          (typecase b
+            (cons
+             (destructuring-bind (bindings . rest) form
+               (or (maybe-references-p bindings vars)
+                   (maybe-closes-over-p rest vars))))
+            (t
+             (maybe-closes-over-p b vars)))))))
+    (t
+     nil)))
 
 (defstruct (box (:constructor make-box (value)))
   value)
@@ -31,7 +92,8 @@
 
 (defstruct (context (:constructor make-context (&optional parent)))
   parent
-  (levelp nil :type boolean)
+  (env-hop nil :type boolean)
+  (stack-hop nil :type boolean)
   (block-tags nil :type list)
   (go-tags nil :type list)
   (symbol-macros nil :type list)
@@ -93,58 +155,130 @@
                (cons tag forms)))))
 (defun context-var-lexical-p (context var)
   (context-find-lexical context var))
-(defun context-add-lexicals (context vars)
+(defun context-add-env-lexicals (context vars)
+  ;; open a new variable context
+    (let ((new-context (make-context context)))
+    (with-slots (lexicals env-hop)
+        new-context
+      (setq env-hop t)
+      (setq lexicals (loop for i fixnum from 0
+                           for v in vars
+                           collect (make-env-lexical v i))))
+    new-context))
+(defun context-add-stack-lexicals (context vars)
   ;; open a new variable context
     (let ((new-context (make-context context)))
-    (with-slots (lexicals levelp)
+    (with-slots (lexicals stack-hop)
         new-context
-      (setq levelp t)
-      (setq lexicals (loop for i from 0
+      (setq stack-hop t)
+      (setq lexicals (loop for i fixnum from 0
                            for v in vars
-                           collect (make-lexical v i))))
+                           collect (make-stack-lexical v i))))
     new-context))
-(defun context-add-functions (context fs)
-  (context-add-lexicals context (mapcar (lambda (x) `(function ,x)) fs)))
-(defun context-add-lexical (context var)
-  (context-add-lexicals context (list var)))
+(defun context-add-env-functions (context fs)
+  (context-add-env-lexicals context (mapcar (lambda (x) `(function ,x)) fs)))
+(defun context-add-stack-functions (context fs)
+  (context-add-stack-lexicals context (mapcar (lambda (x) `(function ,x)) fs)))
 (defun context-find-lexical (context var)
-  (loop with level = 0
+  (loop with env-level = 0
+        with stack-level = 0
         until (null context)
         for record = (find var
                            (context-lexicals context)
                            :key #'lexical-name
                            :test #'equal)
         when record
-          do (return (lexical-with-nesting record level))
-        when (context-levelp context)
-          do (incf level)
+          do (return
+               (etypecase record
+                 (env-lexical   (lexical-with-nesting record env-level))
+                 (stack-lexical (lexical-with-nesting record stack-level))))
+        when (context-env-hop context)
+          do (incf env-level)
+        when (context-stack-hop context)
+          do (incf stack-level)
         do (setq context (context-parent context))))
 
 (deftype eval-closure () `(function (environment) *))
 
+(declaim (inline environment-value))
 (defun environment-value (env nesting offset)
   (dotimes (i (the fixnum nesting))
     (setq env (environment-parent env)))
   (svref (environment-data env) offset))
 
+(declaim (inline (setf environment-value)))
 (defun (setf environment-value) (val env nesting offset)
   (dotimes (i (the fixnum nesting))
     (setq env (environment-parent env)))
   (setf (svref (environment-data env) offset) val))
 
+(defmacro with-stack-frame (nvars &body body)
+  `(call-with-stack-frame ,nvars (lambda () ,@body)))
+
+(declaim (ftype (function (fixnum function) *) call-with-stack-frame)
+         (inline call-with-stack-frame))
+(defun call-with-stack-frame (nvars thunk)
+  (let* ((stack *stack*)
+         (sp (fill-pointer stack))
+         (new-size (+ sp nvars 1)))
+    (declare (type stack stack)
+             (type fixnum sp new-size))
+    (loop for size fixnum = (array-dimension stack 0)
+          while (< size new-size)
+          do (format t "~&Resizing stack (new size: ~D)."
+                     (+ new-size (the fixnum (round (* size 1.5)))))
+             (adjust-array stack
+                           (list (the fixnum
+                                      (+ new-size (the fixnum
+                                                       (round (* size 1.5))))))))
+    (setf (fill-pointer stack) new-size)
+    (setf (aref stack sp) (the fixnum *fp*))
+    (unwind-protect
+         (let ((*fp* sp))
+           (funcall thunk))
+      (setf (fill-pointer stack) sp))))
+
+(declaim (ftype (function (fixnum) *) deref-stack)
+         (inline deref-stack))
+(defun deref-stack (pos)
+  (aref (the stack *stack*) pos))
+
+(declaim (ftype (function (fixnum fixnum) *) stack-ref)
+         (inline stack-ref))
+(defun stack-ref (nesting offset)
+  (let ((pos (the fixnum *fp*)))
+    (dotimes (i nesting)
+      (setq pos (the fixnum (deref-stack pos))))
+    (aref (the stack *stack*) (the fixnum (+ 1 offset pos)))))
+
+(declaim (ftype (function (* fixnum fixnum) *) (setf stack-ref))
+         (inline (setf stack-ref)))
+(defun (setf stack-ref) (val nesting offset)
+  (let ((pos *fp*))
+    (declare (type fixnum pos))
+    (dotimes (i nesting)
+      (setq pos (deref-stack pos)))
+    (setf (aref (the stack *stack*) (the fixnum (+ 1 offset pos))) val)))
+
 (declaim (ftype (function (symbol context) eval-closure) prepare-ref))
 (defun prepare-ref (var context)
   (if (context-var-lexical-p context var)
       (let* ((lexical (context-find-lexical context var))
              (nesting (lexical-nesting lexical))
              (offset (lexical-offset lexical)))
-        (lambda (env)
-          (environment-value env nesting offset)))
+        (etypecase lexical
+          (env-lexical
+           (lambda (env)
+             (environment-value env nesting offset)))
+          (stack-lexical
+           (lambda (env)
+             (declare (ignore env))
+             (stack-ref nesting offset)))))
       (lambda (env)
         (declare (ignore env))
         (symbol-value var))))
 
-(declaim (ftype (function ((or symbol list) context) eval-closure) prepare-refunction-))
+(declaim (ftype (function ((or symbol list) context) eval-closure) prepare-function-ref))
 (defun prepare-function-ref (function-name context)
   (if (context-var-lexical-p context `(function ,function-name))
       (let* ((lexical (context-find-lexical context `(function ,function-name)))
@@ -243,25 +377,67 @@
         (dolist (form* body* result)
           (setq result (funcall (the eval-closure form*) env)))))))
 
+#+ (or)
+                (if (maybe-closes-over-p `(progn ,@body) vars)
+                    (let* ((new-context
+                             (context-add-env-lexicals context
+                                                       (mapcar #'first bindings*)))
+                           (body*
+                             (prepare-progn body new-context)))
+                      (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*) env)))
+                          (funcall body* new-env))))
+                    (let* ((new-context
+                             (context-add-stack-lexicals context
+                                                         (mapcar #'first bindings*)))
+                           (body*
+                             (prepare-progn body new-context)))
+                      (lambda (env)
+                        (with-stack-frame n
+                          (loop for i from 0 below n
+                                for val* in values*
+                                do (setf (stack-ref i)
+                                         (funcall (the eval-closure val*) env)))
+                          (funcall body* env)))))
+
 (declaim (ftype (function (list context) eval-closure) prepare-lambda))
 (defun prepare-lambda (lambda-form context)
   (destructuring-bind (lambda-list &rest body) lambda-form
     ;; FIXME: SPECIAL declarations!
-    (let* ((n (length (the list lambda-list)))
-           (new-context (context-add-lexicals context lambda-list))
-           (body* (prepare-progn body new-context)))
-      (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
-                            morep more-context more-count)
-          (sb-int:parse-lambda-list lambda-list)
-       (lambda (env)
-         (lambda (&rest args)
-           (declare (dynamic-extent args))
-           ;; FIXME: non-simple lambda-lists
-           (let ((new-env (make-environment env n)))
-             (loop for i from 0 to n
-                   for val in args
-                   do (setf (environment-value new-env 0 i) val))
-             (funcall body* new-env))))))))
+    (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))
+      (let* ((argvars lambda-list)    ;fixme
+             (n (length (the list lambda-list))))
+        (if (maybe-closes-over-p `(progn ,@body) argvars)
+            (let* ((new-context (context-add-env-lexicals context argvars))
+                   (body* (prepare-progn body new-context)))
+              (lambda (env)
+                (lambda (&rest args)
+                  (declare (dynamic-extent args))
+                  ;; FIXME: non-simple lambda-lists
+                  (let ((new-env (make-environment env n)))
+                    (loop for i from 0 to n
+                          for val in args
+                          do (setf (environment-value new-env 0 i) val))
+                    (funcall body* new-env)))))
+            (let* ((new-context (context-add-stack-lexicals context argvars))
+                   (body* (prepare-progn body new-context)))
+              (lambda (env)
+                (lambda (&rest args)
+                  (declare (dynamic-extent args))
+                  ;; FIXME: non-simple lambda-lists
+                  (with-stack-frame n
+                    (loop for i from 0 below n
+                          for val in args
+                          do (setf (stack-ref 0 i) val))
+                    (funcall body* env))))))))))
 
 (defun context->native-environment (context)
   ;;FIXME
@@ -319,13 +495,20 @@
                         for result =
                            (progn
                              (check-type var symbol)
-                             (if ;XXX could lift the conditional out of the lambda
-                              lexical?
-                              (setf (environment-value env
-                                                       (lexical-nesting lexical?)
-                                                       (lexical-offset lexical?))
-                                    value)
-                              (setf (symbol-value var) value)))
+                             (etypecase lexical?  ; XXX could lift the
+                                                  ; case distinction
+                                                  ; out of the lambda
+                               (env-lexical
+                                (setf (environment-value env
+                                                         (lexical-nesting lexical?)
+                                                         (lexical-offset lexical?))
+                                      value))
+                               (stack-lexical
+                                (setf (stack-ref (lexical-nesting lexical?)
+                                                 (lexical-offset lexical?))
+                                      value))
+                               (null
+                                (setf (symbol-value var) value))))
                         finally (return result))))))
            ((catch)
             (destructuring-bind (tag &body body) (rest form)
@@ -360,7 +543,7 @@
                                                     (prepare-lambda (rest form) context))
                                               (cons form (prepare-nil))))
                                         bindings))
-                     (new-context (context-add-functions context (mapcar #'first bindings*)))
+                     (new-context (context-add-env-functions context (mapcar #'first bindings*)))
                      (functions (mapcar #'cdr bindings*))
                      (n (length functions))
                      (body* (prepare-progn body new-context)))
@@ -373,7 +556,7 @@
                     (funcall body* new-env))))))
            ((labels)
             (destructuring-bind (bindings &rest body) (rest form)
-              (let* ((new-context (context-add-functions context (mapcar #'first bindings)))
+              (let* ((new-context (context-add-env-functions context (mapcar #'first bindings)))
                      (bindings* (mapcar (lambda (form)
                                           (if (listp form)
                                               (cons (first form)
@@ -401,15 +584,32 @@
                                         bindings))
                      (n (length bindings*))
                      (values* (mapcar #'cdr bindings*))
-                     (new-context (context-add-lexicals context (mapcar #'first bindings*)))
-                     (body* (prepare-progn body new-context)))
-                (lambda (env)
-                  (let ((new-env (make-environment env n)))
-                    (loop for i from 0 to n
-                          for val* in values*
-                          do (setf (environment-value new-env 0 i)
-                                   (funcall (the eval-closure val*) env)))
-                    (funcall body* new-env))))))
+                     (vars (mapcar #'car bindings*)))
+                (if (maybe-closes-over-p `(progn ,@body) vars)
+                    (let* ((new-context
+                             (context-add-env-lexicals context
+                                                       (mapcar #'first bindings*)))
+                           (body*
+                             (prepare-progn body new-context)))
+                      (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*) env)))
+                          (funcall body* new-env))))
+                    (let* ((new-context
+                             (context-add-stack-lexicals context
+                                                         (mapcar #'first bindings*)))
+                           (body*
+                             (prepare-progn body new-context)))
+                      (lambda (env)
+                        (with-stack-frame n
+                          (loop for i from 0 below n
+                                for val* in values*
+                                do (setf (stack-ref 0 i)
+                                         (funcall (the eval-closure val*) env)))
+                          (funcall body* env))))))))
            ((let*)
             ;; FIXME: SPECIAL declarations!
             (destructuring-bind (bindings &rest body) (rest form)
@@ -421,7 +621,7 @@
                                  (let* ((var  (if (listp binding) (first binding) binding))
                                         (val  (if (listp binding) (prepare-form (second binding) context) (prepare-nil)))
                                       
-                                        (new-context (context-add-lexical context var))
+                                        (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)))
@@ -469,7 +669,7 @@
             (destructuring-bind (vars value-form &body body) (rest form)
               (let* ((value-form* (prepare-form value-form context))
                      (n           (length (the list vars)))
-                     (new-context (context-add-lexicals context vars))
+                     (new-context (context-add-env-lexicals context vars))
                      (body*       (prepare-progn body new-context)))
                 (lambda (env)
                   (let* ((new-env (make-environment env n))
@@ -592,8 +792,17 @@
    t))
 
 
+(defmacro with-stack (() &body body)
+  `(call-with-stack (lambda () ,@body)))
+
+(defun call-with-stack (thunk)
+  (let ((*stack* (make-array '(2000) :fill-pointer t :adjustable t))
+        (*fp* 0))
+    (funcall thunk)))
+
 (defun eval (form)
-  (funcall (prepare-form form) (make-null-environment)))
+  (with-stack ()
+    (funcall (prepare-form form) (make-null-environment))))
 
 
 (defun load (filename)
-- 
cgit v1.2.3


From 4ccb1efa134f578996a6cb960369f868673e0f2c Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Mon, 15 Jul 2013 00:00:15 +0200
Subject: Make the stack a SIMPLE-VECTOR, manage the fill-pointer as a special
 variable.

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

(limited to 'sb-eval2.lisp')

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index af29739..6ba0ad6 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -10,9 +10,10 @@
 
 (defvar *stack*)
 (defvar *fp*)
+(defvar *sp*)
 
 (deftype stack ()
-  `(array t (*)))
+  'simple-vector)
 
 (defstruct (environment (:constructor make-environment (parent
                                                         &optional (size 0)
@@ -219,7 +220,7 @@
          (inline call-with-stack-frame))
 (defun call-with-stack-frame (nvars thunk)
   (let* ((stack *stack*)
-         (sp (fill-pointer stack))
+         (sp *sp*)
          (new-size (+ sp nvars 1)))
     (declare (type stack stack)
              (type fixnum sp new-size))
@@ -227,16 +228,16 @@
           while (< size new-size)
           do (format t "~&Resizing stack (new size: ~D)."
                      (+ new-size (the fixnum (round (* size 1.5)))))
-             (adjust-array stack
-                           (list (the fixnum
-                                      (+ new-size (the fixnum
-                                                       (round (* size 1.5))))))))
-    (setf (fill-pointer stack) new-size)
+             (setq stack
+                   (adjust-array stack
+                                 (list (the fixnum
+                                            (+ new-size (the fixnum
+                                                             (round (* size 1.5))))))))
+             (setq *stack* stack))
     (setf (aref stack sp) (the fixnum *fp*))
-    (unwind-protect
-         (let ((*fp* sp))
-           (funcall thunk))
-      (setf (fill-pointer stack) sp))))
+    (let ((*fp* sp)
+          (*sp* new-size))
+      (funcall thunk))))
 
 (declaim (ftype (function (fixnum) *) deref-stack)
          (inline deref-stack))
@@ -796,8 +797,9 @@
   `(call-with-stack (lambda () ,@body)))
 
 (defun call-with-stack (thunk)
-  (let ((*stack* (make-array '(2000) :fill-pointer t :adjustable t))
-        (*fp* 0))
+  (let ((*stack* (make-array '(10000)))
+        (*fp* 0)
+        (*sp* 0))
     (funcall thunk)))
 
 (defun eval (form)
-- 
cgit v1.2.3


From f5d2a0cffe4762e1b793e0490903fdc6ec15b648 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Mon, 15 Jul 2013 00:01:05 +0200
Subject: Remove some debugging output.

---
 sb-eval2.lisp | 4 +---
 1 file changed, 1 insertion(+), 3 deletions(-)

(limited to 'sb-eval2.lisp')

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 6ba0ad6..20b57ca 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -226,9 +226,7 @@
              (type fixnum sp new-size))
     (loop for size fixnum = (array-dimension stack 0)
           while (< size new-size)
-          do (format t "~&Resizing stack (new size: ~D)."
-                     (+ new-size (the fixnum (round (* size 1.5)))))
-             (setq stack
+          do (setq stack
                    (adjust-array stack
                                  (list (the fixnum
                                             (+ new-size (the fixnum
-- 
cgit v1.2.3


From ed8c2eb04279c1d974abecc0c6715ab464eac66f Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Mon, 15 Jul 2013 00:24:17 +0200
Subject: Establish stacks as necessary.

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

(limited to 'sb-eval2.lisp')

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 20b57ca..610ad50 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -213,12 +213,22 @@
     (setq env (environment-parent env)))
   (setf (svref (environment-data env) offset) val))
 
+(defmacro with-stack (() &body body)
+  `(call-with-stack (lambda () ,@body)))
+
+(declaim (inline call-with-stack))
+(defun call-with-stack (thunk)
+  (let ((*stack* (make-array '(10000)))
+        (*fp* 0)
+        (*sp* 0))
+    (funcall thunk)))
+
 (defmacro with-stack-frame (nvars &body body)
   `(call-with-stack-frame ,nvars (lambda () ,@body)))
 
-(declaim (ftype (function (fixnum function) *) call-with-stack-frame)
-         (inline call-with-stack-frame))
-(defun call-with-stack-frame (nvars thunk)
+(declaim (ftype (function (fixnum function) *) really-call-with-stack-frame)
+         (inline really-call-with-stack-frame))
+(defun really-call-with-stack-frame (nvars thunk)
   (let* ((stack *stack*)
          (sp *sp*)
          (new-size (+ sp nvars 1)))
@@ -237,6 +247,13 @@
           (*sp* new-size))
       (funcall thunk))))
 
+(declaim (ftype (function (fixnum function) *) call-with-stack-frame)
+         (inline call-with-stack-frame))
+(defun call-with-stack-frame (nvars thunk)
+  (if (boundp '*stack*)
+      (really-call-with-stack-frame nvars thunk)
+      (with-stack () (really-call-with-stack-frame nvars thunk))))
+
 (declaim (ftype (function (fixnum) *) deref-stack)
          (inline deref-stack))
 (defun deref-stack (pos)
@@ -790,19 +807,8 @@
                        (prepare-global-call f args context))))))))))))
    t))
 
-
-(defmacro with-stack (() &body body)
-  `(call-with-stack (lambda () ,@body)))
-
-(defun call-with-stack (thunk)
-  (let ((*stack* (make-array '(10000)))
-        (*fp* 0)
-        (*sp* 0))
-    (funcall thunk)))
-
 (defun eval (form)
-  (with-stack ()
-    (funcall (prepare-form form) (make-null-environment))))
+  (funcall (prepare-form form) (make-null-environment)))
 
 
 (defun load (filename)
-- 
cgit v1.2.3


From 8d7088f386b8ad39ae428692a2ea03ed5faa490e Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Mon, 15 Jul 2013 00:25:12 +0200
Subject: Remove a temporary code note.

---
 sb-eval2.lisp | 27 ---------------------------
 1 file changed, 27 deletions(-)

(limited to 'sb-eval2.lisp')

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 610ad50..8982405 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -393,33 +393,6 @@
         (dolist (form* body* result)
           (setq result (funcall (the eval-closure form*) env)))))))
 
-#+ (or)
-                (if (maybe-closes-over-p `(progn ,@body) vars)
-                    (let* ((new-context
-                             (context-add-env-lexicals context
-                                                       (mapcar #'first bindings*)))
-                           (body*
-                             (prepare-progn body new-context)))
-                      (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*) env)))
-                          (funcall body* new-env))))
-                    (let* ((new-context
-                             (context-add-stack-lexicals context
-                                                         (mapcar #'first bindings*)))
-                           (body*
-                             (prepare-progn body new-context)))
-                      (lambda (env)
-                        (with-stack-frame n
-                          (loop for i from 0 below n
-                                for val* in values*
-                                do (setf (stack-ref i)
-                                         (funcall (the eval-closure val*) env)))
-                          (funcall body* env)))))
-
 (declaim (ftype (function (list context) eval-closure) prepare-lambda))
 (defun prepare-lambda (lambda-form context)
   (destructuring-bind (lambda-list &rest body) lambda-form
-- 
cgit v1.2.3


From 0d5bbcb4cbf1b8e2d75f4712195120c540515145 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Mon, 15 Jul 2013 01:34:42 +0200
Subject: LET: Don't confuse binding context with enclosing context wrt. the
 stack.

---
 sb-eval2.lisp | 34 ++++++++++++++++++++++++----------
 1 file changed, 24 insertions(+), 10 deletions(-)

(limited to 'sb-eval2.lisp')

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 8982405..055c4b8 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -166,6 +166,12 @@
                            for v in vars
                            collect (make-env-lexical v i))))
     new-context))
+(defun context-bump-stack (context)
+  (let ((new-context (make-context context)))
+    (with-slots (stack-hop)
+        new-context
+      (setq stack-hop t))
+    new-context))
 (defun context-add-stack-lexicals (context vars)
   ;; open a new variable context
     (let ((new-context (make-context context)))
@@ -565,16 +571,24 @@
            ((let)
             ;; FIXME: SPECIAL declarations!
             (destructuring-bind (bindings &rest body) (rest form)
-              (let* ((bindings* (mapcar (lambda (form)
-                                          (if (listp form)
-                                              (cons (first form)
-                                                    (prepare-form (second form) context))
-                                              (cons form (prepare-nil))))
-                                        bindings))
-                     (n (length bindings*))
-                     (values* (mapcar #'cdr bindings*))
-                     (vars (mapcar #'car bindings*)))
-                (if (maybe-closes-over-p `(progn ,@body) vars)
+              (let* ((real-bindings (mapcar (lambda (form)
+                                              (if (listp form)
+                                                  (cons (first form) (second form))
+                                                  (cons form nil)))
+                                            bindings))
+                     (vars (mapcar #'car real-bindings))
+                     (envp (maybe-closes-over-p `(progn ,@body) vars))
+                     (binding-context (if envp
+                                          context
+                                          (context-bump-stack 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*)))
+                (if envp
                     (let* ((new-context
                              (context-add-env-lexicals context
                                                        (mapcar #'first bindings*)))
-- 
cgit v1.2.3


From f49af7efdffa2fb7a8b579965bd9325baa8e946d Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Mon, 15 Jul 2013 09:06:45 +0200
Subject: Specialize STACK-REF over the stack nesting depth.

---
 sb-eval2.lisp | 86 +++++++++++++++++++++++++++++++++++++++++++++++++----------
 1 file changed, 72 insertions(+), 14 deletions(-)

(limited to 'sb-eval2.lisp')

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 055c4b8..4220e94 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -12,6 +12,12 @@
 (defvar *fp*)
 (defvar *sp*)
 
+(defmacro specialize (&environment env var value possible-values &body body)
+  `(ecase ,value
+     ,@(loop for x in (sb-int:eval-in-lexenv possible-values env)
+             collect
+                `((,x) ,(sb-int:eval-in-lexenv `(let ((,var ,x)) ,@body) env)))))
+
 (deftype stack ()
   'simple-vector)
 
@@ -40,6 +46,7 @@
 (defun make-env-lexical (name offset &optional (nesting -1))
   (make-instance 'env-lexical :name name :offset offset :nesting nesting))
 
+(defgeneric lexical-with-nesting (lexical nesting))
 (defmethod lexical-with-nesting ((lexical stack-lexical) nesting)
   (make-stack-lexical (lexical-name lexical) (lexical-offset lexical) nesting))
 (defmethod lexical-with-nesting ((lexical env-lexical) nesting)
@@ -265,13 +272,37 @@
 (defun deref-stack (pos)
   (aref (the stack *stack*) pos))
 
+(declaim (ftype (function (* fixnum) *) (setf deref-stack))
+         (inline (setf deref-stack)))
+(defun (setf deref-stack) (val pos)
+  (setf (aref (the stack *stack*) pos) val))
+
 (declaim (ftype (function (fixnum fixnum) *) stack-ref)
          (inline stack-ref))
 (defun stack-ref (nesting offset)
   (let ((pos (the fixnum *fp*)))
     (dotimes (i nesting)
       (setq pos (the fixnum (deref-stack pos))))
-    (aref (the stack *stack*) (the fixnum (+ 1 offset pos)))))
+    (deref-stack (the fixnum (+ 1 offset pos)))))
+
+(declaim (ftype (function (fixnum) *) stack-ref0)
+         (inline stack-ref0))
+(defun stack-ref0 (offset)
+  (deref-stack (the fixnum (+ (the fixnum (+ 1 (the fixnum *fp*))) offset))))
+
+(define-compiler-macro stack-ref (&whole form
+                                  &environment env
+                                  nesting offset)
+  (if (constantp nesting env)
+      (let ((num (sb-int:eval-in-lexenv nesting env)))
+        (if (zerop num)
+            `(stack-ref0 (the fixnum ,offset))
+            `(progn
+               (let ((pos *fp*))
+                 ,@(loop for i from 1 to num
+                         collect `(setq pos (the fixnum (deref-stack pos))))
+                 (deref-stack (the fixnum (+ 1 (the fixnum (+ (the fixnum ,offset) pos)))))))))
+      form))
 
 (declaim (ftype (function (* fixnum fixnum) *) (setf stack-ref))
          (inline (setf stack-ref)))
@@ -280,7 +311,26 @@
     (declare (type fixnum pos))
     (dotimes (i nesting)
       (setq pos (deref-stack pos)))
-    (setf (aref (the stack *stack*) (the fixnum (+ 1 offset pos))) val)))
+    (setf (deref-stack (the fixnum (+ 1 offset pos))) val)))
+
+(declaim (ftype (function (* fixnum) *) (setf stack-ref0))
+         (inline (setf stack-ref0)))
+(defun (setf stack-ref0) (val offset)
+  (setf (deref-stack (the fixnum (+ (the fixnum (+ 1 (the fixnum *fp*))) offset))) val))
+
+(define-compiler-macro (setf stack-ref) (&whole form
+                                         &environment env
+                                         val nesting offset)
+  (if (constantp nesting env)
+      (let ((num (sb-int:eval-in-lexenv nesting env)))
+        (if (zerop num)
+            `(setf (stack-ref0 (the fixnum ,offset)) ,val)
+            `(progn
+               (let ((pos *fp*))
+                 ,@(loop for i from 1 to num
+                         collect `(setq pos (the fixnum (deref-stack pos))))
+                 (setf (deref-stack (the fixnum (+ 1 (the fixnum (+ (the fixnum ,offset) pos))))) ,val)))))
+      form))
 
 (declaim (ftype (function (symbol context) eval-closure) prepare-ref))
 (defun prepare-ref (var context)
@@ -293,9 +343,16 @@
            (lambda (env)
              (environment-value env nesting offset)))
           (stack-lexical
-           (lambda (env)
-             (declare (ignore env))
-             (stack-ref nesting offset)))))
+           (if (< nesting 20)
+               (specialize m% nesting (loop for i from 0 below 20 collect i)
+                 `(lambda (env)
+                    (declare (ignore env))
+                    ;;(format t "~&; stack-ref ~d ~d" nesting offset)
+                    (stack-ref ,m% offset)))
+               (lambda (env)
+                 (declare (ignore env))
+                 ;;(format t "~&; stack-ref ~d ~d" nesting offset)
+                 (stack-ref nesting offset))))))
       (lambda (env)
         (declare (ignore env))
         (symbol-value var))))
@@ -326,12 +383,6 @@
 (defun prepare-nil ()
   (lambda (env) (declare (ignore env))))
 
-(defmacro specialize (&environment env var value possible-values &body body)
-  `(ecase ,value
-     ,@(loop for x in (sb-int:eval-in-lexenv possible-values env)
-             collect
-                `((,x) ,(sb-int:eval-in-lexenv `(let ((,var ,x)) ,@body) env)))))
-
 (declaim (ftype (function ((or symbol list) list context) eval-closure) prepare-local-call))
 (defun prepare-local-call (f args context)
   (let* ((args* (mapcar (lambda (form) (prepare-form form context)) args))
@@ -499,9 +550,16 @@
                                                          (lexical-offset lexical?))
                                       value))
                                (stack-lexical
-                                (setf (stack-ref (lexical-nesting lexical?)
-                                                 (lexical-offset lexical?))
-                                      value))
+                                (let ((nesting (lexical-nesting lexical?))
+                                      (offset (lexical-offset lexical?)))
+                                  (if (< nesting 20)
+                                      (specialize m%
+                                          nesting
+                                          (loop for i from 0 below 20 collect i)
+                                        `(setf (stack-ref ,m% offset)
+                                               value))
+                                      (setf (stack-ref nesting offset)
+                                            value))))
                                (null
                                 (setf (symbol-value var) value))))
                         finally (return result))))))
-- 
cgit v1.2.3


From d3146c8ace90aee2564c7ccc146f0128f5bad5e8 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Mon, 15 Jul 2013 09:33:21 +0200
Subject: Add a (wrong) definition of LOAD-TIME-VALUE.

---
 sb-eval2.lisp | 4 ++++
 1 file changed, 4 insertions(+)

(limited to 'sb-eval2.lisp')

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 4220e94..61aafae 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -690,6 +690,10 @@
                                              (funcall val env))
                                        (funcall more new-env)))))))))
                 (prepare-let* bindings context))))
+           ((load-time-value)
+            (let ((load-form (cadr form)))
+              ;; FIXME
+              (prepare-form load-form)))
            ((locally)
             (prepare-nil))
            ((multiple-value-call)
-- 
cgit v1.2.3


From 9a8ab9219e03e04c65b3a465aaeb5c973020a2fb Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Mon, 15 Jul 2013 15:56:48 +0200
Subject: LAMBDA: Bail out on complex lambda lists. Conflicts: 	sb-eval2.lisp

---
 sb-eval2.lisp | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

(limited to 'sb-eval2.lisp')

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index f5c3ad8..6b5ffc1 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -455,7 +455,9 @@
         (sb-int:parse-lambda-list lambda-list)
       (declare (ignorable required optional restp rest keyp keys allowp auxp aux
                           morep more-context more-count))
-      (let* ((argvars lambda-list)    ;fixme
+        (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)))
              (envp (maybe-closes-over-p `(progn ,@body) argvars))
              (new-context (if envp
-- 
cgit v1.2.3


From e46cbe4750338333088c4b67c0f7e83c41eb6a9b Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Mon, 15 Jul 2013 16:00:22 +0200
Subject: Fix indentation.

---
 sb-eval2.lisp | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

(limited to 'sb-eval2.lisp')

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 6b5ffc1..1b99129 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -455,9 +455,9 @@
         (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
+      (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)))
              (envp (maybe-closes-over-p `(progn ,@body) argvars))
              (new-context (if envp
-- 
cgit v1.2.3


From 25913996c924ebe7a40ce10c83a98ba817151abe Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Tue, 16 Jul 2013 07:52:07 +0200
Subject: PREPARE-GLOBAL-CALL: Deal with redefinition by using
 FDEFINITION-OBJECTs. Conflicts: 	sb-eval2.lisp

---
 sb-eval2.lisp | 33 ++++++++++++---------------------
 1 file changed, 12 insertions(+), 21 deletions(-)

(limited to 'sb-eval2.lisp')

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 1b99129..830901a 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -402,7 +402,8 @@
 
 (declaim (ftype (function ((or symbol list) list context) eval-closure) prepare-global-call))
 (defun prepare-global-call (f args context)
-  (let ((args* (mapcar (lambda (form) (prepare-form form context)) args)))
+  (let ((args* (mapcar (lambda (form) (prepare-form form context)) args))
+        (f* (sb-c::fdefinition-object f t)))
     (if (< (length args) 20)
         (specialize m% (length args) (loop for i from 0 below 20 collect i)
           (let ((argvars (loop for i from 0 below m%
@@ -410,26 +411,16 @@
             `(let ,(loop for var in argvars
                          for i from 0 below m%
                          collect `(,var (nth ,i args*)))
-               (if (fboundp f)
-                   (let ((f* (fdefinition f)))
-                     (lambda (env)
-                       (declare (ignorable env))
-                       (funcall f*
-                                ,@(loop for var in argvars
-                                        collect `(funcall (the eval-closure ,var) env)))))
-                   (lambda (env)
-                     (declare (ignorable env))
-                     (funcall (fdefinition f)
-                              ,@(loop for var in argvars
-                                      collect `(funcall (the eval-closure ,var) env))))))))
-        (if (fboundp f)
-            (let ((f* (fdefinition f)))
-              (lambda (env)
-                (apply f*
-                       (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*))))
-            (lambda (env)
-              (apply (fdefinition f)
-                     (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*)))))))
+               (lambda (env)
+                 (declare (ignorable env))
+                 (funcall (or (sb-c::fdefn-fun f*)
+                              (error 'undefined-function :name f))
+                          ,@(loop for var in argvars
+                                  collect `(funcall (the eval-closure ,var) env)))))))
+        (lambda (env)
+          (apply (or (sb-c::fdefn-fun f*)
+                     (error 'undefined-function :name f))
+                 (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*))))))
 
 (declaim (ftype (function (eval-closure list context) eval-closure) prepare-direct-call))
 (defun prepare-direct-call (f args context)
-- 
cgit v1.2.3


From fe68d8da059dc0a3494c817732ef8f96805568fd Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Tue, 16 Jul 2013 11:41:06 +0200
Subject: Simplify PREPARE-LAMBDA to rely on &MORE optimization.

---
 sb-eval2.lisp | 57 +++++++++++++++++----------------------------------------
 1 file changed, 17 insertions(+), 40 deletions(-)

(limited to 'sb-eval2.lisp')

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 830901a..4ccd1ae 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -455,46 +455,23 @@
                               (context-add-env-lexicals context argvars)
                               (context-add-stack-lexicals context argvars)))
              (body* (prepare-progn body new-context)))
-        (if (< n 20)
-            (specialize m% n (loop for i from 0 below 20 collect i)
-              (let ((args (loop for i from 0 below m%
-                                collect (gensym (format nil "ARG~D-" i)))))
-                `(if envp
-                     (lambda (env)
-                       (lambda ,args
-                         ;; FIXME: non-simple lambda-lists
-                         (let ((new-env (make-environment env ,m%)))
-                           ,@(loop for i from 0
-                                   for val in args
-                                   collect `(setf (environment-value new-env 0 ,i) ,val))
-                           (funcall body* new-env))))
-                     (lambda (env)
-                       (lambda ,args
-                         ;; FIXME: non-simple lambda-lists
-                         (with-stack-frame ,m%
-                           ,@(loop for i from 0
-                                   for val in args
-                                   collect `(setf (stack-ref 0 ,i) ,val))
-                           (funcall body* env)))))))
-            (if envp
-                (lambda (env)
-                  (lambda (&rest args)
-                    (declare (dynamic-extent args))
-                    ;; FIXME: non-simple lambda-lists
-                    (let ((new-env (make-environment env n)))
-                      (loop for i from 0 to n
-                            for val in args
-                            do (setf (environment-value new-env 0 i) val))
-                      (funcall body* new-env))))
-                (lambda (env)
-                  (lambda (&rest args)
-                    (declare (dynamic-extent args))
-                    ;; FIXME: non-simple lambda-lists
-                    (with-stack-frame n
-                      (loop for i from 0 below n
-                            for val in args
-                            do (setf (stack-ref 0 i) val))
-                      (funcall body* env))))))))))
+        (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)))))))))
 
 
 (defun context->native-environment (context)
-- 
cgit v1.2.3


From 68f5f71d4a787dc0a1662d16121db7f40eb8c09c Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Tue, 16 Jul 2013 17:38:37 +0200
Subject: Implement lambda-lists properly.

---
 sb-eval2.lisp | 169 +++++++++++++++++++++++++++++++++++++++++++++++++---------
 1 file changed, 145 insertions(+), 24 deletions(-)

(limited to 'sb-eval2.lisp')

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)
-- 
cgit v1.2.3


From 7d80fddca07fda51e3400e8b4dd917e96c4a8b71 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Tue, 16 Jul 2013 18:07:19 +0200
Subject: PREPARE-LAMBDA: Stack-allocate environments instead of managing a
 stack.

---
 sb-eval2.lisp | 44 +++++++++++++++++++++++++++++++-------------
 1 file changed, 31 insertions(+), 13 deletions(-)

(limited to 'sb-eval2.lisp')

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index ec15ef9..f153590 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -21,15 +21,34 @@
 (deftype stack ()
   'simple-vector)
 
-(defstruct (environment (:constructor make-environment (parent
-                                                        &optional (size 0)
-                                                        &aux (data
-                                                              (make-array
-                                                               (list size))))))
+(declaim (inline %make-environment))
+(defstruct (environment (:constructor %make-environment))
   (parent nil :type (or null environment))
-  (data nil :type simple-vector))
+  (data nil :type (or null simple-vector)))
+
+(declaim (inline make-null-environment))
 (defun make-null-environment () (make-environment nil 0))
 
+(declaim (inline make-environment))
+(defun make-environment (parent
+                         &optional (size 0)
+                         &aux (data
+                               (unless (zerop (the fixnum size))
+                                 (make-array
+                                  (list size)))))
+  (%make-environment :parent parent :data data))
+
+(defmacro with-dynamic-extent-environment ((var parent size) &body body)
+  (let ((data% (gensym))
+        (size% (gensym)))
+    `(let* ((,size% ,size)
+            (,data% (make-array (list ,size%)))
+            (,var (%make-environment :parent ,parent :data ,data%)))
+       (declare (type (mod 1000) ,size%)
+                (dynamic-extent ,var)
+                (dynamic-extent ,data%))
+       ,@body)))
+
 (defclass lexical ()
   ((name    :accessor lexical-name    :initarg :name    :type (or symbol list))))
 
@@ -486,10 +505,9 @@
              (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)))
+             (envp (or (> varnum 1000)
+                       (maybe-closes-over-p `(progn ,@body) argvars)))
+             (new-context (context-add-env-lexicals context argvars))
              (default-values (append (mapcar #'lambda-binding-default optional)
                                      (mapcar #'lambda-binding-default keys)
                                      (mapcar #'lambda-binding-default aux)))
@@ -580,9 +598,9 @@
               (lambda (env)
                 (lambda (&rest args)
                   (declare (dynamic-extent args))
-                  (with-stack-frame varnum
-                    (handle-arguments args (stack-ref) env)
-                    (funcall body* env))))))))))
+                  (with-dynamic-extent-environment (new-env env varnum)
+                    (handle-arguments args (environment-value new-env) new-env)
+                    (funcall body* new-env))))))))))
 
 
 (defun context->native-environment (context)
-- 
cgit v1.2.3


From 3e973cf67af0dbfc18af6fa5f5e2a5c67e3b70d2 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Tue, 16 Jul 2013 18:30:47 +0200
Subject: PREPARE-LAMBDA: Support &KEY ((:keyword var) ...) syntax.

---
 sb-eval2.lisp | 8 ++++++--
 1 file changed, 6 insertions(+), 2 deletions(-)

(limited to 'sb-eval2.lisp')

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index f153590..4097de4 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -458,7 +458,9 @@
 
 (defun lambda-binding-vars (entry)
   (etypecase entry
-    (cons   (list (first entry)
+    (cons   (list (etypecase (first entry)
+                    (cons   (second (first entry)))
+                    (symbol (first entry)))
                   (if (cddr entry)
                       (third entry)
                       (gensym))))
@@ -478,7 +480,9 @@
   (flet ((keywordify (sym)
            (intern (symbol-name sym) "KEYWORD")))
     (etypecase entry
-      (cons   (keywordify (first entry)))
+      (cons   (etypecase (first entry)
+                (cons   (first (first entry)))
+                (symbol (keywordify (first entry)))))
       (symbol (keywordify entry)))))
 
 (declaim (ftype (function (list context) eval-closure) prepare-lambda))
-- 
cgit v1.2.3


From 47a8aeb3ddeaf7a5ece13b8dbb01f68673fb7b44 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Tue, 16 Jul 2013 18:55:42 +0200
Subject: Remove explicit stack management.

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

(limited to 'sb-eval2.lisp')

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 4097de4..ccb0d14 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -8,9 +8,7 @@
 ;;(declaim (optimize (debug 3) (space 0) (speed 0) (safety 3) (compilation-speed 0)))
 (declaim (optimize (debug 0) (space 0) (speed 3) (safety 0) (compilation-speed 0)))
 
-(defvar *stack*)
-(defvar *fp*)
-(defvar *sp*)
+(defconstant +stack-max+ 1000)
 
 (defmacro specialize (&environment env var value possible-values &body body)
   `(ecase ,value
@@ -18,9 +16,6 @@
              collect
                 `((,x) ,(sb-int:eval-in-lexenv `(let ((,var ,x)) ,@body) env)))))
 
-(deftype stack ()
-  'simple-vector)
-
 (declaim (inline %make-environment))
 (defstruct (environment (:constructor %make-environment))
   (parent nil :type (or null environment))
@@ -44,7 +39,7 @@
     `(let* ((,size% ,size)
             (,data% (make-array (list ,size%)))
             (,var (%make-environment :parent ,parent :data ,data%)))
-       (declare (type (mod 1000) ,size%)
+       (declare (type (mod #.+stack-max+) ,size%)
                 (dynamic-extent ,var)
                 (dynamic-extent ,data%))
        ,@body)))
@@ -56,18 +51,10 @@
   ((offset  :accessor lexical-offset  :initarg :offset  :type fixnum)
    (nesting :accessor lexical-nesting :initarg :nesting :type fixnum)))
 
-(defclass stack-lexical (lexical)
-  ((offset  :accessor lexical-offset  :initarg :offset  :type fixnum)
-   (nesting :accessor lexical-nesting :initarg :nesting :type fixnum)))
-
-(defun make-stack-lexical (name offset &optional (nesting -1))
-  (make-instance 'stack-lexical :name name :offset offset :nesting nesting))
 (defun make-env-lexical (name offset &optional (nesting -1))
   (make-instance 'env-lexical :name name :offset offset :nesting nesting))
 
 (defgeneric lexical-with-nesting (lexical nesting))
-(defmethod lexical-with-nesting ((lexical stack-lexical) nesting)
-  (make-stack-lexical (lexical-name lexical) (lexical-offset lexical) nesting))
 (defmethod lexical-with-nesting ((lexical env-lexical) nesting)
   (make-env-lexical (lexical-name lexical) (lexical-offset lexical) nesting))
 
@@ -116,7 +103,6 @@
 (defstruct (context (:constructor make-context (&optional parent)))
   parent
   (env-hop nil :type boolean)
-  (stack-hop nil :type boolean)
   (block-tags nil :type list)
   (go-tags nil :type list)
   (symbol-macros nil :type list)
@@ -188,29 +174,10 @@
                            for v in vars
                            collect (make-env-lexical v i))))
     new-context))
-(defun context-bump-stack (context)
-  (let ((new-context (make-context context)))
-    (with-slots (stack-hop)
-        new-context
-      (setq stack-hop t))
-    new-context))
-(defun context-add-stack-lexicals (context vars)
-  ;; open a new variable context
-    (let ((new-context (make-context context)))
-    (with-slots (lexicals stack-hop)
-        new-context
-      (setq stack-hop t)
-      (setq lexicals (loop for i fixnum from 0
-                           for v in vars
-                           collect (make-stack-lexical v i))))
-    new-context))
 (defun context-add-env-functions (context fs)
   (context-add-env-lexicals context (mapcar (lambda (x) `(function ,x)) fs)))
-(defun context-add-stack-functions (context fs)
-  (context-add-stack-lexicals context (mapcar (lambda (x) `(function ,x)) fs)))
 (defun context-find-lexical (context var)
   (loop with env-level = 0
-        with stack-level = 0
         until (null context)
         for record = (find var
                            (context-lexicals context)
@@ -219,12 +186,9 @@
         when record
           do (return
                (etypecase record
-                 (env-lexical   (lexical-with-nesting record env-level))
-                 (stack-lexical (lexical-with-nesting record stack-level))))
+                 (env-lexical   (lexical-with-nesting record env-level))))
         when (context-env-hop context)
           do (incf env-level)
-        when (context-stack-hop context)
-          do (incf stack-level)
         do (setq context (context-parent context))))
 
 (deftype eval-closure () `(function (environment) *))
@@ -241,112 +205,6 @@
     (setq env (environment-parent env)))
   (setf (svref (environment-data env) offset) val))
 
-(defmacro with-stack (() &body body)
-  `(call-with-stack (lambda () ,@body)))
-
-(declaim (inline call-with-stack))
-(defun call-with-stack (thunk)
-  (let ((*stack* (make-array '(10000)))
-        (*fp* 0)
-        (*sp* 0))
-    (funcall thunk)))
-
-(defmacro with-stack-frame (nvars &body body)
-  `(call-with-stack-frame ,nvars (lambda () ,@body)))
-
-(declaim (ftype (function (fixnum function) *) really-call-with-stack-frame)
-         (inline really-call-with-stack-frame))
-(defun really-call-with-stack-frame (nvars thunk)
-  (let* ((stack *stack*)
-         (sp *sp*)
-         (new-size (+ sp nvars 1)))
-    (declare (type stack stack)
-             (type fixnum sp new-size))
-    (loop for size fixnum = (array-dimension stack 0)
-          while (< size new-size)
-          do (setq stack
-                   (adjust-array stack
-                                 (list (the fixnum
-                                            (+ new-size (the fixnum
-                                                             (round (* size 1.5))))))))
-             (setq *stack* stack))
-    (setf (aref stack sp) (the fixnum *fp*))
-    (let ((*fp* sp)
-          (*sp* new-size))
-      (funcall thunk))))
-
-(declaim (ftype (function (fixnum function) *) call-with-stack-frame)
-         (inline call-with-stack-frame))
-(defun call-with-stack-frame (nvars thunk)
-  (if (boundp '*stack*)
-      (really-call-with-stack-frame nvars thunk)
-      (with-stack () (really-call-with-stack-frame nvars thunk))))
-
-(declaim (ftype (function (fixnum) *) deref-stack)
-         (inline deref-stack))
-(defun deref-stack (pos)
-  (aref (the stack *stack*) pos))
-
-(declaim (ftype (function (* fixnum) *) (setf deref-stack))
-         (inline (setf deref-stack)))
-(defun (setf deref-stack) (val pos)
-  (setf (aref (the stack *stack*) pos) val))
-
-(declaim (ftype (function (fixnum fixnum) *) stack-ref)
-         (inline stack-ref))
-(defun stack-ref (nesting offset)
-  (let ((pos (the fixnum *fp*)))
-    (dotimes (i nesting)
-      (setq pos (the fixnum (deref-stack pos))))
-    (deref-stack (the fixnum (+ 1 offset pos)))))
-
-(declaim (ftype (function (fixnum) *) stack-ref0)
-         (inline stack-ref0))
-(defun stack-ref0 (offset)
-  (deref-stack (the fixnum (+ (the fixnum (+ 1 (the fixnum *fp*))) offset))))
-
-(define-compiler-macro stack-ref (&whole form
-                                  &environment env
-                                  nesting offset)
-  (if (constantp nesting env)
-      (let ((num (sb-int:eval-in-lexenv nesting env)))
-        (if (zerop num)
-            `(stack-ref0 (the fixnum ,offset))
-            `(progn
-               (let ((pos *fp*))
-                 ,@(loop for i from 1 to num
-                         collect `(setq pos (the fixnum (deref-stack pos))))
-                 (deref-stack (the fixnum (+ 1 (the fixnum (+ (the fixnum ,offset) pos)))))))))
-      form))
-
-(declaim (ftype (function (* fixnum fixnum) *) (setf stack-ref))
-         (inline (setf stack-ref)))
-(defun (setf stack-ref) (val nesting offset)
-  (let ((pos *fp*))
-    (declare (type fixnum pos))
-    (dotimes (i nesting)
-      (setq pos (deref-stack pos)))
-    (setf (deref-stack (the fixnum (+ 1 offset pos))) val)))
-
-(declaim (ftype (function (* fixnum) *) (setf stack-ref0))
-         (inline (setf stack-ref0)))
-(defun (setf stack-ref0) (val offset)
-  (setf (deref-stack (the fixnum (+ (the fixnum (+ 1 (the fixnum *fp*))) offset))) val))
-
-(define-compiler-macro (setf stack-ref) (&whole form
-                                         &environment env
-                                         val nesting offset)
-  (if (constantp nesting env)
-      (let ((num (sb-int:eval-in-lexenv nesting env)))
-        (if (zerop num)
-            `(setf (stack-ref0 (the fixnum ,offset)) ,val)
-            `(progn
-               (let ((pos *fp*))
-                 ,@(loop for i from 1 to num
-                         collect `(setq pos (the fixnum (deref-stack pos))))
-                 (setf (deref-stack (the fixnum (+ 1 (the fixnum (+ (the fixnum ,offset) pos))))) ,val)))))
-      form))
-
 (declaim (ftype (function (symbol context) eval-closure) prepare-ref))
 (defun prepare-ref (var context)
   (if (context-var-lexical-p context var)
@@ -356,18 +214,7 @@
         (etypecase lexical
           (env-lexical
            (lambda (env)
-             (environment-value env nesting offset)))
-          (stack-lexical
-           (if (< nesting 20)
-               (specialize m% nesting (loop for i from 0 below 20 collect i)
-                 `(lambda (env)
-                    (declare (ignore env))
-                    ;;(format t "~&; stack-ref ~d ~d" nesting offset)
-                    (stack-ref ,m% offset)))
-               (lambda (env)
-                 (declare (ignore env))
-                 ;;(format t "~&; stack-ref ~d ~d" nesting offset)
-                 (stack-ref nesting offset))))))
+             (environment-value env nesting offset)))))
       (lambda (env)
         (declare (ignore env))
         (symbol-value var))))
@@ -509,7 +356,7 @@
              (key-num (length keys))
              (aux-num (length aux))
              (varnum (length argvars))
-             (envp (or (> varnum 1000)
+             (envp (or (> varnum +stack-max+)
                        (maybe-closes-over-p `(progn ,@body) argvars)))
              (new-context (context-add-env-lexicals context argvars))
              (default-values (append (mapcar #'lambda-binding-default optional)
@@ -671,17 +518,6 @@
                                                          (lexical-nesting lexical?)
                                                          (lexical-offset lexical?))
                                       value))
-                               (stack-lexical
-                                (let ((nesting (lexical-nesting lexical?))
-                                      (offset (lexical-offset lexical?)))
-                                  (if (< nesting 20)
-                                      (specialize m%
-                                          nesting
-                                          (loop for i from 0 below 20 collect i)
-                                        `(setf (stack-ref ,m% offset)
-                                               value))
-                                      (setf (stack-ref nesting offset)
-                                            value))))
                                (null
                                 (setf (symbol-value var) value))))
                         finally (return result))))))
@@ -757,42 +593,37 @@
                                                   (cons form nil)))
                                             bindings))
                      (vars (mapcar #'car real-bindings))
-                     (envp (maybe-closes-over-p `(progn ,@body) vars))
-                     (binding-context (if envp
-                                          context
-                                          (context-bump-stack context)))
+                     (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*)))
+                     (values* (mapcar #'cdr bindings*))
+                     (new-context
+                       (context-add-env-lexicals context
+                                                 (mapcar #'first bindings*)))
+                     (body*
+                       (prepare-progn body new-context)))
                 (if envp
-                    (let* ((new-context
-                             (context-add-env-lexicals context
-                                                       (mapcar #'first bindings*)))
-                           (body*
-                             (prepare-progn body new-context)))
-                      (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*) env)))
-                          (funcall body* new-env))))
-                    (let* ((new-context
-                             (context-add-stack-lexicals context
-                                                         (mapcar #'first bindings*)))
-                           (body*
-                             (prepare-progn body new-context)))
-                      (lambda (env)
-                        (with-stack-frame n
-                          (loop for i from 0 below n
-                                for val* in values*
-                                do (setf (stack-ref 0 i)
-                                         (funcall (the eval-closure val*) env)))
-                          (funcall body* env))))))))
+                    (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*) 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*) env)))
+                        (funcall body* new-env)))))))
            ((let*)
             ;; FIXME: SPECIAL declarations!
             (destructuring-bind (bindings &rest body) (rest form)
@@ -1004,11 +835,10 @@
          (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))
+(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)
-- 
cgit v1.2.3


From 838ad3bbecb1feb8d611ad7c29bff9160a274a1a Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Tue, 16 Jul 2013 18:56:21 +0200
Subject: PREPARE-LAMBDA: Simplify.

---
 sb-eval2.lisp | 26 +++++++++++++-------------
 1 file changed, 13 insertions(+), 13 deletions(-)

(limited to 'sb-eval2.lisp')

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index ccb0d14..8d05ba9 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -366,7 +366,7 @@
                (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)
+        (macrolet ((handle-arguments (args env)
                      ;; All this ELT and LENGTH stuff is not as
                      ;; inefficient as it looks.  SBCL transforms
                      ;; &rest into &more here.
@@ -384,11 +384,11 @@
                              (go missing-optionals))
                            (when (>= argi (the fixnum (+ required-num optional-num)))
                              (go keys))
-                           (setf (,@env-ref 0 vari) (elt ,args argi))
+                           (setf (environment-value ,env 0 vari) (elt ,args argi))
                            (when (>= argi required-num)
                              (pop default-values*)
                              (incf vari)
-                             (setf (,@env-ref 0 vari) t))
+                             (setf (environment-value ,env 0 vari) t))
                            (incf vari)
                            (incf argi)
                            (go positional)
@@ -397,9 +397,9 @@
                            (when (>= vari (the fixnum (+ required-num (the fixnum (* 2 optional-num)))))
                              (go keys))
                            (let ((val* (pop default-values*)))
-                             (setf (,@env-ref 0 vari)
+                             (setf (environment-value ,env 0 vari)
                                    (funcall (the eval-closure val*) ,env)
-                                   (,@env-ref 0 (1+ vari))
+                                   (environment-value ,env 0 (1+ vari))
                                    nil))
                            (incf vari 2)
                            (go missing-optionals)
@@ -412,13 +412,13 @@
                                   (val* (pop default-values*))
                                   (x    (getf rest key unbound)))
                              (if (eq unbound x)
-                                 (setf (,@env-ref 0 vari)
+                                 (setf (environment-value ,env 0 vari)
                                        (funcall (the eval-closure val*) ,env)
-                                       (,@env-ref 0 (1+ vari))
+                                       (environment-value ,env 0 (1+ vari))
                                        nil)
-                                 (setf (,@env-ref 0 vari)
+                                 (setf (environment-value ,env 0 vari)
                                        x
-                                       (,@env-ref 0 (1+ vari))
+                                       (environment-value ,env 0 (1+ vari))
                                        t)))
                            (incf vari 2)
                            (go keys)
@@ -430,27 +430,27 @@
                                              aux-num)))
                              (go rest))
                            (let ((val* (pop default-values*)))
-                             (setf (,@env-ref 0 vari)
+                             (setf (environment-value ,env 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))
+                             (setf (environment-value ,env 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)
+                    (handle-arguments args new-env)
                     (funcall body* new-env))))
               (lambda (env)
                 (lambda (&rest args)
                   (declare (dynamic-extent args))
                   (with-dynamic-extent-environment (new-env env varnum)
-                    (handle-arguments args (environment-value new-env) new-env)
+                    (handle-arguments args new-env)
                     (funcall body* new-env))))))))))
 
 
-- 
cgit v1.2.3