- (stuff `(proclaim '(inline ,name (setf ,name))))
- ;; FIXME: The arguments in the next two DEFUNs should be
- ;; gensyms. (Otherwise e.g. if NEW-VALUE happened to be the
- ;; name of a special variable, things could get weird.)
- (stuff `(defun ,name (structure)
- (declare (type ,ltype structure))
- (the ,slot-type (elt structure ,index))))
- (unless (dsd-read-only slot)
- (stuff
- `(defun (setf ,name) (new-value structure)
- (declare (type ,ltype structure) (type ,slot-type new-value))
- (setf (elt structure ,index) new-value)))))))
+ (let ((inherited (accessor-inherited-data name defstruct)))
+ (cond
+ ((not inherited)
+ (stuff `(proclaim '(inline ,name (setf ,name))))
+ ;; FIXME: The arguments in the next two DEFUNs should
+ ;; be gensyms. (Otherwise e.g. if NEW-VALUE happened to
+ ;; be the name of a special variable, things could get
+ ;; weird.)
+ (stuff `(defun ,name (structure)
+ (declare (type ,ltype structure))
+ (the ,slot-type (elt structure ,index))))
+ (unless (dsd-read-only slot)
+ (stuff
+ `(defun (setf ,name) (new-value structure)
+ (declare (type ,ltype structure) (type ,slot-type new-value))
+ (setf (elt structure ,index) new-value)))))
+ ((not (= (cdr inherited) index))
+ (style-warn "~@<Non-overwritten accessor ~S does not access ~
+ slot with name ~S (accessing an inherited slot ~
+ instead).~:@>" name (dsd-name slot))))))))