X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=b0f374b0bf7629b017ac196f45b7c792ecafb2cb;hb=e8e3ccee2ad4acb6ee1774d91648b68254868483;hp=391aae10f0ef8c0490cd2acc5ebce6a8eb28df94;hpb=68612b8227bdd1a9e70962201f54231c82affa17;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 391aae1..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
@@ -424,15 +429,16 @@
 	    (and (typep ,argname ',ltype)
 		 ,(cond
 		   ((subtypep ltype 'list)
-		    `(consp (nthcdr ,name-index (the ,ltype ,argname))))
+                     `(do ((head (the ,ltype ,argname) (cdr head))
+			   (i 0 (1+ i)))
+		          ((or (not (consp head)) (= i ,name-index))
+			   (and (consp head) (eq ',name (car head))))))
 		   ((subtypep ltype 'vector)
-		    `(= (length (the ,ltype ,argname))
-		        ,(dd-length defstruct)))
+		    `(and (= (length (the ,ltype ,argname))
+			   ,(dd-length defstruct))
+		          (eq ',name (aref (the ,ltype ,argname) ,name-index))))
 		   (t (bug "Uncatered-for lisp type in typed DEFSTRUCT: ~S."
-			   ltype)))
-		 (eq (elt (the ,ltype ,argname)
-			  ,name-index)
-		     ',name))))))))
+			   ltype))))))))))
 
 ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT.
 (defun typed-copier-definitions (defstruct)
@@ -656,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
@@ -672,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))