X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fpcl%2Fcombin.lisp;h=b6a0fc142bcc737b6d932b4936e402d6238cb367;hb=7d853ed1882221bc790062e423a74a620f6e4ee1;hp=b2743d33becbecc32c06f61aaa7135c1e1da9c91;hpb=832f3b5652ae1b4a8888829cd4a1b391a8ca9952;p=sbcl.git

diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index b2743d3..b6a0fc1 100644
--- a/src/pcl/combin.lisp
+++ b/src/pcl/combin.lisp
@@ -216,10 +216,9 @@
 
 (defun expand-effective-method-function (gf effective-method &optional env)
   (declare (ignore env))
-  (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
+  (multiple-value-bind (nreq applyp)
       (get-generic-fun-info gf)
-    (declare (ignore nreq nkeys arg-info))
-    (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
+    (let ((ll (make-fast-method-call-lambda-list nreq applyp))
           (check-applicable-keywords
            (when (and applyp (gf-requires-emf-keyword-checks gf))
              '((check-applicable-keywords))))
@@ -243,13 +242,13 @@
              (declare (ignorable #'%no-primary-method #'%invalid-qualifiers))
              ,effective-method)))
         (mc-args-p
-         (let* ((required
-                 ;; FIXME: Ick. Shared idiom, too, with stuff in cache.lisp
-                 (let (req)
-                   (dotimes (i (length metatypes) (nreverse req))
-                     (push (dfun-arg-symbol i) req))))
+         (let* ((required (make-dfun-required-args nreq))
                 (gf-args (if applyp
-                             `(list* ,@required .dfun-rest-arg.)
+                             `(list* ,@required
+                                     (sb-c::%listify-rest-args
+                                      .dfun-more-context.
+                                      (the (and unsigned-byte fixnum)
+                                        .dfun-more-count.)))
                              `(list ,@required))))
            `(lambda ,ll
              (declare (ignore .pv-cell. .next-method-call.))
@@ -310,7 +309,7 @@
     (call-method
      (let ((gensym (get-effective-method-gensym)))
        (values (make-emf-call
-                metatypes applyp gensym
+                (length metatypes) applyp gensym
                 (make-effective-method-fun-type
                  generic-function form method-alist-p wrappers-p))
                (list gensym))))
@@ -319,13 +318,14 @@
            (type (make-effective-method-list-fun-type
                   generic-function form method-alist-p wrappers-p)))
        (values `(dolist (emf ,gensym nil)
-                 ,(make-emf-call metatypes applyp 'emf type))
+                 ,(make-emf-call (length metatypes) applyp 'emf type))
                (list gensym))))
     (check-applicable-keywords
-     (values `(check-applicable-keywords
-               .dfun-rest-arg. .keyargs-start. .valid-keys.)
+     (values `(check-applicable-keywords .keyargs-start.
+                                         .valid-keys.
+                                         .dfun-more-context.
+                                         .dfun-more-count.)
              '(.keyargs-start. .valid-keys.)))
-
     (t
      (default-code-converter form))))
 
@@ -488,34 +488,41 @@
         (aver any-keyp)
         (values (if allowp t keys) nopt)))))
 
-(defun check-applicable-keywords (args start valid-keys)
+(defun check-applicable-keywords (start valid-keys more-context more-count)
   (let ((allow-other-keys-seen nil)
         (allow-other-keys nil)
-        (args (nthcdr start args)))
-    (collect ((invalid))
-      (loop
-       (when (null args)
-         (when (and (invalid) (not allow-other-keys))
-           (error 'simple-program-error
-                  :format-control "~@<invalid keyword argument~P: ~
+        (i start))
+    (declare (type index i more-count)
+             (optimize speed))
+    (flet ((current-value ()
+             (sb-c::%more-arg more-context i)))
+      (declare (inline current-value))
+      (collect ((invalid))
+        (loop
+           (when (>= i more-count)
+             (when (and (invalid) (not allow-other-keys))
+               (error 'simple-program-error
+                      :format-control "~@<invalid keyword argument~P: ~
                                    ~{~S~^, ~} (valid keys are ~{~S~^, ~}).~@:>"
-                  :format-arguments (list (length (invalid)) (invalid) valid-keys)))
-         (return))
-       (let ((key (pop args)))
-         (cond
-           ((not (symbolp key))
-            (error 'simple-program-error
-                   :format-control "~@<keyword argument not a symbol: ~S.~@:>"
-                   :format-arguments (list key)))
-           ((null args) (sb-c::%odd-key-args-error))
-           ((eq key :allow-other-keys)
-            ;; only the leftmost :ALLOW-OTHER-KEYS has any effect
-            (unless allow-other-keys-seen
-              (setq allow-other-keys-seen t
-                    allow-other-keys (car args))))
-           ((eq t valid-keys))
-           ((not (memq key valid-keys)) (invalid key))))
-       (pop args)))))
+                      :format-arguments (list (length (invalid)) (invalid) valid-keys)))
+             (return))
+           (let ((key (current-value)))
+             (incf i)
+             (cond
+               ((not (symbolp key))
+                (error 'simple-program-error
+                       :format-control "~@<keyword argument not a symbol: ~S.~@:>"
+                       :format-arguments (list key)))
+               ((= i more-count)
+                (sb-c::%odd-key-args-error))
+               ((eq key :allow-other-keys)
+                ;; only the leftmost :ALLOW-OTHER-KEYS has any effect
+                (unless allow-other-keys-seen
+                  (setq allow-other-keys-seen t
+                        allow-other-keys (current-value))))
+               ((eq t valid-keys))
+               ((not (memq key valid-keys)) (invalid key))))
+           (incf i))))))
 
 ;;;; the STANDARD method combination type. This is coded by hand
 ;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping