by symbols in the Common Lisp package: preventing two independent pieces
of software from colliding with each other.
+@item
+@findex slot-value-using-class
+@findex sb-mop:slot-value-using-class
+@findex (setf slot-value-using-class)
+@findex (setf sb-mop:slot-value-using-class)
+@findex slot-boundp-using-class
+@findex sb-mop:slot-boundp-using-class
+specializations of the @code{new-value} argument to @code{(setf
+sb-mop:slot-value-using-class)} are not allowed: all user-defined
+methods must have a specializer of the class @code{t}.
+
+This prohibition is motivated by a separation of layers: the
+@code{slot-value-using-class} family of functions is intended for use in
+implementing different and new slot allocation strategies, rather than
+in performing application-level dispatching. Additionally, with this
+requirement, there is a one-to-one mapping between metaclass, class and
+slot-definition-class tuples and effective methods of @code{(setf
+slot-value-using-class)}, which permits optimization of @code{(setf
+slot-value-using-class)}'s discriminating function in the same manner as
+for @code{slot-value-using-class} and @code{slot-boundp-using-class}.
+
+Note that application code may specialize on the @code{new-value}
+argument of slot accessors.
+
@end itemize
@node Support For Unix
;;; Methods are not reinitializable.
(define-condition metaobject-initialization-violation
- (reference-condition simple-condition)
+ (reference-condition simple-error)
())
(macrolet ((def (name args control)
(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)
(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))))
--- /dev/null
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; this file tests that it is not possible to add an
+;;; optimization-invalidating method to #'(SETF
+;;; SLOT-VALUE-USING-CLASS). If a way is found to preserve the
+;;; optimization, or if the optimization is deemed to be invalid, then
+;;; this test can go away.
+
+(defpackage "MOP-16"
+ (:use "CL" "SB-MOP"))
+
+(in-package "MOP-16")
+
+(defclass foo-class (standard-class) ())
+
+(defclass foo-effective-slot-definition (standard-effective-slot-definition)
+ ())
+
+(multiple-value-bind (value condition)
+ (ignore-errors
+ (defmethod (setf slot-value-using-class)
+ ((new-value integer) (class foo-class)
+ (object standard-object) (slotd foo-effective-slot-definition))
+ "Haha"))
+ (assert (null value))
+ (assert (typep condition 'error)))
projects / sbcl.git / commitdiff