0.8.17.30:

[sbcl.git] / src / code / defstruct.lisp

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 0660f8e..8a72c68 100644 (file)
--- 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
@@ -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))
 
@@ -919,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)
@@ -1080,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))))