(unless (eq (classoid-layout classoid) layout)
(register-layout layout)))
(t
+ (%redefine-defstruct classoid old-layout layout)
(let ((old-dd (layout-info old-layout)))
(when (defstruct-description-p old-dd)
(dolist (slot (dd-slots old-dd))
(fmakunbound (dsd-accessor-name slot))
(unless (dsd-read-only slot)
(fmakunbound `(setf ,(dsd-accessor-name slot)))))))
- (%redefine-defstruct classoid old-layout layout)
(setq layout (classoid-layout classoid))))
(setf (find-classoid (dd-name dd)) classoid)
(info :type :compiler-layout (dd-name dd))
(ensure-structure-class dd
inherits
- (if clayout-p "previously compiled" "current")
- "compiled"
+ (if clayout-p
+ "The most recently compiled"
+ "The current")
+ "the most recently loaded"
:compiler-layout clayout))
(cond (old-layout
- (undefine-structure (layout-classoid old-layout))
- (when (and (classoid-subclasses classoid)
- (not (eq layout old-layout)))
- (collect ((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))))))
+ (labels
+ ;; 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. FIXME: maybe rename
+ ;; UNDEFINE-FUN-NAME to UNDECLARE-FUNCTION-NAME?
+ ((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
+ (collect ((subs))
+ (dohash ((classoid layout)
+ (classoid-subclasses classoid)
+ :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)))))))
+ (undeclare-structure (layout-classoid old-layout)
+ (and (classoid-subclasses classoid)
+ (not (eq layout old-layout))))
+ (setf (layout-invalid layout) nil)
+ ;; FIXME: it might be polite to hold onto old-layout and
+ ;; restore it at the end of the file. -- RMK 2008-09-19
+ ;; (International Talk Like a Pirate Day).
+ (warn "~@<Clobbering the compiler's idea of the layout of ~A.~:@>"
+ classoid)))
(t
(unless (eq (classoid-layout classoid) layout)
(register-layout layout :invalidate nil))
(error "shouldn't happen! strange thing in LAYOUT-INFO:~% ~S"
old-layout)
(values class new-layout old-layout)))))))))
-
-;;; 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.
-(defun undefine-structure (class)
- (let ((info (layout-info (classoid-layout class))))
- (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)))
- (values))
\f
;;; Return a list of pairs (name . index). Used for :TYPE'd
;;; constructors to find all the names that we have to splice in &