From: <ma...@at...> - 2000-11-25 19:20:21
|
Hi, I have been working on another "old" patch. SBCL fails on structures that include other structures, since it won't print "inherited" accessor-slots. In the end it calls #'fdefinition on NIL, and that fails ... My patch is based on a patch by Douglas T. Crosher, that was sent to cmucl-imp: ------------------------ From: Douglas Thomas Crosher <dt...@sc...> Subject: Re: CMUCL commit: src/code defstruct.lisp To: pw...@se... (Paul Werkowski) Date: Wed, 22 Sep 1999 01:47:41 +1000 (EST) Cc: cmu...@co... > DEFAULT-STRUCTURE-PRINT was puking on certain cases of structures that > included other defstructs. An example of a failing case is: > > (defstruct a1 s1) > (defstruct (a2 (:include a1)(:conc-name a1-)) s2) [...] It may be better to always setup the dsd-accessor slot with the name of the accessor function, and test for inherited slots in the few necessary cases. The appended patch adds the function dsd-inherited-p for this test, and always sets the dsd-accessor - giving it some testing now. > NOTE: There is code in ir1tran that also blindly calls fdefinition > on the contents of dsd-accessor. Don't know if this is a latent bug. The compiler appears to be okay as it starts from the accessor function and finds the structure class via (info function accessor-for name), and within this class the accessor will not be Nil. Regards Douglas Crosher ----------------------------- I've looked at current CMUCL. It looks like this patch was integrated. So, probably we should do that, too. Well, I've made a small test-case, and cmucl and sbcl (patched) agree on this. I only tested this using "CHILL", but I hope there are no boot-strapping issues involved here. Below you'll find the test-code and the patch. Cheers, Martin So, here is the test-code: (in-package :cl-user) ;; defstruct-new test (dotimes (i 2) (defstruct a1 s1) (defstruct (a2 (:include a1) (:conc-name a1-)) s2) (assert (print (make-a1))) (assert (print (make-a2))) (let ((a (make-a1 :s1 's1)) (b (make-a2))) (setf (a1-s1 b) 's1) (setf (a1-s2 b) 's2) (assert (eq (a1-s1 a) (a1-s1 b))) (assert (eq (a1-s2 b) 's2)))) and here is the patch: --- /home/ma/data/src/sbcl/src/code/defstruct.lisp Fri Nov 24 20:05:45 2000 +++ bugs-misc/defstruct-new.lisp Sat Nov 25 20:09:06 2000 @@ -119,8 +119,7 @@ %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.) + ;; Name of accessor. (accessor nil) default ; default value expression (type t) ; declared type specifier @@ -148,9 +147,7 @@ ;;; string to avoid creating lots of worthless symbols at load time. (defun dsd-name (dsd) (intern (string (dsd-%name dsd)) - (if (dsd-accessor dsd) - (symbol-package (dsd-accessor dsd)) - (sane-package)))) + (symbol-package (dsd-accessor dsd)))) ;;;; typed (non-class) structures @@ -320,6 +317,19 @@ "attempting to modify a symbol in the COMMON-LISP package: ~S" symbol)))) +;;; True when the defstruct slot has been inherited from an included +;;; structure. +(defun dsd-inherited-p (defstruct slot) + (let* ((fun (dsd-accessor slot)) + (existing (info :function :accessor-for fun))) + (and (structure-class-p existing) + (not (eq (class-name existing) (dd-name defstruct))) + (string= (dsd-%name (find fun + (dd-slots + (layout-info (class-layout existing))) + :key #'dsd-accessor)) + (dsd-%name slot))))) + ;;; Return forms to define readers and writers for raw slots as inline ;;; functions. (defun raw-accessor-definitions (dd) @@ -333,7 +343,8 @@ (multiple-value-bind (accessor offset data) (slot-accessor-form dd slot argname) ;; When accessor exists and is raw - (when (and accname (not (eq accessor '%instance-ref))) + (unless (or (dsd-inherited-p dd slot) + (eq accessor '%instance-ref)) (res `(declaim (inline ,accname))) (res `(declaim (ftype (function (,name) ,stype) ,accname))) (res `(defun ,accname (,argname) @@ -561,10 +572,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 @@ -590,25 +598,14 @@ spec)) (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name) - (error 'simple-program-error + (error 'program-error :format-control "duplicate slot name ~S" :format-arguments (list name))) (setf (dsd-%name islot) (string name)) (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot))) - (let* ((accname (concat-pnames (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))) - + (setf (dsd-accessor islot) + (concat-pnames (dd-conc-name defstruct) name)) (when default-p (setf (dsd-default islot) default)) (when type-p @@ -769,11 +766,13 @@ (let ((old-info (layout-info old-layout))) (when (defstruct-description-p old-info) (dolist (slot (dd-slots old-info)) - (fmakunbound (dsd-accessor slot)) + (unless (dsd-inherited-p old-info slot) + (let ((fun (dsd-accessor slot))) + (fmakunbound fun) (unless (dsd-read-only slot) - (fmakunbound `(setf ,(dsd-accessor slot))))))) + (fmakunbound `(setf ,fun))))))) (%redefine-defstruct class old-layout layout) - (setq layout (class-layout class)))) + (setq layout (class-layout class))))) (setf (sb!xc:find-class (dd-name info)) class) @@ -783,15 +782,15 @@ (unless (eq (dd-type info) 'funcallable-structure) (dolist (slot (dd-slots info)) - (let ((dsd slot)) - (when (and (dsd-accessor slot) - (eq (dsd-raw-type slot) t)) + (unless (or (dsd-inherited-p info slot) + (not (eq (dsd-raw-type slot) 't))) (protect-cl (dsd-accessor slot)) (setf (symbol-function (dsd-accessor slot)) - (structure-slot-getter layout dsd)) + (structure-slot-getter layout slot)) + (unless (dsd-read-only slot) (setf (fdefinition `(setf ,(dsd-accessor slot))) - (structure-slot-setter layout dsd)))))) + (structure-slot-setter layout slot)))))) ;; FIXME: See comment on corresponding code in %%COMPILER-DEFSTRUCT. #| @@ -819,7 +818,7 @@ :format-arguments (list (sb!xc:class-name (layout-class layout)) structure)))) - (copy-structure structure)))))) + (copy-structure structure))))) (when (dd-doc info) (setf (fdocumentation (dd-name info) 'type) (dd-doc info))) @@ -923,7 +922,8 @@ (dolist (slot (dd-slots info)) (let* ((fun (dsd-accessor slot)) (setf-fun `(setf ,fun))) - (when (and fun (eq (dsd-raw-type slot) t)) + (unless (or (dsd-inherited-p info slot) + (not (eq (dsd-raw-type slot) 't))) (proclaim-as-defstruct-function-name fun) (setf (info :function :accessor-for fun) class) (unless (dsd-read-only slot) @@ -1085,10 +1085,11 @@ (undefine-function-name (dd-copier info)) (undefine-function-name (dd-predicate info)) (dolist (slot (dd-slots info)) + (unless (dsd-inherited-p info slot) (let ((fun (dsd-accessor slot))) (undefine-function-name fun) (unless (dsd-read-only slot) - (undefine-function-name `(setf ,fun)))))) + (undefine-function-name `(setf ,fun))))))) ;; Clear out the SPECIFIER-TYPE cache so that subsequent ;; references are unknown types. (values-specifier-type-cache-clear))) @@ -1415,3 +1416,4 @@ (rest args))) (inherits (inherits-for-structure defstruct))) (function-%compiler-only-defstruct defstruct inherits))) + ------------------------------------------ -- Homepage: http://www.atzmueller.net/ Email: ma...@at... |
From: William H. N. <wil...@ai...> - 2000-11-25 22:13:57
|
On Sat, Nov 25, 2000 at 08:20:25PM +0100, ma...@at... wrote: > I have been working on another "old" patch. > SBCL fails on structures that include other structures, since it won't > print "inherited" accessor-slots. In the end it calls #'fdefinition on > NIL, and that fails ... [..] > So, here is the test-code: > > (in-package :cl-user) > > ;; defstruct-new test > (dotimes (i 2) > (defstruct a1 s1) > (defstruct (a2 (:include a1) (:conc-name a1-)) s2) > (assert (print (make-a1))) > (assert (print (make-a2))) > (let ((a (make-a1 :s1 's1)) > (b (make-a2))) > (setf (a1-s1 b) 's1) > (setf (a1-s2 b) 's2) > (assert (eq (a1-s1 a) (a1-s1 b))) > (assert (eq (a1-s2 b) 's2)))) Unless someone has code which has a reasonably good reason for using this behavior, and is broken unless we make this fix, I'd like to put off dealing with this, for two reasons. First, there are several issues in structure implementation that I'd like to straighten out: * More accessors ought to be implemented as closures in order to reduce code size. * Structure accessors shouldn't be treated so specially as they are now. Redefining a structure accessor, or DECLAIMing its FTYPE, should act like you'd expect from reading the ANSI spec. * (probably some other things which I can't think of right away -- I just remember vaguely that I consider structures to be a bit of an unresolved mess.) Until I'm ready to address most or all of these issues systematically, I'm not eager to go and start patching what seems to be obscure and tricky behavior. Second, it's not completely clear to me what should be the correct behavior once people start doing this kind of tricky stuff. Consider (DEFSTRUCT FOO (X 0 :TYPE NUMBER)) (DEFSTRUCT (BAR (:INCLUDE FOO (X 0 :TYPE INTEGER)) (:CONC-NAME "FOO-"))) What should be the FTYPE of FOO-X now? (FUNCTION (FOO) NUMBER)? (FUNCTION (FOO) INTEGER)? (FUNCTION (BAR) INTEGER)? What about the FTYPE of (SETF FOO-X)? My first impression is that the correct behavior is for the most recent definition simply to overwrite any older definitions. Thus, in my example above, the final FTYPE of FOO-X is (FUNCTION (BAR) INTEGER), and the final FTYPE of (SETF FOO-X) is (FUNCTION (INTEGER BAR) INTEGER). And thus, the behavior which you're requiring above in your test code, where calling (A1-S1 A) doesn't cause a TYPE-ERROR, looks incorrect. -- William Harold Newman <wil...@ai...> software consultant PGP key fingerprint 85 CE 1C BA 79 8D 51 8C B9 25 FB EE E0 C3 E5 7C |
From: <ma...@at...> - 2000-11-27 10:09:00
|
William Harold Newman wrote: > > On Sat, Nov 25, 2000 at 08:20:25PM +0100, ma...@at... wrote: > > I have been working on another "old" patch. > > SBCL fails on structures that include other structures, since it won't > > print "inherited" accessor-slots. In the end it calls #'fdefinition on > > NIL, and that fails ... [...] > Unless someone has code which has a reasonably good reason for > using this behavior, and is broken unless we make this fix, > I'd like to put off dealing with this, for two reasons. > > First, there are several issues in structure implementation that I'd > like to straighten out: > * More accessors ought to be implemented as closures in order to > reduce code size. > * Structure accessors shouldn't be treated so specially as they > are now. Redefining a structure accessor, or DECLAIMing its > FTYPE, should act like you'd expect from reading the ANSI spec. > * (probably some other things which I can't think of right > away -- I just remember vaguely that I consider structures > to be a bit of an unresolved mess.) > Until I'm ready to address most or all of these issues systematically, > I'm not eager to go and start patching what seems to be obscure and > tricky behavior. Ok. I agree. The most pressing issue at hand now seems to be the sigint handling ... :-| > Second, it's not completely clear to me what should be the correct > behavior once people start doing this kind of tricky stuff. Consider > (DEFSTRUCT FOO > (X 0 :TYPE NUMBER)) > (DEFSTRUCT (BAR (:INCLUDE FOO (X 0 :TYPE INTEGER)) > (:CONC-NAME "FOO-"))) > What should be the FTYPE of FOO-X now? > (FUNCTION (FOO) NUMBER)? > (FUNCTION (FOO) INTEGER)? > (FUNCTION (BAR) INTEGER)? > What about the FTYPE of (SETF FOO-X)? My first impression is that the > correct behavior is for the most recent definition simply to overwrite > any older definitions. Thus, in my example above, the final FTYPE of > FOO-X is (FUNCTION (BAR) INTEGER), and the final FTYPE of (SETF FOO-X) > is (FUNCTION (INTEGER BAR) INTEGER). And thus, the behavior which > you're requiring above in your test code, where calling (A1-S1 A) > doesn't cause a TYPE-ERROR, looks incorrect. Yes, IMHO the patch should cause a type-error in the above case I've looked at CLHS section 8.1 (Macro defstruct): it seems to me, that the above definition is simply incorrect, since an inherited slot "must have" (CLHS) the same type as the original slot. So the FTYPE should be (FUNCTION (BAR) NUMBER), and a type error should be generated. Cheers, Martin -- Homepage: http://www.atzmueller.net/ Email: ma...@at... |