0.9.6.33:

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

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 8db6b37..9b8487f 100644 (file)
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -53,11 +53,30 @@
 ;;;
 ;;; Methods are not reinitializable.
 
-(defmethod reinitialize-instance ((method standard-method) &rest initargs)
-  (declare (ignore initargs))
-  (error "An attempt was made to reinitialize the method ~S.~%~
-          Method objects cannot be reinitialized."
-         method))
+(define-condition metaobject-initialization-violation
+    (reference-condition simple-condition)
+  ())
+
+(macrolet ((def (name args control)
+               `(defmethod ,name ,args
+                 (declare (ignore initargs))
+                 (error 'metaobject-initialization-violation
+                  :format-control ,(format nil "~@<~A~@:>" control)
+                  :format-arguments (list ',name)
+                  :references (list '(:amop :initialization "Method"))))))
+  (def reinitialize-instance ((method method) &rest initargs)
+    "Method objects cannot be redefined by ~S.")
+  (def change-class ((method method) new &rest initargs)
+    "Method objects cannot be redefined by ~S.")
+  ;; NEW being a subclass of method is dealt with in the general
+  ;; method of CHANGE-CLASS
+  (def update-instance-for-redefined-class ((method method) added discarded
+                                            plist &rest initargs)
+    "No behaviour specified for ~S on method objects.")
+  (def update-instance-for-different-class (old (new method) &rest initargs)
+    "No behaviour specified for ~S on method objects.")
+  (def update-instance-for-different-class ((old method) new &rest initargs)
+    "No behaviour specified for ~S on method objects."))
 
 (defmethod legal-documentation-p ((object standard-method) x)
   (if (or (null x) (stringp x))
@@ -456,10 +475,10 @@
                        :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)))))
+      (when (arg-info-valid-p (gf-arg-info gf))
+        (update-dfun gf))
+      (map-dependents gf (lambda (dependent)
+                           (apply #'update-dependent gf dependent args))))))
 
 (declaim (special *lazy-dfun-compute-p*))
 
@@ -548,6 +567,10 @@
                         :generic-function generic-function
                         :method method)
           (update-dfun generic-function))
+        (map-dependents generic-function
+                        (lambda (dep)
+                          (update-dependent generic-function
+                                            dep 'add-method method)))
         generic-function)))
 
 (defun real-remove-method (generic-function method)
@@ -564,8 +587,12 @@
       (update-ctors 'remove-method
                     :generic-function generic-function
                     :method method)
-      (update-dfun generic-function)))
-  generic-function)
+      (update-dfun generic-function)
+      (map-dependents generic-function
+                      (lambda (dep)
+                        (update-dependent generic-function
+                                          dep 'remove-method method)))
+      generic-function)))
 \f
 (defun compute-applicable-methods-function (generic-function arguments)
   (values (compute-applicable-methods-using-types
@@ -909,7 +936,7 @@
                      (eq (pop specls) *the-class-t*))
                  (every #'classp specls))
         (cond ((and (eq (class-name (car specls)) 'std-class)
-                    (eq (class-name (cadr specls)) 'std-object)
+                    (eq (class-name (cadr specls)) 'standard-object)
                     (eq (class-name (caddr specls))
                         'standard-effective-slot-definition))
                (set-standard-svuc-method type method))
@@ -930,7 +957,6 @@
              precompute-p
              (not (or (eq spec *the-class-t*)
                       (eq spec *the-class-slot-object*)
-                      (eq spec *the-class-std-object*)
                       (eq spec *the-class-standard-object*)
                       (eq spec *the-class-structure-object*)))
              (let ((sc (class-direct-subclasses spec)))
@@ -994,19 +1020,16 @@
       cache)))
 
 (defmacro class-test (arg class)
-  (cond ((eq class *the-class-t*)
-         t)
-        ((eq class *the-class-slot-object*)
-         `(not (typep (classoid-of ,arg)
-                      'built-in-classoid)))
-        ((eq class *the-class-std-object*)
-         `(or (std-instance-p ,arg) (fsc-instance-p ,arg)))
-        ((eq class *the-class-standard-object*)
-         `(std-instance-p ,arg))
-        ((eq class *the-class-funcallable-standard-object*)
-         `(fsc-instance-p ,arg))
-        (t
-         `(typep ,arg ',(class-name class)))))
+  (cond
+    ((eq class *the-class-t*) t)
+    ((eq class *the-class-slot-object*)
+     `(not (typep (classoid-of ,arg) 'built-in-classoid)))
+    ((eq class *the-class-standard-object*)
+     `(or (std-instance-p ,arg) (fsc-instance-p ,arg)))
+    ((eq class *the-class-funcallable-standard-object*)
+     `(fsc-instance-p ,arg))
+    (t
+     `(typep ,arg ',(class-name class)))))
 
 (defmacro class-eq-test (arg class)
   `(eq (class-of ,arg) ',class))
@@ -1537,9 +1560,13 @@
              (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)))
+(defun (setf class-name) (new-value class)
+  (let ((classoid (%wrapper-classoid (class-wrapper class))))
+    (setf (classoid-name classoid) new-value))
+  (reinitialize-instance class :name new-value))
+
+(defun (setf generic-function-name) (new-value generic-function)
+  (reinitialize-instance generic-function :name new-value))
 \f
 (defmethod function-keywords ((method standard-method))
   (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)