From 916638fbbd10a8921c2b70a4e6c2693c6101517b Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Sat, 20 Jul 2013 17:51:07 +0200
Subject: LAMBDA: Do not generate spurious extra gensym'd variables for &AUX
 bindings.

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

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 8216bdf..1a58111 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -388,15 +388,26 @@
               (funcall (the eval-closure form*) env))
             (funcall (the eval-closure last-form*) env))))))
 
-(defun lambda-binding-vars (entry)
-  (etypecase entry
-    (cons   (list (etypecase (first entry)
-                    (cons   (second (first entry)))
-                    (symbol (first entry)))
-                  (if (cddr entry)
-                      (third entry)
-                      (gensym))))
-    (symbol (list entry (gensym)))))
+(defun lambda-binding-vars (entry kind)
+  (check-type kind (member :aux :optional :key :required))
+  (ecase kind
+    ((:key :optional)
+     (etypecase entry
+       (cons   (list (etypecase (first entry)
+                       (cons   (second (first entry)))
+                       (symbol (first entry)))
+                     (if (cddr entry)
+                         (third entry)
+                         (gensym))))
+       (symbol (list entry (gensym)))))
+    ((:required)
+     (etypecase entry
+       (cons   (list (first entry)))
+       (symbol entry)))
+    ((:aux)
+     (etypecase entry
+       (cons   (list (first entry)))
+       (symbol entry)))))
 
 (defun lambda-binding-main-var (entry)
   (etypecase entry
@@ -465,10 +476,10 @@
           (error "The interpreter does not support the lambda-list keyword ~S"
                  'sb-int:&more))
         (let* ((argvars (append required
-                                (mapcan #'lambda-binding-vars optional)
+                                (mapcan (lambda (x) (lambda-binding-vars x :optional)) optional)
                                 (and restp (list rest))
-                                (mapcan #'lambda-binding-vars keys)
-                                (mapcan #'lambda-simple-binding-vars aux)))
+                                (mapcan (lambda (x) (lambda-binding-vars x :key)) keys)
+                                (mapcan (lambda (x) (lambda-binding-vars x :aux)) aux)))
                (keywords (mapcar #'lambda-key keys))
                (required-num (length required))
                (optional-num (length optional))
@@ -492,16 +503,16 @@
                                 (push :lexical varspecs)
                                 (incf (the fixnum varnum))))))
                    (mapc #'register-var required)
-                   (flet ((process-bindings (bindings)
+                   (flet ((process-bindings (bindings kind)
                             (loop for binding in bindings
                                   for default-value = (lambda-binding-default binding)
-                                  for vars = (lambda-binding-vars binding)
+                                  for vars = (lambda-binding-vars binding kind)
                                   collect (prepare-form default-value new-context)
                                   do (mapc #'register-var vars))))
-                     (append (process-bindings optional)
+                     (append (process-bindings optional :optional)
                              (progn (when restp (register-var rest)) '())
-                             (process-bindings keys)
-                             (process-bindings aux)))))
+                             (process-bindings keys :key)
+                             (process-bindings aux :aux)))))
                (envp (or (> varnum +stack-max+)
                          (maybe-closes-over-p context `(progn ,@body) argvars)
                          (some (lambda (x) (maybe-closes-over-p context x argvars))
-- 
cgit v1.2.3