+(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))))
+