X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=8ad72f6631d62e9c812c12a3c44af89f0f59d54d;hb=37200d73dfca16507809778574092cfb998711d5;hp=b9515edf564de432d53eaa7d1767d8a64df5744e;hpb=e66288cd5588b336b79a7e19f1c884e4e3263d53;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index b9515ed..8ad72f6 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,66 @@
                         :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.restp gf.rest
+                                            gf.keyp gf.keys gf.allowp)
+              (parse-lambda-list gf-lambda-list)
+            (declare (ignore gf.rest))
+            ;; 7.6.4 point 5 probably entails that if any method says
+            ;; &allow-other-keys then the gf should be construed to
+            ;; accept any key.
+            (let ((allowp (or gf.allowp
+                              (find '&allow-other-keys methods
+                                    :test #'find
+                                    :key #'method-lambda-list))))
+              (setf (info :function :type name)
+                    (specifier-type
+                     `(function
+                       (,@(mapcar tfun gf.required)
+                          ,@(if gf.optional
+                                `(&optional ,@(mapcar tfun gf.optional)))
+                          ,@(if gf.restp
+                                `(&rest t))
+                          ,@(when gf.keyp
+                              (let ((all-keys
+                                     (mapcar
+                                      (lambda (x)
+                                        (list x t))
+                                      (remove-duplicates
+                                       (nconc
+                                        (mapcan #'function-keywords methods)
+                                        (mapcar #'keywordicate gf.keys))))))
+                                (when all-keys
+                                  (setq keysp t)
+                                  `(&key ,@all-keys))))
+                          ,@(when (and (not keysp) allowp)
+                              `(&key))
+                          ,@(when 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
@@ -1567,11 +1623,19 @@
               (cond ((/= nkeys 1)
                      ;; KLUDGE: someone has defined a method
                      ;; specialized on the second argument: punt.
+                     (setf po-cache nil)
                      (make-initial-dfun gf))
                     (po-cache
                      (multiple-value-bind (dfun cache info)
                          (make-caching-dfun gf po-cache)
                        (set-dfun gf dfun cache info)))
+                    ;; the relevant PRINT-OBJECT methods get defined
+                    ;; late, by delayed DEF!METHOD.  We mustn't cache
+                    ;; the effective method for our classes earlier
+                    ;; than the relevant PRINT-OBJECT methods are
+                    ;; defined...
+                    ((boundp 'sb-impl::*delayed-def!method-args*)
+                     (make-initial-dfun gf))
                     (t (multiple-value-bind (dfun cache info)
                            (make-final-dfun-internal
                             gf
@@ -1609,6 +1673,15 @@
   (reinitialize-instance generic-function :name new-value)
   new-value)
 
+(defmethod function-keywords ((method standard-method))
+  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p
+                        keywords)
+      (analyze-lambda-list (if (consp method)
+                               (early-method-lambda-list method)
+                               (method-lambda-list method)))
+    (declare (ignore nreq nopt keysp restp))
+    (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)