0.9.9.25:

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

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index f721a4b..879f26e 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,9 +475,7 @@
                        :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)))
+      (when (arg-info-valid-p (gf-arg-info gf))
         (update-dfun gf))
       (map-dependents gf (lambda (dependent)
                            (apply #'update-dependent gf dependent args))))))
@@ -707,8 +724,8 @@
 (defun value-for-caching (gf classes)
   (let ((methods (compute-applicable-methods-using-types
                    gf (mapcar #'class-eq-type classes))))
-    (method-function-get (or (method-fast-function (car methods))
-                             (method-function (car methods)))
+    (method-function-get (or (safe-method-fast-function (car methods))
+                             (safe-method-function (car methods)))
                          :constant-value)))
 
 (defun default-secondary-dispatch-function (generic-function)
@@ -1543,13 +1560,15 @@
              (set-dfun gf dfun cache info) ; lest the cache be freed twice
              (update-dfun gf dfun cache info))))))
 \f
-(defun (setf class-name) (new-value class)
+(defmethod (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))
+  (reinitialize-instance class :name new-value)
+  new-value)
 
-(defun (setf generic-function-name) (new-value generic-function)
-  (reinitialize-instance generic-function :name new-value))
+(defmethod (setf generic-function-name) (new-value generic-function)
+  (reinitialize-instance generic-function :name new-value)
+  new-value)
 \f
 (defmethod function-keywords ((method standard-method))
   (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)