X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=9f43c637f2006003c324ede662a01012c4ce973d;hb=96a67b487909638cc0cb91114b6babf94b4bc1a7;hp=4122b7b36e450fbe14cbd86376b882361658a943;hpb=ef793f0d484ac3a527e945a62c93f904d73049a6;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 4122b7b..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,30 +53,31 @@ ;;; ;;; Methods are not reinitializable. -(define-condition metaobject-initialization-violation +(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-control ,(format nil "~@<~A~@:>" control) :format-arguments (list ',name) - :references (list '(:amop :initialization "Method")))))) + :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.") - ;; FIXME: NEW being a subclass of METHOD. - (def update-instance-for-redefined-class ((method method) added discarded + ;; 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)) t @@ -181,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)) @@ -247,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" @@ -275,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))) ||# @@ -552,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) @@ -573,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)) @@ -590,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 @@ -723,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) @@ -951,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))) @@ -1559,13 +1560,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)