- (set-fun-name
- (etypecase index
- (fixnum (if fsc-p
- (lambda (nv instance)
- (check-obsolete-instance instance)
- (setf (clos-slots-ref (fsc-instance-slots instance) index)
- nv))
- (lambda (nv instance)
- (check-obsolete-instance instance)
- (setf (clos-slots-ref (std-instance-slots instance) index)
- nv))))
- (cons (lambda (nv instance)
- (check-obsolete-instance instance)
- (setf (cdr index) nv))))
- `(writer ,slot-name)))
+ (let* ((safe-p (and slotd
+ (slot-definition-class slotd)
+ (safe-p (slot-definition-class slotd))))
+ (writer-fun (etypecase location
+ (fixnum (if fsc-p
+ (lambda (nv instance)
+ (check-obsolete-instance instance)
+ (setf (clos-slots-ref (fsc-instance-slots instance)
+ location)
+ nv))
+ (lambda (nv instance)
+ (check-obsolete-instance instance)
+ (setf (clos-slots-ref (std-instance-slots instance)
+ location)
+ nv))))
+ (cons (lambda (nv instance)
+ (check-obsolete-instance instance)
+ (setf (cdr location) nv)))
+ (null
+ (lambda (nv instance)
+ (declare (ignore nv instance))
+ (instance-structure-protocol-error
+ slotd
+ '(setf slot-value-using-class))))))
+ (checking-fun (lambda (new-value instance)
+ (check-obsolete-instance instance)
+ ;; If the SLOTD had a TYPE-CHECK-FUNCTION, call it.
+ (let* (;; Note that this CLASS is not neccessarily
+ ;; the SLOT-DEFINITION-CLASS of the
+ ;; SLOTD passed to M-O-S-W-M-F, since it's
+ ;; e.g. possible for a subclass to define
+ ;; a slot of the same name but with no
+ ;; accessors. So we need to fetch the SLOTD
+ ;; when CHECKING-FUN is called, instead of
+ ;; just closing over it.
+ (class (class-of instance))
+ (slotd (find-slot-definition class slot-name))
+ (type-check-function
+ (when slotd
+ (slot-definition-type-check-function slotd))))
+ (when type-check-function
+ (funcall type-check-function new-value)))
+ ;; Then call the real writer.
+ (funcall writer-fun new-value instance))))
+ (set-fun-name (if safe-p
+ checking-fun
+ writer-fun)
+ `(writer ,slot-name))))