From 20f739827c4f3d6a46feef268eaa43e6ea2cabc8 Mon Sep 17 00:00:00 2001 From: pw <pw> Date: Mon, 20 Sep 1999 11:12:59 +0000 Subject: [PATCH] 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) as seen in Hemlock source. The problem was that the dsd-accessor slot is documented to sometimes contain NIL but default-structure-print blindly called fdefinition on the sometimes NIL value. The fix here is to compute the slot accessor name from the conc-name and slot-name. 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. --- code/defstruct.lisp | 87 ++++++++++++++++++++++++--------------------- 1 file changed, 46 insertions(+), 41 deletions(-) diff --git a/code/defstruct.lisp b/code/defstruct.lisp index 3555b240f..ab8676810 100644 --- a/code/defstruct.lisp +++ b/code/defstruct.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.66 1998/12/19 15:56:19 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.67 1999/09/20 11:12:59 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1619,47 +1619,52 @@ (let* ((type (%instance-layout structure)) (name (class-name (layout-class type))) (dd (layout-info type))) - (if *print-pretty* - (pprint-logical-block (stream nil :prefix "#S(" :suffix ")") - (prin1 name stream) - (let ((slots (dd-slots dd))) - (when slots + (flet ((slot-accessor (slot) + (let ((aname + (intern (concatenate + 'simple-string + (symbol-name (kernel::dd-conc-name dd)) + (dsd-%name slot))))) + (fdefinition aname)))) + (if *print-pretty* + (pprint-logical-block (stream nil :prefix "#S(" :suffix ")") + (prin1 name stream) + (let ((slots (dd-slots dd))) + (when slots + (write-char #\space stream) + (pprint-indent :block 2 stream) + (pprint-newline :linear stream) + (loop + (pprint-pop) + (let ((slot (pop slots))) + (write-char #\: stream) + (output-symbol-name (dsd-%name slot) stream) + (write-char #\space stream) + (pprint-newline :miser stream) + (output-object + (funcall (slot-accessor slot) structure) stream) + (when (null slots) + (return)) + (write-char #\space stream) + (pprint-newline :linear stream)))))) + (descend-into (stream) + (write-string "#S(" stream) + (prin1 name stream) + (do ((index 0 (1+ index)) + (slots (dd-slots dd) (cdr slots))) + ((or (null slots) + (and (not *print-readably*)(eql *print-length* index))) + (if (null slots) + (write-string ")" stream) + (write-string " ...)" stream))) + (declare (type index index)) (write-char #\space stream) - (pprint-indent :block 2 stream) - (pprint-newline :linear stream) - (loop - (pprint-pop) - (let ((slot (pop slots))) - (write-char #\: stream) - (output-symbol-name (dsd-%name slot) stream) - (write-char #\space stream) - (pprint-newline :miser stream) - (output-object (funcall (fdefinition (dsd-accessor slot)) - structure) - stream) - (when (null slots) - (return)) - (write-char #\space stream) - (pprint-newline :linear stream)))))) - (descend-into (stream) - (write-string "#S(" stream) - (prin1 name stream) - (do ((index 0 (1+ index)) - (slots (dd-slots dd) (cdr slots))) - ((or (null slots) - (and (not *print-readably*) (eql *print-length* index))) - (if (null slots) - (write-string ")" stream) - (write-string " ...)" stream))) - (declare (type index index)) - (write-char #\space stream) - (write-char #\: stream) - (let ((slot (first slots))) - (output-symbol-name (dsd-%name slot) stream) - (write-char #\space stream) - (output-object (funcall (fdefinition (dsd-accessor slot)) - structure) - stream)))))))) + (write-char #\: stream) + (let ((slot (first slots))) + (output-symbol-name (dsd-%name slot) stream) + (write-char #\space stream) + (output-object + (funcall (slot-accessor slot) structure) stream))))))))) (defun make-structure-load-form (structure) (declare (type structure-object structure)) -- GitLab