X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=8a72c68ce7612bbe214bdcb502b00e673cf09f42;hb=77d94d36bcfd3d5eea73ad51e6ee621a8938f995;hp=6d70ebeed6980add1042cd96452344d6634ecec8;hpb=beccf6c476f5cf2ef0bd839866527a46ec88d626;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 6d70ebe..8a72c68 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
@@ -609,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
@@ -926,11 +931,13 @@
               `(,value-the ,dsd-type ,(subst instance 'instance
                                              accessor-place-form)))
             (sb!c:source-transform-lambda (new-value instance)
-               (destructuring-bind (accessor-name &rest accessor-args)
-                   accessor-place-form
-                 `(,(info :setf :inverse accessor-name)
-                    ,@(subst instance 'instance accessor-args)
-                    (the ,dsd-type ,new-value)))))))
+              (destructuring-bind (accessor-name &rest accessor-args)
+                  accessor-place-form
+                (once-only ((new-value new-value)
+                            (instance instance))
+                  `(,(info :setf :inverse accessor-name)
+                     ,@(subst instance 'instance accessor-args)
+                     (the ,dsd-type ,new-value))))))))
 
 ;;; Return a LAMBDA form which can be used to set a slot.
 (defun slot-setter-lambda-form (dd dsd)
@@ -1087,10 +1094,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))))