0.8.16.6:

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

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 0660f8e..182e978 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))
 
@@ -1080,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))))