X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=9f43c637f2006003c324ede662a01012c4ce973d;hb=96a67b487909638cc0cb91114b6babf94b4bc1a7;hp=0ac414efab8153b5e3151f885822e6e4dce12941;hpb=b5791569082496e3bc4db6254c870c0bc994e19a;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 0ac414e..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,9 +474,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)))))) @@ -536,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) @@ -557,7 +573,7 @@ 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)) @@ -574,8 +590,8 @@ (map-dependents generic-function (lambda (dep) (update-dependent generic-function - dep 'remove-method method))) - generic-function))) + dep 'remove-method method))))) + generic-function) (defun compute-applicable-methods-function (generic-function arguments) (values (compute-applicable-methods-using-types @@ -707,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) @@ -935,18 +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-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))) @@ -1543,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)