X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=9f43c637f2006003c324ede662a01012c4ce973d;hb=96a67b487909638cc0cb91114b6babf94b4bc1a7;hp=8db6b37c62831236b4eb0a6a27308c7321e13e55;hpb=92c8db80e039f60623e53a0b9355cf0a9ec49f3d;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 8db6b37..9f43c63 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -33,11 +33,11 @@ ;;; 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)) @@ -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)) @@ -163,21 +182,20 @@ (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)) @@ -229,7 +247,7 @@ (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" @@ -257,9 +275,9 @@ ; :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))) ||# @@ -456,10 +474,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*)) @@ -534,7 +552,7 @@ 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) @@ -548,10 +566,14 @@ :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)) @@ -564,7 +586,11 @@ (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) (defun compute-applicable-methods-function (generic-function arguments) @@ -697,8 +723,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) @@ -909,7 +935,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)) @@ -925,19 +951,19 @@ (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-std-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))) @@ -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,15 @@ (set-dfun gf dfun cache info) ; lest the cache be freed twice (update-dfun gf dfun cache info)))))) -(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) (defmethod function-keywords ((method standard-method)) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)