- (let ((location (slot-definition-location slotd)))
- (typecase location
- (fixnum
- (cond ((std-instance-p object)
- (setf (clos-slots-ref (std-instance-slots object) location)
- new-value))
- ((fsc-instance-p object)
- (setf (clos-slots-ref (fsc-instance-slots object) location)
- new-value))
- (t (bug "unrecognized instance type in ~S"
- '(setf slot-value-using-class)))))
- (cons
- (setf (cdr location) new-value))
- (t
- (instance-structure-protocol-error slotd
- '(setf slot-value-using-class))))))
+ (let ((location (slot-definition-location slotd))
+ (type-check-function
+ (when (safe-p class)
+ (slot-definition-type-check-function slotd))))
+ (flet ((check (new-value)
+ (when type-check-function
+ (funcall (the function type-check-function) new-value))
+ new-value))
+ (typecase location
+ (fixnum
+ (cond ((std-instance-p object)
+ (setf (clos-slots-ref (std-instance-slots object) location)
+ (check new-value)))
+ ((fsc-instance-p object)
+ (setf (clos-slots-ref (fsc-instance-slots object) location)
+ (check new-value)))
+ (t (bug "unrecognized instance type in ~S"
+ '(setf slot-value-using-class)))))
+ (cons
+ (setf (cdr location) (check new-value)))
+ (t
+ (instance-structure-protocol-error
+ slotd '(setf slot-value-using-class)))))))