From: Christophe Rhodes <csr21@cantab.net>
Date: Fri, 15 Nov 2013 09:01:41 +0000 (+0000)
Subject: relax restriction on defstruct slot names
X-Git-Url: http://repo.macrolet.net/gitweb/?p=sbcl.git;a=commitdiff_plain;h=69968cef67fa95f22996c0c8784be8cae63099bb

relax restriction on defstruct slot names

DEFSTRUCT slot names are a bit weird, but behave basically like
strings rather than like symbols.  This makes their interaction with
the MOP a little problematic, but for now simply allow things to
pass through and generally work "as expected".

Report from Eric Marsden sbcl-devel 2013-11-05
---

diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo
index 9825343..977e583 100644
--- a/doc/manual/beyond-ansi.texinfo
+++ b/doc/manual/beyond-ansi.texinfo
@@ -309,6 +309,19 @@ however, it is not consistent with the weaker requirement in AMOP, which
 states that any class found by @code{find-class}, no matter what its
 @code{class-name}, is redefined.
 
+@item
+@findex @sbmop{slot-definition-name}
+@tindex @cl{structure-class}
+@findex @cl{defstruct}
+an error is not signaled in the case of the @code{:name} initialization
+argument for @code{slot-definition} objects being a constant, when the
+slot definition is of type @code{structure-slot-definition} (i.e. it is
+associated with a class of type @code{structure-class}).
+
+This allows code which uses constant names for structure slots to
+continue working as specified in ANSI, while enforcing the constraint
+for all other types of slot.
+
 @end itemize
 
 @subsection Metaobject Protocol Extensions
@@ -386,7 +399,7 @@ at
 @findex @cl{find}
 @findex @cl{subseq}
 
-Users of this extension just make instances of @cl{sequence} subclasses
+Users of this extension just make instances of @code{sequence} subclasses
 and transparently operate on them using sequence functions:
 @lisp
 (coerce (subseq (make-instance 'my-sequence) 5 10) 'list)
diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index 6b0c91a..14475ea 100644
--- a/src/pcl/init.lisp
+++ b/src/pcl/init.lisp
@@ -141,7 +141,12 @@
     (error 'slotd-initialization-error :initarg :name :kind :missing))
   (unless (symbolp name)
     (error 'slotd-initialization-type-error :initarg :name :datum name :expected-type 'symbol))
-  (when (constantp name)
+  (when (and (constantp name)
+             ;; KLUDGE: names of structure slots are weird, and their
+             ;; weird behaviour gets grandfathered in this way.  (The
+             ;; negative constraint is hard to express in normal
+             ;; CLOS method terms).
+             (not (typep slotd 'structure-slot-definition)))
     (error 'slotd-initialization-error :initarg :name :kind :constant :value name))
   (when (and initformp (not initfunp))
     (error 'slotd-initialization-error :initarg :initfunction :kind :missing))
diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index 9bfc78c..08b27d9 100644
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -1141,7 +1141,7 @@ redefinition."
   (let ((sb-ext:*evaluator-mode* :compile))
     (handler-bind ((warning #'error))
      (eval `(let ()
-              (defstruct destruct-no-warning-not-at-toplevel bar))))))
+              (defstruct defstruct-no-warning-not-at-toplevel bar))))))
 
 (with-test (:name :bug-941102)
   (let ((test `((defstruct bug-941102)
@@ -1153,3 +1153,8 @@ redefinition."
     (multiple-value-bind (warn2 fail2) (ctu:file-compile test)
       (assert (not warn2))
       (assert (not fail2)))))
+
+(with-test (:name (defstruct :constant-slot-names))
+  (defstruct defstruct-constant-slot-names t)
+  (assert (= 3 (defstruct-constant-slot-names-t
+                (make-defstruct-constant-slot-names :t 3)))))