0.pre7.34:

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

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 40f7ba9..621520e 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -121,8 +121,12 @@
   %name        
   ;; its position in the implementation sequence
   (index (required-argument) :type fixnum)
-  ;; Name of accessor, or NIL if this accessor has the same name as an
-  ;; inherited accessor (which we don't want to shadow.)
+  ;; the name of the accessor function
+  ;;
+  ;; (CMU CL had extra complexity here ("..or NIL if this accessor has
+  ;; the same name as an inherited accessor (which we don't want to
+  ;; shadow)") but that behavior doesn't seem to be specified by (or
+  ;; even particularly consistent with) ANSI, so it's gone in SBCL.)
   (accessor nil)
   default                      ; default value expression
   (type t)                     ; declared type specifier
@@ -567,10 +571,7 @@
 ;;; Parse a slot description for DEFSTRUCT, add it to the description
 ;;; and return it. If supplied, ISLOT is a pre-initialized DSD that we
 ;;; modify to get the new slot. This is supplied when handling
-;;; included slots. If the new accessor name is already an accessor
-;;; for same slot in some included structure, then set the
-;;; DSD-ACCESSOR to NIL so that we don't clobber the more general
-;;; accessor.
+;;; included slots.
 (defun parse-1-dsd (defstruct spec &optional
                     (islot (make-defstruct-slot-description :%name ""
                                                             :index 0
@@ -589,10 +590,9 @@
                  read-only ro-p)))
        (t
        (when (keywordp spec)
-         ;; FIXME: should be style warning
-         (warn "Keyword slot name indicates probable syntax ~
-                error in DEFSTRUCT -- ~S."
-               spec))
+         (style-warn "Keyword slot name indicates probable syntax ~
+                      error in DEFSTRUCT: ~S."
+                     spec))
        spec))
 
     (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
@@ -602,18 +602,24 @@
     (setf (dsd-%name islot) (string name))
     (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))
 
-    (let* ((accname (symbolicate (or (dd-conc-name defstruct) "") name))
-          (existing (info :function :accessor-for accname)))
-      (if (and (structure-class-p existing)
-              (not (eq (sb!xc:class-name existing) (dd-name defstruct)))
-              (string= (dsd-%name (find accname
-                                        (dd-slots
-                                         (layout-info
-                                          (class-layout existing)))
-                                        :key #'dsd-accessor))
-                       name))
-       (setf (dsd-accessor islot) nil)
-       (setf (dsd-accessor islot) accname)))
+    (let ((accessor-name (symbolicate (or (dd-conc-name defstruct) "") name))
+         (predicate-name (dd-predicate defstruct)))
+      (setf (dsd-accessor islot) accessor-name)
+      (when (eql accessor-name predicate-name)
+       ;; Some adventurous soul has named a slot so that its accessor
+       ;; collides with the structure type predicate. ANSI doesn't
+       ;; specify what to do in this case. As of 2001-09-04, Martin
+       ;; Atzmueller reports that CLISP and Lispworks both give
+       ;; priority to the slot accessor, so that the predicate is
+       ;; overwritten. We might as well do the same (as well as
+       ;; signalling a warning).
+       (style-warn
+        "~@<The structure accessor name ~S is the same as the name of the ~
+          structure type predicate. ANSI doesn't specify what to do in ~
+          this case; this implementation chooses to overwrite the type ~
+          predicate with the slot accessor.~@:>"
+        accessor-name)
+       (setf (dd-predicate defstruct) nil)))
 
     (when default-p
       (setf (dsd-default islot) default))