X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=b0f374b0bf7629b017ac196f45b7c792ecafb2cb;hb=67dc5cf478dfe5e3f517001febb9a8f7b922eacf;hp=0660f8e5e24318a6eebbbccf0f0aa6c0d5c9b310;hpb=d48e55084636a84d1b54f1f7370fa98c55f3ec6e;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 0660f8e..b0f374b 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -337,15 +337,18 @@
        (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.
+		;; Note we intentionally enforce package locks and
+		;; 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.
+	        (with-single-package-locked-error
+		    (:symbol ',name "defining ~A as a structure"))
 		(%defstruct ',dd ',inherits)
 		(eval-when (:compile-toplevel :load-toplevel :execute)
 		  (%compiler-defstruct ',dd ',inherits))
@@ -358,6 +361,8 @@
 			    (class-method-definitions dd)))
 		',name))
 	   `(progn
+	      (with-single-package-locked-error
+		  (:symbol ',name "defining ~A as a structure"))
 	      (eval-when (:compile-toplevel :load-toplevel :execute)
 		(setf (info :typed-structure :info ',name) ',dd))
 	      ,@(unless expanding-into-code-for-xc-host-p
@@ -657,11 +662,18 @@
           remove the ambiguity in your code.~@:>"
 	 accessor-name)
 	(setf (dd-predicate-name defstruct) nil))
-      #-sb-xc-host
-      (when (and (fboundp accessor-name)
-		 (not (accessor-inherited-data accessor-name defstruct)))
-	(style-warn "redefining ~S in DEFSTRUCT" accessor-name)))
-
+      ;; FIXME: It would be good to check for name collisions here, but
+      ;; the easy check,
+      ;;x#-sb-xc-host
+      ;;x(when (and (fboundp accessor-name)
+      ;;x           (not (accessor-inherited-data accessor-name defstruct)))
+      ;;x  (style-warn "redefining ~S in DEFSTRUCT" accessor-name)))
+      ;; which was done until sbcl-0.8.11.18 or so, is wrong: it causes
+      ;; a warning at MACROEXPAND time, when instead the warning should
+      ;; occur not just because the code was constructed, but because it
+      ;; is actually compiled or loaded.
+      )
+    
     (when default-p
       (setf (dsd-default slot) default))
     (when type-p
@@ -673,8 +685,8 @@
       (if read-only
 	  (setf (dsd-read-only slot) t)
 	  (when (dsd-read-only slot)
-	    (error "Slot ~S is :READ-ONLY in parent and must be :READ-ONLY in subtype ~S."
-		   name
+	    (error "~@<The slot ~S is :READ-ONLY in superclass, and so must ~
+                       be :READ-ONLY in subclass.~:@>"
 		   (dsd-name slot)))))
     slot))