;;;
;;; 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)))
- (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*))
: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)
(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
(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))
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)))
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))
(defun generate-discrimination-net (generic-function methods types sorted-p)
(let* ((arg-info (gf-arg-info generic-function))
- (c-a-m-emf-std-p (gf-info-c-a-m-emf-std-p arg-info))
+ (c-a-m-emf-std-p (gf-info-c-a-m-emf-std-p arg-info))
(precedence (arg-info-precedence arg-info)))
(generate-discrimination-net-internal
generic-function methods types
(lambda (methods known-types)
(if (or sorted-p
- (and c-a-m-emf-std-p
- (block one-order-p
- (let ((sorted-methods nil))
- (map-all-orders
- (copy-list methods) precedence
- (lambda (methods)
- (when sorted-methods (return-from one-order-p nil))
- (setq sorted-methods methods)))
- (setq methods sorted-methods))
- t)))
+ (and c-a-m-emf-std-p
+ (block one-order-p
+ (let ((sorted-methods nil))
+ (map-all-orders
+ (copy-list methods) precedence
+ (lambda (methods)
+ (when sorted-methods (return-from one-order-p nil))
+ (setq sorted-methods methods)))
+ (setq methods sorted-methods))
+ t)))
`(methods ,methods ,known-types)
`(unordered-methods ,methods ,known-types)))
(lambda (position type true-value false-value)
(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)
projects / sbcl.git / blobdiff