X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=3fb6cd242a830c8cfcac7e23706c7676e5c74622;hb=53dd919e3b97fe7a63b6826d812eef6bac0ca9ad;hp=ae16f9927809b8970bd9d9594d89ec5b85f7ccb4;hpb=2d10bc4b0d8557a5c553d13a3d520c40b48414db;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index ae16f99..3fb6cd2 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))) ||# @@ -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) @@ -705,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) @@ -1541,13 +1559,15 @@ (set-dfun gf dfun cache info) ; lest the cache be freed twice (update-dfun gf dfun cache info)))))) -(defun (setf class-name) (new-value class) +(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)) + (reinitialize-instance class :name new-value) + new-value) -(defun (setf generic-function-name) (new-value generic-function) - (reinitialize-instance generic-function :name 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)