From a23903deaf6348cc088eb0f992a99cdba0a37d66 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 4 Dec 2002 10:00:51 +0000 Subject: [PATCH] 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 --- BUGS | 6 --- CREDITS | 3 +- NEWS | 6 +++ src/code/defstruct.lisp | 115 +++++++++++++++++++++++++++------------- src/code/early-fasl.lisp | 4 +- src/code/target-defstruct.lisp | 29 +++++----- tests/defstruct.impure.lisp | 31 ++++++++++- version.lisp-expr | 2 +- 8 files changed, 136 insertions(+), 60 deletions(-) diff --git a/BUGS b/BUGS index e76569d..7cdead5 100644 --- a/BUGS +++ b/BUGS @@ -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, diff --git a/CREDITS b/CREDITS index d0de362..e3492ea 100644 --- a/CREDITS +++ b/CREDITS @@ -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 diff --git a/NEWS b/NEWS index e3b8953..d1007b2 100644 --- a/NEWS +++ b/NEWS @@ -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 diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index eece961..de54368 100644 --- 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 "~@" 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 "~@" + 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))) diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index cc74cc2..2f63d5c 100644 --- 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*)) diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 858e452..03f368a 100644 --- 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) diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index c86fb9e..a9d2f1e 100644 --- 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) diff --git a/version.lisp-expr b/version.lisp-expr index 7ba229d..c5aba7c 100644 --- 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" -- 1.7.10.4