X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=182e978bc48e42fe96185ff7ea11d2b8502539d4;hb=771b864c8f32af7734bc0550aeaf1539fc4df194;hp=4b0f84da86fe202712ce741cd1c376892115c87d;hpb=f409f90c5e8c4c87ed9fa6efdc0e5c1952d94602;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 4b0f84d..182e978 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)
@@ -455,7 +461,7 @@
 	  (let ((inherited (accessor-inherited-data name defstruct)))
 	    (cond
 	      ((not inherited)
-	       (stuff `(proclaim '(inline ,name (setf ,name))))
+	       (stuff `(declaim (inline ,name (setf ,name))))
 	       ;; FIXME: The arguments in the next two DEFUNs should
 	       ;; be gensyms. (Otherwise e.g. if NEW-VALUE happened to
 	       ;; be the name of a special variable, things could get
@@ -608,7 +614,7 @@
 	(symbol
 	 (when (keywordp spec)
 	   (style-warn "Keyword slot name indicates probable syntax ~
-		        error in DEFSTRUCT: ~S."
+                        error in DEFSTRUCT: ~S."
 		       spec))
 	 spec)
 	(cons
@@ -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))
 
@@ -993,7 +1006,7 @@
 
     (let ((predicate-name (dd-predicate-name dd)))
       (when predicate-name
-	(sb!xc:proclaim `(ftype (sfunction (t) t) ,predicate-name))
+	(sb!xc:proclaim `(ftype (sfunction (t) boolean) ,predicate-name))
 	;; Provide inline expansion (or not).
 	(ecase (dd-type dd)
 	  ((structure funcallable-structure)
@@ -1079,10 +1092,10 @@
       (when (or moved retyped deleted)
 	(warn
 	 "incompatibly redefining slots of structure class ~S~@
-	  Make sure any uses of affected accessors are recompiled:~@
-	  ~@[  These slots were moved to new positions:~%    ~S~%~]~
-	  ~@[  These slots have new incompatible types:~%    ~S~%~]~
-	  ~@[  These slots were deleted:~%    ~S~%~]"
+          Make sure any uses of affected accessors are recompiled:~@
+          ~@[  These slots were moved to new positions:~%    ~S~%~]~
+          ~@[  These slots have new incompatible types:~%    ~S~%~]~
+          ~@[  These slots were deleted:~%    ~S~%~]"
 	 name moved retyped deleted)
 	t))))