(setf (slot-value method '%function)
(method-function-from-fast-function fmf)))))
-(defmethod accessor-method-class ((method standard-accessor-method))
- (car (slot-value method 'specializers)))
-
-(defmethod accessor-method-class ((method standard-writer-method))
- (cadr (slot-value method 'specializers)))
-
;;; initialization
;;;
;;; Error checking is done in before methods. Because of the simplicity of
;;; Methods are not reinitializable.
(define-condition metaobject-initialization-violation
- (reference-condition simple-condition)
+ (reference-condition simple-error)
())
(macrolet ((def (name args control)
(setf (slot-value method 'closure-generator)
(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
- (let ((class (accessor-method-class method)))
- (when (slot-class-p 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)))))
-
(defmethod method-qualifiers ((method standard-method))
(plist-value method 'qualifiers))
\f
(loop (when (null methods) (return gf))
(real-add-method gf (pop methods) methods)))
+(define-condition new-value-specialization (reference-condition error)
+ ((%method :initarg :method :reader new-value-specialization-method))
+ (:report
+ (lambda (c s)
+ (format s "~@<Cannot add method ~S to ~S, as it specializes the ~
+ new-value argument.~@:>"
+ (new-value-specialization-method c)
+ #'(setf slot-value-using-class))))
+ (:default-initargs :references
+ (list '(:sbcl :node "Metaobject Protocol")
+ '(:amop :generic-function (setf slot-value-using-class)))))
+
(defun real-add-method (generic-function method &optional skip-dfun-update-p)
(when (method-generic-function method)
(error "~@<The method ~S is already part of the generic ~
(when (and existing (similar-lambda-lists-p existing method))
(remove-method generic-function existing))
+ ;; KLUDGE: We have a special case here, as we disallow
+ ;; specializations of the NEW-VALUE argument to (SETF
+ ;; SLOT-VALUE-USING-CLASS). GET-ACCESSOR-METHOD-FUNCTION is
+ ;; the optimizing function here: it precomputes the effective
+ ;; method, assuming that there is no dispatch to be done on
+ ;; the new-value argument.
+ (when (and (eq generic-function #'(setf slot-value-using-class))
+ (not (eq *the-class-t* (first specializers))))
+ (error 'new-value-specialization
+ :method method))
+
(setf (method-generic-function method) generic-function)
(pushnew method (generic-function-methods generic-function))
(dolist (specializer specializers)
(setf (gf-info-simple-accessor-type arg-info)
(let* ((methods (generic-function-methods gf))
(class (and methods (class-of (car methods))))
- (type (and class
- (cond ((eq class
- *the-class-standard-reader-method*)
- 'reader)
- ((eq class
- *the-class-standard-writer-method*)
- 'writer)
- ((eq class
- *the-class-standard-boundp-method*)
- 'boundp)))))
+ (type
+ (and class
+ (cond ((or (eq class *the-class-standard-reader-method*)
+ (eq class *the-class-global-reader-method*))
+ 'reader)
+ ((or (eq class *the-class-standard-writer-method*)
+ (eq class *the-class-global-writer-method*))
+ 'writer)
+ ((or (eq class *the-class-standard-boundp-method*)
+ (eq class *the-class-global-boundp-method*))
+ 'boundp)))))
(when (and (gf-info-c-a-m-emf-std-p arg-info)
type
(dolist (method (cdr methods) t)
(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))))))
+ (let ((wrapper (class-wrapper (specializer-class spec))))
+ (unless (or (not wrapper) (invalid-wrapper-p wrapper))
+ (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)))
(default '(default)))
(flet ((add-class-list (classes)
(when (or (null new-class) (memq new-class classes))
- (let ((wrappers (get-wrappers-from-classes
- nkeys wrappers classes metatypes)))
- (when (and wrappers
- (eq default (probe-cache cache wrappers default)))
+ (let ((%wrappers (get-wrappers-from-classes
+ nkeys wrappers classes metatypes)))
+ (when (and %wrappers
+ (eq default (probe-cache cache %wrappers default)))
(let ((value (cond ((eq valuep t)
(sdfun-for-caching generic-function
classes))
((eq valuep :constant-value)
(value-for-caching generic-function
classes)))))
- (setq cache (fill-cache cache wrappers value))))))))
+ ;; need to get them again, as finalization might
+ ;; have happened in between, which would
+ ;; invalidate wrappers.
+ (let ((wrappers (get-wrappers-from-classes
+ nkeys wrappers classes metatypes)))
+ (when (if (atom wrappers)
+ (not (invalid-wrapper-p wrappers))
+ (every (complement #'invalid-wrapper-p)
+ wrappers))
+ (setq cache (fill-cache cache wrappers value))))))))))
(if classes-list
(mapc #'add-class-list classes-list)
(dolist (method (generic-function-methods generic-function))
(declare (ignore class))
(function-funcall (slot-definition-boundp-function slotd) object))
+(defun special-case-for-compute-discriminating-function-p (gf)
+ (or (eq gf #'slot-value-using-class)
+ (eq gf #'(setf slot-value-using-class))
+ (eq gf #'slot-boundp-using-class)))
+
(defmethod compute-discriminating-function ((gf standard-generic-function))
(with-slots (dfun-state arg-info) gf
+ (when (special-case-for-compute-discriminating-function-p gf)
+ ;; if we have a special case for
+ ;; COMPUTE-DISCRIMINATING-FUNCTION, then (at least for the
+ ;; special cases implemented as of 2006-05-09) any information
+ ;; in the cache is misplaced.
+ (aver (null dfun-state)))
(typecase dfun-state
- (null (let ((name (generic-function-name gf)))
- (when (eq name 'compute-applicable-methods)
- (update-all-c-a-m-gf-info gf))
- (cond ((eq name 'slot-value-using-class)
- (update-slot-value-gf-info gf 'reader)
- #'slot-value-using-class-dfun)
- ((equal name '(setf slot-value-using-class))
- (update-slot-value-gf-info gf 'writer)
- #'setf-slot-value-using-class-dfun)
- ((eq name 'slot-boundp-using-class)
- (update-slot-value-gf-info gf 'boundp)
- #'slot-boundp-using-class-dfun)
- ((gf-precompute-dfun-and-emf-p arg-info)
- (make-final-dfun gf))
- (t
- (make-initial-dfun gf)))))
+ (null
+ (when (eq gf #'compute-applicable-methods)
+ (update-all-c-a-m-gf-info gf))
+ (cond
+ ((eq gf #'slot-value-using-class)
+ (update-slot-value-gf-info gf 'reader)
+ #'slot-value-using-class-dfun)
+ ((eq gf #'(setf slot-value-using-class))
+ (update-slot-value-gf-info gf 'writer)
+ #'setf-slot-value-using-class-dfun)
+ ((eq gf #'slot-boundp-using-class)
+ (update-slot-value-gf-info gf 'boundp)
+ #'slot-boundp-using-class-dfun)
+ ((gf-precompute-dfun-and-emf-p arg-info)
+ (make-final-dfun gf))
+ (t
+ (make-initial-dfun gf))))
(function dfun-state)
(cons (car dfun-state)))))
(defmethod update-gf-dfun ((class std-class) gf)
(let ((*new-class* class)
- #|| (name (generic-function-name gf)) ||#
(arg-info (gf-arg-info gf)))
- (cond #||
- ((eq name 'slot-value-using-class)
- (update-slot-value-gf-info gf 'reader))
- ((equal name '(setf slot-value-using-class))
- (update-slot-value-gf-info gf 'writer))
- ((eq name 'slot-boundp-using-class)
- (update-slot-value-gf-info gf 'boundp))
- ||#
- ((gf-precompute-dfun-and-emf-p arg-info)
- (multiple-value-bind (dfun cache info)
- (make-final-dfun-internal gf)
- (set-dfun gf dfun cache info) ; lest the cache be freed twice
- (update-dfun gf dfun cache info))))))
+ (cond
+ ((special-case-for-compute-discriminating-function-p gf))
+ ((gf-precompute-dfun-and-emf-p arg-info)
+ (multiple-value-bind (dfun cache info)
+ (make-final-dfun-internal gf)
+ (set-dfun gf dfun cache info) ; lest the cache be freed twice
+ (update-dfun gf dfun cache info))))))
\f
(defmethod (setf class-name) (new-value class)
(let ((classoid (%wrapper-classoid (class-wrapper class))))
- (setf (classoid-name classoid) new-value))
+ (if (and new-value (symbolp new-value))
+ (setf (classoid-name classoid) new-value)
+ (setf (classoid-name classoid) nil)))
(reinitialize-instance class :name new-value)
new-value)