+(declaim (ftype (sfunction (t symbol) t) slot-value))
+(defun slot-value (object slot-name)
+ (let* ((wrapper (valid-wrapper-of object))
+ (cell (or (find-slot-cell wrapper slot-name)
+ (return-from slot-value
+ (values (slot-missing (wrapper-class* wrapper) object slot-name
+ 'slot-value)))))
+ (location (car cell))
+ (value
+ (cond ((fixnump location)
+ (if (std-instance-p object)
+ (standard-instance-access object location)
+ (funcallable-standard-instance-access object location)))
+ ((consp location)
+ (cdr location))
+ ((not location)
+ (return-from slot-value
+ (funcall (slot-info-reader (cdr cell)) object)))
+ (t
+ (bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
+ (if (eq +slot-unbound+ value)
+ (slot-unbound (wrapper-class* wrapper) object slot-name)
+ value)))
+
+;;; This is used during the PCL build, but gets replaced by a deftransform
+;;; in fixup.lisp.
+(define-compiler-macro slot-value (&whole form object slot-name
+ &environment env)
+ (if (and (constantp slot-name env)
+ (interned-symbol-p (constant-form-value slot-name env)))
+ `(accessor-slot-value ,object ,slot-name)
+ form))
+
+(defun set-slot-value (object slot-name new-value)
+ (let* ((wrapper (valid-wrapper-of object))
+ (cell (or (find-slot-cell wrapper slot-name)
+ (return-from set-slot-value
+ (values (slot-missing (wrapper-class* wrapper) object slot-name
+ 'setf new-value)))))
+ (location (car cell))
+ (info (cdr cell))
+ (typecheck (slot-info-typecheck info)))
+ (when typecheck
+ (funcall typecheck new-value))
+ (cond ((fixnump location)
+ (if (std-instance-p object)
+ (setf (standard-instance-access object location) new-value)
+ (setf (funcallable-standard-instance-access object location)
+ new-value)))
+ ((consp location)
+ (setf (cdr location) new-value))
+ ((not location)
+ (funcall (slot-info-writer info) new-value object))
+ (t
+ (bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell))))
+ new-value)
+
+;;; A version of SET-SLOT-VALUE for use in safe code, where we want to
+;;; check types when writing to slots:
+;;; * Doesn't have an optimizing compiler-macro
+;;; * Isn't special-cased in WALK-METHOD-LAMBDA
+(defun safe-set-slot-value (object slot-name new-value)
+ (set-slot-value object slot-name new-value))
+
+;;; This is used during the PCL build, but gets replaced by a deftransform
+;;; in fixup.lisp.
+(define-compiler-macro set-slot-value (&whole form object slot-name new-value
+ &environment env)
+ (if (and (constantp slot-name env)
+ (interned-symbol-p (constant-form-value slot-name env))
+ ;; We can't use the ACCESSOR-SET-SLOT-VALUE path in safe
+ ;; code, since it'll use the global automatically generated
+ ;; accessor, which won't do typechecking. (SLOT-OBJECT
+ ;; won't have been compiled with SAFETY 3, so SAFE-P will
+ ;; be NIL in MAKE-STD-WRITER-METHOD-FUNCTION).
+ (not (safe-code-p env)))
+ `(accessor-set-slot-value ,object ,slot-name ,new-value)
+ form))
+
+(defun (cas slot-value) (old-value new-value object slot-name)
+ (let* ((wrapper (valid-wrapper-of object))
+ (cell (or (find-slot-cell wrapper slot-name)
+ (return-from slot-value
+ (values (slot-missing (wrapper-class* wrapper) object slot-name
+ 'cas (list old-value new-value))))))
+ (location (car cell))
+ (info (cdr cell))
+ (typecheck (slot-info-typecheck info)))
+ (when typecheck
+ (funcall typecheck new-value))
+ (let ((old (cond ((fixnump location)
+ (if (std-instance-p object)
+ (cas (standard-instance-access object location) old-value new-value)
+ (cas (funcallable-standard-instance-access object location)
+ old-value new-value)))
+ ((consp location)
+ (cas (cdr location) old-value new-value))
+ ((not location)
+ ;; FIXME: (CAS SLOT-VALUE-USING-CLASS)...
+ (error "Cannot compare-and-swap slot ~S on: ~S" slot-name object))
+ (t
+ (bug "Bogus slot-cell in (CAS SLOT-VALUE): ~S" cell)))))
+ (if (and (eq +slot-unbound+ old)
+ (neq old old-value))
+ (slot-unbound (wrapper-class* wrapper) object slot-name)
+ old))))
+
+(defun slot-boundp (object slot-name)
+ (let* ((wrapper (valid-wrapper-of object))
+ (cell (or (find-slot-cell wrapper slot-name)
+ (return-from slot-boundp
+ (and (slot-missing (wrapper-class* wrapper) object slot-name
+ 'slot-boundp)
+ t))))
+ (location (car cell))
+ (value
+ (cond ((fixnump location)
+ (if (std-instance-p object)
+ (standard-instance-access object location)
+ (funcallable-standard-instance-access object location)))
+ ((consp location)
+ (cdr location))
+ ((not location)
+ (return-from slot-boundp
+ (funcall (slot-info-boundp (cdr cell)) object)))
+ (t
+ (bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
+ (not (eq +slot-unbound+ value))))
+
+(define-compiler-macro slot-boundp (&whole form object slot-name
+ &environment env)
+ (if (and (constantp slot-name env)
+ (interned-symbol-p (constant-form-value slot-name env)))
+ `(accessor-slot-boundp ,object ,slot-name)
+ form))