(let ((inherited (accessor-inherited-data name defstruct)))
(cond
((not inherited)
- (stuff `(declaim (inline ,name (setf ,name))))
+ (stuff `(declaim (inline ,name ,@(unless (dsd-read-only slot)
+ `((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
;;; Return a LAMBDA form which can be used to set a slot.
(defun slot-setter-lambda-form (dd dsd)
- `(lambda (new-value instance)
- ,(funcall (nth-value 1 (slot-accessor-transforms dd dsd))
- '(dummy new-value instance))))
+ ;; KLUDGE: Evaluating the results of SLOT-ACCESSOR-TRANSFORMS needs
+ ;; a lexenv.
+ (let ((sb!c:*lexenv* (if (boundp 'sb!c:*lexenv*)
+ sb!c:*lexenv*
+ (sb!c::make-null-lexenv))))
+ `(lambda (new-value instance)
+ ,(funcall (nth-value 1 (slot-accessor-transforms dd dsd))
+ '(dummy new-value instance)))))
;;; core compile-time setup of any class with a LAYOUT, used even by
;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities
(when (and (classoid-subclasses classoid)
(not (eq layout old-layout)))
(collect ((subs))
- (dohash (classoid layout (classoid-subclasses classoid))
- (declare (ignore layout))
- (undefine-structure classoid)
- (subs (classoid-proper-name classoid)))
- (when (subs)
- (warn "removing old subclasses of ~S:~% ~S"
- (classoid-name classoid)
- (subs))))))
+ (dohash ((classoid layout) (classoid-subclasses classoid)
+ :locked t)
+ (declare (ignore layout))
+ (undefine-structure classoid)
+ (subs (classoid-proper-name classoid)))
+ (when (subs)
+ (warn "removing old subclasses of ~S:~% ~S"
+ (classoid-name classoid)
+ (subs))))))
(t
(unless (eq (classoid-layout classoid) layout)
(register-layout layout :invalidate nil))
(let* ((accessor-name (dsd-accessor-name dsd))
(dsd-type (dsd-type dsd)))
(when accessor-name
+ (setf (info :function :structure-accessor accessor-name) dd)
(let ((inherited (accessor-inherited-data accessor-name dd)))
(cond
((not inherited)
(when errorp
(error "No DEFSTRUCT-DESCRIPTION for ~S." name)))))
-(defun structure-slot-index (type slot-name &optional (errorp t))
- (let ((slotd (find slot-name
- (dd-slots (find-defstruct-description type))
- :key #'dsd-name)))
- (if slotd
- (dsd-index slotd)
- (when errorp
- (error "No slot named ~S in ~S." slot-name type)))))
-
-;;; Used internally, but it would be nice to provide something
-;;; like this for users as well.
-#!+sb-thread
-(defmacro define-structure-slot-compare-and-exchange
- (name &key structure slot)
- (let* ((dd (find-defstruct-description structure t))
- (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
- (type (when slotd (dsd-type slotd)))
- (index (when slotd (dsd-index slotd))))
- (unless index
- (error "Slot ~S not found in ~S." slot structure))
- `(progn
- (declaim (inline ,name))
- (defun ,name (instance old new)
- (declare (type ,structure instance)
- (type ,type new))
- (sb!vm::%instance-set-conditional instance ,index old new)))))
-
-;;; Ditto
-#!+sb-thread
-(defmacro define-structure-slot-addressor (name &key structure slot)
- (let* ((dd (find-defstruct-description structure t))
- (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
- (index (when slotd (dsd-index slotd))))
- (unless index
- (error "Slot ~S not found in ~S." slot structure))
- `(progn
- (declaim (inline ,name))
- (defun ,name (instance)
- (declare (type ,structure instance) (optimize speed))
- (sb!ext:truly-the
- sb!vm:word
- (+ (sb!kernel:get-lisp-obj-address instance)
- (- (* ,(+ sb!vm:instance-slots-offset index) sb!vm:n-word-bytes)
- sb!vm:instance-pointer-lowtag)))))))
-
(/show0 "code/defstruct.lisp end of file")