- `(,ref ,instance-name ,(dsd-index dsd))
- (let* ((raw-slot-data (find raw-type *raw-slot-data-list*
- :key #'raw-slot-data-raw-type
- :test #'equal))
- (raw-slot-accessor (raw-slot-data-accessor-name raw-slot-data))
- (raw-n-words (raw-slot-data-n-words raw-slot-data)))
- (multiple-value-bind (scaled-dsd-index misalignment)
- (floor (dsd-index dsd) raw-n-words)
- (aver (zerop misalignment))
- `(,raw-slot-accessor (,ref ,instance-name ,(dd-raw-index dd))
- ,scaled-dsd-index))))))
-
-;;; Return inline expansion designators (i.e. values suitable for
-;;; (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR ..)) for the reader
-;;; and writer functions of the slot described by DSD.
-(defun slot-accessor-inline-expansion-designators (dd dsd)
- (let ((instance-type-decl `(declare (type ,(dd-name dd) instance)))
- (accessor-place-form (%accessor-place-form dd dsd 'instance))
- (dsd-type (dsd-type dsd)))
- (values (lambda ()
- `(lambda (instance)
- ,instance-type-decl
- (truly-the ,dsd-type ,accessor-place-form)))
- (lambda ()
- `(lambda (new-value instance)
- (declare (type ,dsd-type new-value))
- ,instance-type-decl
- (setf ,accessor-place-form new-value))))))
+ `(,ref ,instance-name ,(dsd-index dsd))
+ (let* ((raw-slot-data (find raw-type *raw-slot-data-list*
+ :key #'raw-slot-data-raw-type
+ :test #'equal))
+ (raw-slot-accessor (raw-slot-data-accessor-name raw-slot-data)))
+ `(,raw-slot-accessor ,instance-name ,(dsd-index dsd))))))
+
+;;; Return source transforms for the reader and writer functions of
+;;; the slot described by DSD. They should be inline expanded, but
+;;; source transforms work faster.
+(defun slot-accessor-transforms (dd dsd)
+ (let ((accessor-place-form (%accessor-place-form dd dsd
+ `(the ,(dd-name dd) instance)))
+ (dsd-type (dsd-type dsd))
+ (value-the (if (dsd-safe-p dsd) 'truly-the 'the)))
+ (values (sb!c:source-transform-lambda (instance)
+ `(,value-the ,dsd-type ,(subst instance 'instance
+ accessor-place-form)))
+ (sb!c:source-transform-lambda (new-value instance)
+ (destructuring-bind (accessor-name &rest accessor-args)
+ accessor-place-form
+ (once-only ((new-value new-value)
+ (instance instance))
+ `(,(info :setf :inverse accessor-name)
+ ,@(subst instance 'instance accessor-args)
+ (the ,dsd-type ,new-value))))))))
+
+;;; Return a LAMBDA form which can be used to set a slot.
+(defun slot-setter-lambda-form (dd dsd)
+ ;; 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)))))
+
+;;; Blow away all the compiler info for the structure CLASS. Iterate
+;;; over this type, clearing the compiler structure type info, and
+;;; undefining all the associated functions. If SUBCLASSES-P, also do
+;;; the same for subclasses. FIXME: maybe rename UNDEFINE-FUN-NAME to
+;;; UNDECLARE-FUNCTION-NAME?
+(defun undeclare-structure (classoid subclasses-p)
+ (let ((info (layout-info (classoid-layout classoid))))
+ (when (defstruct-description-p info)
+ (let ((type (dd-name info)))
+ (remhash type *typecheckfuns*)
+ (setf (info :type :compiler-layout type) nil)
+ (undefine-fun-name (dd-copier-name info))
+ (undefine-fun-name (dd-predicate-name info))
+ (dolist (slot (dd-slots info))
+ (let ((fun (dsd-accessor-name slot)))
+ (unless (accessor-inherited-data fun info)
+ (undefine-fun-name fun)
+ (unless (dsd-read-only slot)
+ (undefine-fun-name `(setf ,fun)))))))
+ ;; Clear out the SPECIFIER-TYPE cache so that subsequent
+ ;; references are unknown types.
+ (values-specifier-type-cache-clear)))
+ (when subclasses-p
+ (let ((subclasses (classoid-subclasses classoid)))
+ (when subclasses
+ (collect ((subs))
+ (dohash ((classoid layout)
+ subclasses
+ :locked t)
+ (declare (ignore layout))
+ (undeclare-structure classoid nil)
+ (subs (classoid-proper-name classoid)))
+ ;; Is it really necessary to warn about
+ ;; undeclaring functions for subclasses?
+ (when (subs)
+ (warn "undeclaring functions for old subclasses ~
+ of ~S:~% ~S"
+ (classoid-name classoid)
+ (subs))))))))