X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fdefstruct.lisp;h=2adbc997870ae1b45f356f96a501d8fc446d03de;hb=26148f0c8d7d35e1c5e1d363ade79552cbeb0386;hp=a894f47ebd62e9046fa93ec29e6aa66801fc1258;hpb=d2cbbce99d82ad691626e6371085e5b20e7cb6c2;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index a894f47..2adbc99 100644
--- 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