;;; METHOD-FUNCTION ??
(defmethod method-function ((method standard-method))
- (or (slot-value method 'function)
+ (or (slot-value method '%function)
(let ((fmf (slot-value method 'fast-function)))
(unless fmf ; The :BEFORE SHARED-INITIALIZE method prevents this.
(error "~S doesn't seem to have a METHOD-FUNCTION." method))
- (setf (slot-value method 'function)
+ (setf (slot-value method '%function)
(method-function-from-fast-function fmf)))))
(defmethod accessor-method-class ((method standard-accessor-method))
;;;
;;; 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))
(setf (plist-value method 'qualifiers) qualifiers)
#+ignore
(setf (slot-value method 'closure-generator)
- (method-function-closure-generator (slot-value method 'function))))
+ (method-function-closure-generator (slot-value method '%function))))
(defmethod shared-initialize :after ((method standard-accessor-method)
slot-names
&key)
(declare (ignore slot-names))
- (with-slots (slot-name slot-definition)
- method
- (unless slot-definition
+ (with-slots (slot-name %slot-definition) method
+ (unless %slot-definition
(let ((class (accessor-method-class method)))
(when (slot-class-p class)
- (setq slot-definition (find slot-name (class-direct-slots class)
+ (setq %slot-definition (find slot-name (class-direct-slots class)
:key #'slot-definition-name)))))
- (when (and slot-definition (null slot-name))
- (setq slot-name (slot-definition-name slot-definition)))))
+ (when (and %slot-definition (null slot-name))
+ (setq slot-name (slot-definition-name %slot-definition)))))
(defmethod method-qualifiers ((method standard-method))
(plist-value method 'qualifiers))
(initarg-error :method-combination
method-combination
"a method combination object")))
- ((slot-boundp generic-function 'method-combination))
+ ((slot-boundp generic-function '%method-combination))
(t
(initarg-error :method-combination
"not supplied"
; :argument-precedence-order
; 'argument-precedence-order)
; (add-initarg declarations :declarations 'declarations)
-; (add-initarg documentation :documentation 'documentation)
+; (add-initarg documentation :documentation '%documentation)
; (add-initarg method-class :method-class 'method-class)
-; (add-initarg method-combination :method-combination 'method-combination)
+; (add-initarg method-combination :method-combination '%method-combination)
(apply #'call-next-method generic-function initargs)))
||#
\f
: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*))
in method ~S:~2I~_~S.~@:>"
method qualifiers)))
((short-method-combination-p mc)
- (let ((mc-name (method-combination-type mc)))
+ (let ((mc-name (method-combination-type-name mc)))
(when (or (null qualifiers)
(cdr qualifiers)
(and (neq (car qualifiers) :around)
: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)
- (when (eq generic-function (method-generic-function method))
+ (when (eq generic-function (method-generic-function method))
(let* ((name (generic-function-name generic-function))
(specializers (method-specializers method))
(methods (generic-function-methods generic-function))
(update-ctors 'remove-method
:generic-function generic-function
:method method)
- (update-dfun 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)
(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-structure-svuc-method type method)))))))
(defun mec-all-classes-internal (spec precompute-p)
- (cons (specializer-class spec)
- (and (classp spec)
- precompute-p
- (not (or (eq spec *the-class-t*)
- (eq spec *the-class-slot-object*)
- (eq spec *the-class-standard-object*)
- (eq spec *the-class-structure-object*)))
- (let ((sc (class-direct-subclasses spec)))
- (when sc
- (mapcan (lambda (class)
- (mec-all-classes-internal class precompute-p))
- sc))))))
+ (unless (invalid-wrapper-p (class-wrapper (specializer-class spec)))
+ (cons (specializer-class spec)
+ (and (classp spec)
+ precompute-p
+ (not (or (eq spec *the-class-t*)
+ (eq spec *the-class-slot-object*)
+ (eq spec *the-class-standard-object*)
+ (eq spec *the-class-structure-object*)))
+ (let ((sc (class-direct-subclasses spec)))
+ (when sc
+ (mapcan (lambda (class)
+ (mec-all-classes-internal class precompute-p))
+ sc)))))))
(defun mec-all-classes (spec precompute-p)
(let ((classes (mec-all-classes-internal spec precompute-p)))
(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)
projects / sbcl.git / blobdiff