- (let* ((class (class-of object))
- (slot-definition (find-slot-definition class slot-name)))
- (if (null slot-definition)
- (progn (slot-missing class object slot-name 'setf new-value)
- new-value)
- (setf (slot-value-using-class class object slot-definition)
- new-value))))
-
-(define-compiler-macro set-slot-value (&whole form object slot-name new-value)
- (if (and (constantp slot-name)
- (interned-symbol-p (eval slot-name)))
+ (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)))