0.7.9.35:

[sbcl.git] / src / code / defstruct.lisp

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index a894f47..2adbc99 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -27,10 +27,36 @@
          (t res))))
 
 ;;; Delay looking for compiler-layout until the constructor is being
-;;; compiled, since it doesn't exist until after the EVAL-WHEN (COMPILE)
-;;; stuff is compiled.
+;;; compiled, since it doesn't exist until after the EVAL-WHEN
+;;; (COMPILE) stuff is compiled. (Or, in the oddball case when
+;;; DEFSTRUCT is executing in a non-toplevel context, the
+;;; compiler-layout still doesn't exist at compilation time, and we
+;;; delay still further.)
 (sb!xc:defmacro %delayed-get-compiler-layout (name)
-  `',(compiler-layout-or-lose name))
+  (let ((layout (info :type :compiler-layout name)))
+    (cond (layout
+          ;; ordinary case: When the DEFSTRUCT is at top level,
+          ;; then EVAL-WHEN (COMPILE) stuff will have set up the
+          ;; layout for us to use.
+          (unless (typep (layout-info layout) 'defstruct-description)
+            (error "Class is not a structure class: ~S" name))
+          `,layout)
+         (t
+          ;; KLUDGE: In the case that DEFSTRUCT is not at top-level
+          ;; the layout doesn't exist at compile time. In that case
+          ;; we laboriously look it up at run time. This code will
+          ;; run on every constructor call and will likely be quite
+          ;; slow, so if anyone cares about performance of
+          ;; non-toplevel DEFSTRUCTs, it should be rewritten to be
+          ;; cleverer. -- WHN 2002-10-23
+          (sb!c::compiler-note
+           "implementation limitation: ~
+             Non-toplevel DEFSTRUCT constructors are slow.")
+          (let ((layout (gensym "LAYOUT")))
+            `(let ((,layout (info :type :compiler-layout ',name)))
+               (unless (typep (layout-info ,layout) 'defstruct-description)
+                 (error "Class is not a structure class: ~S" ',name))
+               ,layout))))))
 
 ;;; Get layout right away.
 (sb!xc:defmacro compile-time-find-layout (name)
@@ -315,14 +341,23 @@
        (if (dd-class-p dd)
           (let ((inherits (inherits-for-structure dd)))
             `(progn
+               ;; Note we intentionally call %DEFSTRUCT first, and
+               ;; especially before %COMPILER-DEFSTRUCT. %DEFSTRUCT
+               ;; has the tests (and resulting CERROR) for collisions
+               ;; with LAYOUTs which already exist in the runtime. If
+               ;; there are any collisions, we want the user's
+               ;; response to CERROR to control what happens.
+               ;; Especially, if the user responds to the collision
+               ;; with ABORT, we don't want %COMPILER-DEFSTRUCT to
+               ;; modify the definition of the class.
+               (%defstruct ',dd ',inherits)
                (eval-when (:compile-toplevel :load-toplevel :execute)
                  (%compiler-defstruct ',dd ',inherits))
-               (%defstruct ',dd ',inherits)
                ,@(unless expanding-into-code-for-xc-host-p
                    (append ;; FIXME: We've inherited from CMU CL nonparallel
                            ;; code for creating copiers for typed and untyped
                            ;; structures. This should be fixed.
-                                       ;(copier-definition dd)
+                           ;(copier-definition dd)
                            (constructor-definitions dd)
                            (class-method-definitions dd)))
                ',name))
@@ -997,19 +1032,37 @@
   (declare (type sb!xc:class class) (type layout old-layout new-layout))
   (let ((name (class-proper-name class)))
     (restart-case
-       (error "redefining class ~S incompatibly with the current definition"
+       (error "~@<attempt to redefine the ~S class ~S incompatibly with the current definition~:@>"
+              'structure-object
               name)
       (continue ()
-       :report "Invalidate current definition."
-       (warn "Previously loaded ~S accessors will no longer work." name)
-       (register-layout new-layout))
+       :report (lambda (s)
+                (format s
+                        "~@<Use the new definition of ~S, invalidating ~
+                          already-loaded code and instances.~@:>"
+                        name))
+       (register-layout new-layout))
+      (recklessly-continue ()
+       :report (lambda (s)
+                (format s
+                        "~@<Use the new definition of ~S as if it were ~
+                          compatible, allowing old accessors to use new ~
+                          instances and allowing new accessors to use old ~
+                          instances.~@:>"
+                        name))
+       ;; classic CMU CL warning: "Any old ~S instances will be in a bad way. 
+       ;; I hope you know what you're doing..."
+       (register-layout new-layout
+                       :invalidate nil
+                       :destruct-layout old-layout))
       (clobber-it ()
-       :report "Smash current layout, preserving old code."
-       (warn "Any old ~S instances will be in a bad way.~@
-              I hope you know what you're doing..."
-             name)
-       (register-layout new-layout :invalidate nil
-                        :destruct-layout old-layout))))
+       ;; FIXME: deprecated 2002-10-16, and since it's only interactive
+       ;; hackery instead of a supported feature, can probably be deleted
+       ;; in early 2003
+       :report "(deprecated synonym for RECKLESSLY-CONTINUE)"
+       (register-layout new-layout
+                       :invalidate nil
+                       :destruct-layout old-layout))))
   (values))
 
 ;;; This is called when we are about to define a structure class. It