diff --git a/code/defstruct.lisp b/code/defstruct.lisp index 1978c441ccf6986a98fff2e0b35845bf1b55a4a5..d3a2f2191e69485e5b1d60f6e40b78659b922c80 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.93 2004/03/31 11:21:01 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.94 2004/09/03 03:05:58 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1823,15 +1823,27 @@ (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 - (write-char #\space stream) - (pprint-indent :block 2 stream) - (pprint-newline :linear stream) - (loop + (cond + ((and (null (dd-slots dd)) *print-level* (>= *current-level* *print-level*)) + ;; The CLHS entry for *PRINT-LENGTH* says "If an object to + ;; be recursively printed has components and is at a level + ;; equal to or greater than the value of *print-level*, + ;; then the object is printed as ``#''." + ;; + ;; So, if it has no components, and we're at *PRINT-LEVEL*, + ;; we print out #(S<name>). + (write-string "#S(" stream) + (prin1 name stream) + (write-char #\) stream)) + (*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) @@ -1844,26 +1856,27 @@ (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)))))))) + (pprint-newline :linear stream))))))) + (t + (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))))))))) (defun make-structure-load-form (structure) (declare (type structure-object structure)) diff --git a/code/print.lisp b/code/print.lisp index 0a9ac33e860d638db84c7b7bff6c167a7efffa19..55919be50b8079d87383134c31731ac878b48118 100644 --- a/code/print.lisp +++ b/code/print.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/print.lisp,v 1.96 2004/08/27 12:25:02 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.97 2004/09/03 03:05:58 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -282,6 +282,8 @@ (cond ((and (pp:pretty-stream-p stream) *print-pretty*) (pprint-logical-block (stream nil :prefix "#<" :suffix ">") (print-description))) + ((and *print-level* (>= *current-level* *print-level*)) + (write-char #\# stream)) (t (write-string "#<" stream) (print-description)