0.7.10.9:

Merge fix for bug 127 (Valtteri Vuorikoski sbcl-devel 2002-11-30) (entomotomy: ... store a (ACCESSOR-NAME . INDEX) alist, not just a list of accessor names, so that we can detect some other edge cases ... write some basic tests ... increment fasl file version
2026-09-10 07:26:40 -04:00 · 2002-12-04 10:00:51 +00:00 · 2002-12-04 10:00:51 +00:00 · a23903deaf
parent d8346491af
commit a23903deaf
8 changed files with 136 additions and 60 deletions
--- a/6
+++ b/6
@ -616,12 +616,6 @@ WORKAROUND:
   Evidently Python thinks of the lambda as a code transformation so
   much that it forgets that it's also an object.

-127:
-  The DEFSTRUCT section of the ANSI spec, in the :CONC-NAME section,
-  specifies a precedence rule for name collisions between slot accessors of
-  structure classes related by inheritance. As of 0.7.0, SBCL still 
-  doesn't follow it.
-
 135:
  Ideally, uninterning a symbol would allow it, and its associated
  FDEFINITION and PROCLAIM data, to be reclaimed by the GC. However,
--- a/3
+++ b/3
@ -616,7 +616,8 @@ Peter Van Eynde:
  reports as well.

 Valtteri Vuorikoski:
-  He ported SBCL to NetBSD.
+  He ported SBCL to NetBSD, and also fixed a long-standing bug in
+  DEFSTRUCT with respect to colliding accessor names.

 Colin Walters:
  His O(N) implementation of the general case of MAP, posted on the
--- a/6
+++ b/6
@ -1432,6 +1432,10 @@ changes in sbcl-0.7.10 relative to sbcl-0.7.9:
    SXHASH-related changes in the layout of CLOS data structures

 changes in sbcl-0.7.11 relative to sbcl-0.7.10:
+  * fixed bug 127: DEFSTRUCT now does not clobber old structure
+    accessors that are related by inheritance, as specified in the
+    :CONC-NAME section of the specification of DEFSTRUCT.  (thanks to
+    Valtteri Vuorikoski)
  * fixed some more bugs revealed by Paul Dietz' test suite:
    ** As required by ANSI, LOOP now disallows anonymous collection
       clauses such as COLLECT I in conjunction with aggregate boolean
@ -1441,6 +1445,8 @@ changes in sbcl-0.7.11 relative to sbcl-0.7.10:
       to WITH A = 1 WITH A = (1+ A);
    ** IT is only a special loop symbol within the first clause of a
       conditional loop clause;
+  * incremented fasl file version number, because of the incompatible
+    change to the DEFSTRUCT-DESCRIPTION structure.

 planned incompatible changes in 0.7.x:
  * (not done yet, but planned:) When the profiling interface settles
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@ -106,6 +106,8 @@
  ;; a list of DEFSTRUCT-SLOT-DESCRIPTION objects for all slots
  ;; (including included ones)
  (slots () :type list)
+  ;; a list of (NAME . INDEX) pairs for accessors of included structures
+  (inherited-accessor-alist () :type list)
  ;; number of elements we've allocated (See also RAW-LENGTH.)
  (length 0 :type index)
  ;; General kind of implementation.
@ -410,6 +412,11 @@

 ;;;; functions to generate code for various parts of DEFSTRUCT definitions

+;;; First, a helper to determine whether a name names an inherited
+;;; accessor.
+(defun accessor-inherited-data (name defstruct)
+  (assoc name (dd-inherited-accessor-alist defstruct) :test #'eq))
+
 ;;; Return a list of forms which create a predicate function for a
 ;;; typed DEFSTRUCT.
 (defun typed-predicate-definitions (defstruct)
@ -442,18 +449,26 @@
 	      (index (dsd-index slot))
 	      (slot-type `(and ,(dsd-type slot)
 			       ,(dd-element-type defstruct))))
-	  (stuff `(proclaim '(inline ,name (setf ,name))))
-	  ;; FIXME: The arguments in the next two DEFUNs should be
-	  ;; gensyms. (Otherwise e.g. if NEW-VALUE happened to be the
-	  ;; name of a special variable, things could get weird.)
-	  (stuff `(defun ,name (structure)
-		    (declare (type ,ltype structure))
-		    (the ,slot-type (elt structure ,index))))
-	  (unless (dsd-read-only slot)
-	    (stuff
-	     `(defun (setf ,name) (new-value structure)
-		(declare (type ,ltype structure) (type ,slot-type new-value))
-		(setf (elt structure ,index) new-value)))))))
+	  (let ((inherited (accessor-inherited-data name defstruct)))
+	    (cond
+	      ((not inherited)
+	       (stuff `(proclaim '(inline ,name (setf ,name))))
+	       ;; FIXME: The arguments in the next two DEFUNs should
+	       ;; be gensyms. (Otherwise e.g. if NEW-VALUE happened to
+	       ;; be the name of a special variable, things could get
+	       ;; weird.)
+	       (stuff `(defun ,name (structure)
+			(declare (type ,ltype structure))
+			(the ,slot-type (elt structure ,index))))
+	       (unless (dsd-read-only slot)
+		 (stuff
+		  `(defun (setf ,name) (new-value structure)
+		    (declare (type ,ltype structure) (type ,slot-type new-value))
+		    (setf (elt structure ,index) new-value)))))
+	      ((not (= (cdr inherited) index))
+	       (style-warn "~@<Non-overwritten accessor ~S does not access ~
+                            slot with name ~S (accessing an inherited slot ~
+                            instead).~:@>" name (dsd-%name slot))))))))
    (stuff)))

 ;;;; parsing
@ -629,7 +644,11 @@
          accessor, but you can't rely on this behavior, so it'd be wise to ~
          remove the ambiguity in your code.~@:>"
 	 accessor-name)
-	(setf (dd-predicate-name defstruct) nil)))
+	(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)))

    (when default-p
      (setf (dsd-default slot) default))
@ -760,12 +779,26 @@
 	(setf (dd-raw-index dd) (dd-raw-index included-structure))
 	(setf (dd-raw-length dd) (dd-raw-length included-structure)))

+      (setf (dd-inherited-accessor-alist dd)
+	    (dd-inherited-accessor-alist included-structure))
      (dolist (included-slot (dd-slots included-structure))
 	(let* ((included-name (dsd-name included-slot))
 	       (modified (or (find included-name modified-slots
 				   :key (lambda (x) (if (atom x) x (car x)))
 				   :test #'string=)
 			     `(,included-name))))
+	  ;; We stash away an alist of accessors to parents' slots
+	  ;; that have already been created to avoid conflicts later
+	  ;; so that structures with :INCLUDE and :CONC-NAME (and
+	  ;; other edge cases) can work as specified.
+	  (when (dsd-accessor-name included-slot)
+	    ;; the "oldest" (i.e. highest up the tree of inheritance)
+	    ;; will prevail, so don't push new ones on if they
+	    ;; conflict.
+	    (pushnew (cons (dsd-accessor-name included-slot)
+			   (dsd-index included-slot))
+		     (dd-inherited-accessor-alist dd)
+		     :test #'eq :key #'car))
 	  (parse-1-dsd dd
 		       modified
 		       (copy-structure included-slot)))))))
@ -959,26 +992,35 @@
      (let* ((accessor-name (dsd-accessor-name dsd))
 	     (dsd-type (dsd-type dsd)))
 	(when accessor-name
-	  (multiple-value-bind (reader-designator writer-designator)
-	      (slot-accessor-inline-expansion-designators dd dsd)
-	    (sb!xc:proclaim `(ftype (function (,dtype) ,dsd-type)
-				    ,accessor-name))
-	    (setf (info :function :inline-expansion-designator accessor-name)
-		  reader-designator
-		  (info :function :inlinep accessor-name)
-		  :inline)
-	    (unless (dsd-read-only dsd)
-	      (let ((setf-accessor-name `(setf ,accessor-name)))
-		(sb!xc:proclaim
-		 `(ftype (function (,dsd-type ,dtype) ,dsd-type)
-			 ,setf-accessor-name))
-		(setf (info :function
-			    :inline-expansion-designator
-			    setf-accessor-name)
-		      writer-designator
-		      (info :function :inlinep setf-accessor-name)
-		      :inline))))))))
-
+	  (let ((inherited (accessor-inherited-data accessor-name dd)))
+	    (cond
+	      ((not inherited)
+	       (multiple-value-bind (reader-designator writer-designator)
+		   (slot-accessor-inline-expansion-designators dd dsd)
+		 (sb!xc:proclaim `(ftype (function (,dtype) ,dsd-type)
+				   ,accessor-name))
+		 (setf (info :function :inline-expansion-designator
+			     accessor-name)
+		       reader-designator
+		       (info :function :inlinep accessor-name)
+		       :inline)
+		 (unless (dsd-read-only dsd)
+		   (let ((setf-accessor-name `(setf ,accessor-name)))
+		     (sb!xc:proclaim
+		      `(ftype (function (,dsd-type ,dtype) ,dsd-type)
+			,setf-accessor-name))
+		     (setf (info :function
+				 :inline-expansion-designator
+				 setf-accessor-name)
+			   writer-designator
+			   (info :function :inlinep setf-accessor-name)
+			   :inline)))))
+	      ((not (= (cdr inherited) (dsd-index dsd)))
+	       (style-warn "~@<Non-overwritten accessor ~S does not access ~
+                            slot with name ~S (accessing an inherited slot ~
+                            instead).~:@>"
+			   accessor-name
+			   (dsd-%name dsd)))))))))
  (values))

 ;;;; redefinition stuff
@ -1148,9 +1190,10 @@
 	(undefine-fun-name (dd-predicate-name info))
 	(dolist (slot (dd-slots info))
 	  (let ((fun (dsd-accessor-name slot)))
-	    (undefine-fun-name fun)
-	    (unless (dsd-read-only slot)
-	      (undefine-fun-name `(setf ,fun))))))
+	    (unless (accessor-inherited-data fun info)
+	      (undefine-fun-name fun)
+	      (unless (dsd-read-only slot)
+		(undefine-fun-name `(setf ,fun)))))))
      ;; Clear out the SPECIFIER-TYPE cache so that subsequent
      ;; references are unknown types.
      (values-specifier-type-cache-clear)))
--- a/src/code/early-fasl.lisp
+++ b/src/code/early-fasl.lisp
@ -42,7 +42,7 @@
 ;;; versions which break binary compatibility. But it certainly should
 ;;; be incremented for release versions which break binary
 ;;; compatibility.
-(def!constant +fasl-file-version+ 35)
+(def!constant +fasl-file-version+ 36)
 ;;; (record of versions before 0.7.0 deleted in 0.7.1.41)
 ;;; 23 = sbcl-0.7.0.1 deleted no-longer-used EVAL-STACK stuff,
 ;;;      causing changes in *STATIC-SYMBOLS*.
@ -71,6 +71,8 @@
 ;;;     reflecting changes from a week or more ago) changed layout of
 ;;;     CLOS objects to support SXHASH returning values other than 42
 ;;;     for STANDARD-OBJECT
+;;; 36: (2002-12-04) DEFSTRUCT-DESCRIPTION layout changed to accommodate
+;;;     correct behaviour of colliding accessors

 ;;; the conventional file extension for our fasl files
 (declaim (type simple-string *fasl-file-type*))
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@ -177,19 +177,22 @@
  (dolist (dsd (dd-slots dd))
    (/show0 "doing FDEFINITION for slot accessor")
    (let ((accessor-name (dsd-accessor-name dsd)))
-      (/show0 "ACCESSOR-NAME=..")
-      (/hexstr accessor-name)
-      (protect-cl accessor-name)
-      (/hexstr "getting READER-FUN and WRITER-FUN")
-      (multiple-value-bind (reader-fun writer-fun) (slot-accessor-funs dd dsd)
-	(declare (type function reader-fun writer-fun))
-	(/show0 "got READER-FUN and WRITER-FUN=..")
-	(/hexstr reader-fun)
-	(setf (symbol-function accessor-name) reader-fun)
-	(unless (dsd-read-only dsd)
-	  (/show0 "setting FDEFINITION for WRITER-FUN=..")
-	  (/hexstr writer-fun)
-	  (setf (fdefinition `(setf ,accessor-name)) writer-fun)))))
+      ;; We mustn't step on any inherited accessors
+      (unless (accessor-inherited-data accessor-name dd)
+	(/show0 "ACCESSOR-NAME=..")
+	(/hexstr accessor-name)
+	(protect-cl accessor-name)
+	(/hexstr "getting READER-FUN and WRITER-FUN")
+	(multiple-value-bind (reader-fun writer-fun)
+	    (slot-accessor-funs dd dsd)
+	  (declare (type function reader-fun writer-fun))
+	  (/show0 "got READER-FUN and WRITER-FUN=..")
+	  (/hexstr reader-fun)
+	  (setf (symbol-function accessor-name) reader-fun)
+	  (unless (dsd-read-only dsd)
+	    (/show0 "setting FDEFINITION for WRITER-FUN=..")
+	    (/hexstr writer-fun)
+	    (setf (fdefinition `(setf ,accessor-name)) writer-fun))))))

  ;; Set FDEFINITION for copier.
  (when (dd-copier-name dd)
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@ -21,8 +21,8 @@
 (defstruct person age (name 007 :type string)) ; not an error until 007 used
 (make-person :name "James") ; not an error, 007 not used
 (assert (raises-error? (make-person) type-error))
-;;; FIXME: broken structure slot type checking in sbcl-0.pre7.62
-#+nil (assert (raises-error? (setf (person-name (make-person "Q")) 1) type-error))
+(assert (raises-error? (setf (person-name (make-person :name "Q")) 1)
+		       type-error))

 ;;; basic inheritance
 (defstruct (astronaut (:include person)
@ -389,6 +389,33 @@
  (assert (eq (foo-0-7-8-53-x foo-0-7-8-53) :s))
  (assert (eq (foo-0-7-8-53-y foo-0-7-8-53) :not)))

+;;; tests of behaviour of colliding accessors.
+(defstruct (bug127-foo (:conc-name bug127-baz-)) a)
+(assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1))
+(defstruct (bug127-bar (:conc-name bug127-baz-) (:include bug127-foo)) b)
+(assert (= (bug127-baz-a (make-bug127-bar :a 1 :b 2)) 1))
+(assert (= (bug127-baz-b (make-bug127-bar :a 1 :b 2)) 2))
+(assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1))
+
+(defun bug127-flurble (x)
+  x)
+(defstruct bug127 flurble)
+(assert (= (bug127-flurble (make-bug127 :flurble 7)) 7))
+
+(defstruct bug127-a b-c)
+(assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9))
+(defstruct (bug127-a-b (:include bug127-a)) c)
+(assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9))
+(assert (= (bug127-a-b-c (make-bug127-a-b :b-c 11 :c 13)) 11))
+
+(defstruct (bug127-e (:conc-name bug127--)) foo)
+(assert (= (bug127--foo (make-bug127-e :foo 3)) 3))
+(defstruct (bug127-f (:conc-name bug127--)) foo)
+(assert (= (bug127--foo (make-bug127-f :foo 3)) 3))
+(assert (raises-error? (bug127--foo (make-bug127-e :foo 3)) type-error))
+
+;;; FIXME: should probably do the same tests on DEFSTRUCT :TYPE
+
 ;;; success
 (format t "~&/returning success~%")
 (quit :unix-status 104)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)

-"0.7.10.8"
+"0.7.10.9"