X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fdefstruct.lisp;fp=src%2Fcode%2Fdefstruct.lisp;h=dc182089ba30042029b90674f6fe071485b9090b;hb=14c8e1a7d219eaccf6657b3fa3f24de9a24717cb;hp=aac8f2dc22761554f0d9b3b930c98983fc8f3677;hpb=7b2aeb8180bfe97fa0becc98297177e875e09551;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index aac8f2d..dc18208 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -912,13 +912,13 @@
            (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)
 
@@ -1000,23 +1000,59 @@
           (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))
@@ -1274,28 +1310,6 @@
              (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))
 
 ;;; Return a list of pairs (name . index). Used for :TYPE'd
 ;;; constructors to find all the names that we have to splice in &