X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=621520ea439fe59ee5d20103afa0844bc4c65d10;hb=0dcc957ae6bf24809fda82fd59c134e70058c42a;hp=dd97a6d8e7b775b84bc3c368f555caae4abe57b2;hpb=f4f18b9dcdaf1948947b1747f5bfa766a1a0ee4c;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index dd97a6d..621520ea 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -571,7 +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. 
+;;; included slots.
 (defun parse-1-dsd (defstruct spec &optional
 		     (islot (make-defstruct-slot-description :%name ""
 							     :index 0
@@ -590,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,8 +601,25 @@
 	     :format-arguments (list name)))
     (setf (dsd-%name islot) (string name))
     (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))
-    (setf (dsd-accessor islot)
-	  (symbolicate (or (dd-conc-name defstruct) "") name))
+
+    (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))