From 9b82dc5e7f5aec7a4dfad4afad32ab508240521d Mon Sep 17 00:00:00 2001 From: dtc <dtc> Date: Sat, 25 Jul 1998 23:37:39 +0000 Subject: [PATCH] Fix a multitude of problems with the non-pretty print code in default-structure-print; noted by Bill Newman. --- code/defstruct.lisp | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/code/defstruct.lisp b/code/defstruct.lisp index ca0b26fa7..06d4d3850 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.64 1998/07/24 17:17:53 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.65 1998/07/25 23:37:39 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1621,21 +1621,22 @@ (descend-into (stream) (write-string "#S(" stream) (prin1 name stream) - (do ((index 1 (1+ index)) - (length (%instance-length structure)) + (do ((index 0 (1+ index)) (slots (dd-slots dd) (cdr slots))) - ((or (= index length) - (and *print-length* - (= index *print-length*))) - (if (= index length) + ((or (null slots) + (and (not *print-readably*) (eql *print-length* index))) + (if (null slots) (write-string ")" stream) - (write-string "...)" stream))) + (write-string " ...)" stream))) (declare (type index index)) (write-char #\space stream) (write-char #\: stream) - (output-symbol-name (dsd-%name (car slots)) stream) - (write-char #\space stream) - (output-object (%instance-ref structure index) 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)))))))) (defun make-structure-load-form (structure) (declare (type structure-object structure)) -- GitLab