X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=79ac11b3113a4e27cc4e853145f2c43d39efc79a;hb=28b2447f2775779fe49fd024d8cce069060431c6;hp=52d9ece6665b31a741a0b5e5a0933d86b7c7791d;hpb=05e9b542c5700416b8fd9f3ba9bb91bb6ab84b3a;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 52d9ece..79ac11b 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -560,6 +560,7 @@
                               :generic-function generic-function
                               :method method)
                 (update-dfun generic-function))
+              (setf (gf-info-needs-update generic-function) t)
               (map-dependents generic-function
                               (lambda (dep)
                                 (update-dependent generic-function
@@ -587,11 +588,54 @@
                         :generic-function generic-function
                         :method method)
           (update-dfun generic-function)
+          (setf (gf-info-needs-update generic-function) t)
           (map-dependents generic-function
                           (lambda (dep)
                             (update-dependent generic-function
                                               dep 'remove-method method)))))))
   generic-function)
+
+
+;; Tell INFO about the generic function's methods' keys so that the
+;; compiler doesn't complain that the keys defined for some method are
+;; unrecognized.
+(sb-ext:without-package-locks
+  (defun sb-c::maybe-update-info-for-gf (name)
+    (let ((gf (if (fboundp name) (fdefinition name))))
+      (when (and gf (generic-function-p gf) (not (early-gf-p gf))
+                 (not (eq :declared (info :function :where-from name)))
+                 (gf-info-needs-update gf))
+        (let* ((methods (generic-function-methods gf))
+               (gf-lambda-list (generic-function-lambda-list gf))
+               (tfun (constantly t))
+               keysp)
+          (multiple-value-bind
+              (gf.required gf.optional gf.rest ignore gf.allowp)
+              (%split-arglist gf-lambda-list)
+            (declare (ignore ignore))
+            (setf (info :function :type name)
+                  (specifier-type
+                   `(function
+                     (,@(mapcar tfun gf.required)
+                        ,@(if gf.optional
+                              `(&optional ,@(mapcar tfun gf.optional)))
+                        ,@(if gf.rest
+                              `(&rest t))
+                        ,@(let ((all-keys
+                                 (mapcar
+                                  (lambda (x)
+                                    (list x t))
+                                  (remove-duplicates
+                                   (mapcan #'function-keywords methods)))))
+                            (when all-keys
+                              (setq keysp t)
+                              `(&key ,@all-keys)))
+                        ,@(if (and keysp gf.allowp)
+                              `(&allow-other-keys)))
+                     *))
+                  (info :function :where-from name) :defined-method
+                  (gf-info-needs-update gf) nil)))))
+    (values)))
 
 (defun compute-applicable-methods-function (generic-function arguments)
   (values (compute-applicable-methods-using-types
@@ -1624,6 +1668,15 @@
                                (early-method-lambda-list method)
                                (method-lambda-list method)))
     (declare (ignore nreq nopt keysp restp keywords))
+    (values keywords allow-other-keys-p)))
+
+(defmethod function-keyword-parameters ((method standard-method))
+  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p
+                        keywords keyword-parameters)
+      (analyze-lambda-list (if (consp method)
+                               (early-method-lambda-list method)
+                               (method-lambda-list method)))
+    (declare (ignore nreq nopt keysp restp keywords))
     (values keyword-parameters allow-other-keys-p)))
 
 (defun method-ll->generic-function-ll (ll)
@@ -1658,7 +1711,7 @@
           (let ((methods.keys nil) (methods.allowp nil))
             (dolist (m methods)
               (multiple-value-bind (m.keyparams m.allow-other-keys)
-                  (function-keywords m)
+                  (function-keyword-parameters m)
                 (setq methods.keys (union methods.keys m.keyparams :key #'maybe-car))
                 (setq methods.allowp (or methods.allowp m.allow-other-keys))))
             (let ((arglist '()))