[armedbear-cvs] r14058 - trunk/abcl/src/org/armedbear/lisp

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Sun Aug  5 13:27:10 2012
New Revision: 14058

Log:
Follow up to r14054, efficient arguments option variable references
for &rest and &key.

Modified:
   trunk/abcl/src/org/armedbear/lisp/clos.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sun Aug  5 00:01:37 2012	(r14057)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sun Aug  5 13:27:10 2012	(r14058)
@@ -1254,6 +1254,9 @@
   (multiple-value-bind
         (whole required optional rest keys aux)
       (parse-define-method-combination-args-lambda-list args-lambda-list)
+    (unless rest
+      (when keys
+        (setf rest (gensym))))
     (let* ((gf-lambda-list (gensym))
            (args-var (gensym))
            (args-len-var (when (or (some #'second optional)
@@ -1272,8 +1275,12 @@
                (let* (,@(when whole
                               `((,whole ',args-var)))
                       ,@(when rest
-                              `((,rest `(subseq ,',args-var
-                                                (+ ,nreq ,nopt)))))
+                              `((,rest (progn
+                                         (push `(,',rest
+                                                 (subseq ,',args-var
+                                                          ,(+ nreq nopt)))
+                                               ,binding-forms)
+                                         ',rest))))
                         ,@(loop for var in required
                              and i upfrom 0
                              collect `(,var (when (< ,i nreq)
@@ -1307,14 +1314,24 @@
                                                           ,',initform))
                                                     ,binding-forms)
                                               ',var-binding)))
-                        ,@(loop for ((key var) initform) in keys
+                        ,@(loop for ((key var) initform supplied-var) in keys
+                             for supplied-binding = (or supplied-var (gensym))
+                             for var-binding = (gensym)
                              ;; Same as optional parameters:
                              ;; even though keywords can't be supplied in
                              ;; excess, we should bind "supplied-p" in case
                              ;; the key isn't supplied in the arguments list
-                             collect `(,var `(getk (subseq ,',args-var
-                                                           (+ ,nreq ,nopt)) ,',key
-                                                           ,',initform)))
+                             collect `(,supplied-binding
+                                       (progn
+                                         (push `(,',supplied-binding
+                                                 (member ,',key ,',rest)))
+                                         ',supplied-binding))
+                             collect `(,var (progn
+                                              (push `(,',var-binding
+                                                      (if ,',supplied-binding
+                                                          (cadr ,',supplied-binding)
+                                                          ,',initform))
+                                                    ,binding-forms))))
                         ,@(loop for (var initform) in aux
                              for var-binding = (gensym)
                              collect `(,var (progn