- (if (skip-fast-slot-access-p class slot-name 'reader)
- `(accessor-slot-value ,parameter ,slot-name)
- `(instance-read-internal .pv. ,(slot-vector-symbol position)
- ,pv-offset (accessor-slot-value ,parameter ,slot-name)
- ,(if (generate-fast-class-slot-access-p class slot-name)
- :class :instance))))
-
-(defmacro instance-write-internal (pv slots pv-offset new-value default
- &optional kind)
- (unless (member kind '(nil :instance :class :default))
- (error "illegal kind argument to ~S: ~S" 'instance-write-internal kind))
- (if (eq kind :default)
- default
- (let* ((index (gensym)))
- `(locally (declare #.*optimize-speed*)
- (let ((,index (svref ,pv ,pv-offset)))
- (typecase ,index
- ,@(when (or (null kind) (eq kind :instance))
- `((fixnum (and ,slots
- (setf (clos-slots-ref ,slots ,index)
- ,new-value)))))
- ,@(when (or (null kind) (eq kind :class))
- `((cons (setf (cdr ,index) ,new-value))))
- (t ,default)))))))
-
-(defmacro instance-write (pv-offset
- parameter
- position
- slot-name
- class
- new-value)
- (if (skip-fast-slot-access-p class slot-name 'writer)
- `(accessor-set-slot-value ,parameter ,slot-name ,new-value)
- `(instance-write-internal .pv. ,(slot-vector-symbol position)
- ,pv-offset ,new-value
- (accessor-set-slot-value ,parameter ,slot-name ,new-value)
- ,(if (generate-fast-class-slot-access-p class slot-name)
- :class :instance))))
-
-(defmacro instance-boundp-internal (pv slots pv-offset default
- &optional kind)
- (unless (member kind '(nil :instance :class :default))
- (error "illegal kind argument to ~S: ~S" 'instance-boundp-internal kind))
- (if (eq kind :default)
- default
- (let* ((index (gensym)))
- `(locally (declare #.*optimize-speed*)
- (let ((,index (svref ,pv ,pv-offset)))
- (typecase ,index
- ,@(when (or (null kind) (eq kind :instance))
- `((fixnum (not (and ,slots
- (eq (clos-slots-ref ,slots ,index)
- +slot-unbound+))))))
- ,@(when (or (null kind) (eq kind :class))
- `((cons (not (eq (cdr ,index) +slot-unbound+)))))
- (t ,default)))))))
+ (ecase (slot-access-strategy (constant-value-or-nil class)
+ (constant-value-or-nil slot-name)
+ 'reader)
+ (:standard
+ `(instance-read-standard
+ .pv. ,(slot-vector-symbol position)
+ ,pv-offset (accessor-slot-value ,parameter ,slot-name)
+ ,(if (generate-fast-class-slot-access-p class slot-name)
+ :class :instance)))
+ (:custom
+ `(instance-read-custom .pv. ,pv-offset ,parameter))
+ (:accessor
+ `(accessor-slot-value ,parameter ,slot-name))))
+
+(defmacro instance-read-standard (pv slots pv-offset default &optional kind)
+ (unless (member kind '(nil :instance :class))
+ (error "illegal kind argument to ~S: ~S" 'instance-read-standard kind))
+ (let* ((index (gensym))
+ (value index))
+ `(locally (declare #.*optimize-speed*)
+ (let ((,index (svref ,pv ,pv-offset))
+ (,slots (truly-the simple-vector ,slots)))
+ (setq ,value (typecase ,index
+ ;; FIXME: the line marked by KLUDGE below (and
+ ;; the analogous spot in
+ ;; INSTANCE-WRITE-STANDARD) is there purely to
+ ;; suppress a type mismatch warning that
+ ;; propagates through to user code.
+ ;; Presumably SLOTS at this point can never
+ ;; actually be NIL, but the compiler seems to
+ ;; think it could, so we put this here to shut
+ ;; it up. (see also mail Rudi Schlatte
+ ;; sbcl-devel 2003-09-21) -- CSR, 2003-11-30
+ ,@(when (or (null kind) (eq kind :instance))
+ `((fixnum
+ (clos-slots-ref ,slots ,index))))
+ ,@(when (or (null kind) (eq kind :class))
+ `((cons (cdr ,index))))
+ (t
+ +slot-unbound+)))
+ (if (eq ,value +slot-unbound+)
+ ,default
+ ,value)))))
+
+(defmacro instance-read-custom (pv pv-offset parameter)
+ `(locally (declare #.*optimize-speed*)
+ (funcall (slot-info-reader (svref ,pv (1+ ,pv-offset))) ,parameter)))
+
+;;;; (SETF SLOT-VALUE)
+
+(defmacro instance-write (pv-offset parameter position slot-name class new-value
+ &optional check-type-p)
+ (ecase (slot-access-strategy (constant-value-or-nil class)
+ (constant-value-or-nil slot-name)
+ 'writer)
+ (:standard
+ `(instance-write-standard
+ .pv. ,(slot-vector-symbol position)
+ ,pv-offset ,new-value
+ ;; KLUDGE: .GOOD-NEW-VALUE. is type-checked by the time this form
+ ;; is executed (if it is executed).
+ (accessor-set-slot-value ,parameter ,slot-name .good-new-value.)
+ ,(if (generate-fast-class-slot-access-p class slot-name)
+ :class :instance)
+ ,check-type-p))
+ (:custom
+ `(instance-write-custom .pv. ,pv-offset ,parameter ,new-value))
+ (:accessor
+ (if check-type-p
+ ;; FIXME: We don't want this here. If it's _possible_ the fast path
+ ;; is applicable, we want to use it as well.
+ `(safe-set-slot-value ,parameter ,slot-name ,new-value)
+ `(accessor-set-slot-value ,parameter ,slot-name ,new-value)))))
+
+(defmacro instance-write-standard (pv slots pv-offset new-value default
+ &optional kind safep)
+ (unless (member kind '(nil :instance :class))
+ (error "illegal kind argument to ~S: ~S" 'instance-write-standard kind))
+ (let* ((index (gensym))
+ (new-value-form
+ (if safep
+ `(let ((.typecheckfun. (slot-info-typecheck (svref ,pv (1+ ,pv-offset)))))
+ (declare (type (or function null) .typecheckfun.))
+ (if .typecheckfun.
+ (funcall .typecheckfun. ,new-value)
+ ,new-value))
+ new-value)))
+ `(locally (declare #.*optimize-speed*)
+ (let ((.good-new-value. ,new-value-form)
+ (,index (svref ,pv ,pv-offset)))
+ (typecase ,index
+ ,@(when (or (null kind) (eq kind :instance))
+ `((fixnum (and ,slots
+ (setf (clos-slots-ref ,slots ,index)
+ .good-new-value.)))))
+ ,@(when (or (null kind) (eq kind :class))
+ `((cons (setf (cdr ,index) .good-new-value.))))
+ (t ,default))))))
+
+(defmacro instance-write-custom (pv pv-offset parameter new-value)
+ `(locally (declare #.*optimize-speed*)
+ (funcall (slot-info-writer (svref ,pv (1+ ,pv-offset))) ,new-value ,parameter)))
+
+;;;; SLOT-BOUNDP