- (let* ((class (when (eq *boot-state* 'complete)
- (if (typep class-or-name 'class)
- class-or-name
- (find-class class-or-name nil))))
- (safe-p (and class
- (safe-p class)))
- (check-fun (lambda (new-value instance)
- (let* ((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)))))
- (initargs (copy-tree
- (if safe-p
- (make-method-function
- (lambda (nv instance)
- (funcall check-fun nv instance)
- (pv-binding1 (.pv. .calls.
- (bug "Please report this")
- (instance) (instance-slots))
- (instance-write-internal
- .pv. instance-slots 0 nv
- (setf (slot-value instance slot-name) nv)))))
- (make-method-function
- (lambda (nv instance)
- (pv-binding1 (.pv. .calls.
- (bug "Please report this")
- (instance) (instance-slots))
- (instance-write-internal
- .pv. instance-slots 0 nv
- (setf (slot-value instance slot-name) nv)))))))))
- (setf (getf (getf initargs 'plist) :slot-name-lists)
- (list nil (list nil slot-name)))
- initargs))
+ (let ((class (maybe-class class-or-name)))
+ (ecase (slot-access-strategy class slot-name 'writer t)
+ (:standard
+ (let ((initargs (copy-tree
+ (if (and class (safe-p class))
+ (make-method-function
+ (lambda (nv instance)
+ (pv-binding1 ((bug "Please report this")
+ (instance) (instance-slots))
+ (instance-write-standard
+ .pv. instance-slots 0 nv
+ (setf (slot-value instance slot-name) .good-new-value.)
+ nil t))))
+ (make-method-function
+ (lambda (nv instance)
+ (pv-binding1 ((bug "Please report this")
+ (instance) (instance-slots))
+ (instance-write-standard
+ .pv. instance-slots 0 nv
+ (setf (slot-value instance slot-name) .good-new-value.)))))))))
+ (setf (getf (getf initargs 'plist) :slot-name-lists)
+ (list nil (list nil slot-name)))
+ initargs))
+ ((:custom :accessor)
+ (let ((initargs (copy-tree
+ (make-method-function
+ (lambda (nv instance)
+ (pv-binding1 ((bug "Please report this")
+ (instance) nil)
+ (instance-write-custom .pv. 0 instance nv)))))))
+ (setf (getf (getf initargs 'plist) :slot-name-lists)
+ (list nil (list nil slot-name)))
+ initargs)))))