0.8.4.23:

[sbcl.git] / src / pcl / methods.lisp

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 437e146..db593a5 100644 (file)
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -409,8 +409,7 @@
 (defmethod initialize-instance :after ((gf standard-generic-function)
                                       &key (lambda-list nil lambda-list-p)
                                       argument-precedence-order)
-  (with-slots (arg-info)
-    gf
+  (with-slots (arg-info) gf
     (if lambda-list-p
        (set-arg-info gf
                      :lambda-list lambda-list
@@ -419,25 +418,25 @@
     (when (arg-info-valid-p arg-info)
       (update-dfun gf))))
 
-(defmethod reinitialize-instance :after ((gf standard-generic-function)
-                                        &rest args
-                                        &key (lambda-list nil lambda-list-p)
-                                        (argument-precedence-order
-                                         nil argument-precedence-order-p))
-  (with-slots (arg-info)
-    gf
-    (if lambda-list-p
-       (if argument-precedence-order-p
-           (set-arg-info gf
-                         :lambda-list lambda-list
-                         :argument-precedence-order argument-precedence-order)
-           (set-arg-info gf
-                         :lambda-list lambda-list))
-       (set-arg-info gf))
-    (when (and (arg-info-valid-p arg-info)
-              args
-              (or lambda-list-p (cddr args)))
-      (update-dfun gf))))
+(defmethod reinitialize-instance :around
+    ((gf standard-generic-function) &rest args &key
+     (lambda-list nil lambda-list-p) (argument-precedence-order nil apo-p))
+  (let ((old-mc (generic-function-method-combination gf)))
+    (prog1 (call-next-method)
+      ;; KLUDGE: EQ is too strong a test.
+      (unless (eq old-mc (generic-function-method-combination gf))
+       (flush-effective-method-cache gf))
+      (cond
+       ((and lambda-list-p apo-p)
+        (set-arg-info gf
+                      :lambda-list lambda-list
+                      :argument-precedence-order argument-precedence-order))
+       (lambda-list-p (set-arg-info gf :lambda-list lambda-list))
+       (t (set-arg-info gf)))
+      (when (and (arg-info-valid-p (gf-arg-info gf))
+                (not (null args))
+                (or lambda-list-p (cddr args)))
+       (update-dfun gf)))))
 
 (declaim (special *lazy-dfun-compute-p*))
 
@@ -494,6 +493,33 @@
                 (setq remove-again-p nil))
            (when remove-again-p
              (remove-method generic-function method))))
+
+       ;; KLUDGE II: ANSI saith that it is not an error to add a
+       ;; method with invalid qualifiers to a generic function of the
+       ;; wrong kind; it's only an error at generic function
+       ;; invocation time; I dunno what the rationale was, and it
+       ;; sucks.  Nevertheless, it's probably a programmer error, so
+       ;; let's warn anyway. -- CSR, 2003-08-20
+       (let ((mc (generic-function-method-combination generic-functioN)))
+         (cond
+           ((eq mc *standard-method-combination*)
+            (when (and qualifiers
+                       (or (cdr qualifiers)
+                           (not (memq (car qualifiers)
+                                      '(:around :before :after)))))
+              (warn "~@<Invalid qualifiers for standard method combination ~
+                      in method ~S:~2I~_~S.~@:>"
+                    method qualifiers)))
+           ((short-method-combination-p mc)
+            (let ((mc-name (method-combination-type mc)))
+              (when (or (null qualifiers)
+                        (cdr qualifiers)
+                        (and (neq (car qualifiers) :around)
+                             (neq (car qualifiers) mc-name)))
+                (warn "~@<Invalid qualifiers for ~S method combination ~
+                        in method ~S:~2I~_~S.~@:>"
+                      mc-name method qualifiers))))))
+       
        (unless skip-dfun-update-p
          (update-ctors 'add-method
                        :generic-function generic-function
@@ -639,9 +665,10 @@
   (let ((types (mapcar #'class-eq-type classes)))
     (multiple-value-bind (methods all-applicable-and-sorted-p)
        (compute-applicable-methods-using-types gf types)
-      (function-funcall (get-secondary-dispatch-function1
-                        gf methods types nil t all-applicable-and-sorted-p)
-                       nil (mapcar #'class-wrapper classes)))))
+      (let ((generator (get-secondary-dispatch-function1
+                       gf methods types nil t all-applicable-and-sorted-p)))
+       (make-callable gf methods generator
+                      nil (mapcar #'class-wrapper classes))))))
 
 (defun value-for-caching (gf classes)
   (let ((methods (compute-applicable-methods-using-types
@@ -1485,6 +1512,10 @@
             (set-dfun gf dfun cache info) ; lest the cache be freed twice
             (update-dfun gf dfun cache info))))))
 \f
+(defmethod (setf class-name) :before (new-value (class class))
+  (let ((classoid (find-classoid (class-name class))))
+    (setf (classoid-name classoid) new-value)))
+\f
 (defmethod function-keywords ((method standard-method))
   (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
       (analyze-lambda-list (if (consp method)