;;;
;;; 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))
: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))))))
(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)
(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)))
+(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)
+ 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)