From b6ed0e20d468099b62d27095db7d18f76d8886d2 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 8 Jun 2007 07:55:53 +0000 Subject: [PATCH] 1.0.6.32: printing of layoutless structures * This used be conditionalized for SB-SHOW builds, but they come up often enough when in the debugger during PCL build that it seems worthwhile to keep in core. --- src/code/target-defstruct.lisp | 139 +++++++++++++++++++++-------------------- version.lisp-expr | 2 +- 2 files changed, 73 insertions(+), 68 deletions(-) diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index ef0761fac..2f462ef9f 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -429,81 +429,85 @@ ;;; default PRINT-OBJECT method +(defun %print-structure-sans-layout-info (name stream) + ;; KLUDGE: during PCL build debugging, we can sometimes + ;; attempt to print out a PCL object (with null LAYOUT-INFO). + (pprint-logical-block (stream nil :prefix "#<" :suffix ">") + (prin1 name stream) + (write-char #\space stream) + (write-string "(no LAYOUT-INFO)" stream))) + +(defun %print-structure-sans-slots (name stream) + ;; the structure type doesn't count as a component for *PRINT-LEVEL* + ;; processing. We can likewise elide the logical block processing, + ;; since all we have to print is the type name. -- CSR, 2004-10-05 + (write-string "#S(" stream) + (prin1 name stream) + (write-char #\) stream)) + (defun %default-structure-pretty-print (structure stream) (let* ((layout (%instance-layout structure)) (name (classoid-name (layout-classoid layout))) (dd (layout-info layout))) - ;; KLUDGE: during the build process with SB-SHOW, we can sometimes - ;; attempt to print out a PCL object (with null LAYOUT-INFO). - #!+sb-show - (when (null dd) - (pprint-logical-block (stream nil :prefix "#<" :suffix ">") - (prin1 name stream) - (write-char #\space stream) - (write-string "(no LAYOUT-INFO)")) - (return-from %default-structure-pretty-print nil)) - ;; the structure type doesn't count as a component for - ;; *PRINT-LEVEL* processing. We can likewise elide the logical - ;; block processing, since all we have to print is the type name. - ;; -- CSR, 2004-10-05 - (when (and dd (null (dd-slots dd))) - (write-string "#S(" stream) - (prin1 name stream) - (write-char #\) stream) - (return-from %default-structure-pretty-print nil)) - (pprint-logical-block (stream nil :prefix "#S(" :suffix ")") - (prin1 name stream) - (let ((remaining-slots (dd-slots dd))) - (when remaining-slots - (write-char #\space stream) - ;; CMU CL had (PPRINT-INDENT :BLOCK 2 STREAM) here, - ;; but I can't see why. -- WHN 20000205 - (pprint-newline :linear stream) - (loop - (pprint-pop) - (let ((slot (pop remaining-slots))) - (write-char #\: stream) - (output-symbol-name (symbol-name (dsd-name slot)) stream) - (write-char #\space stream) - (pprint-newline :miser stream) - (output-object (funcall (fdefinition (dsd-accessor-name slot)) - structure) - stream) - (when (null remaining-slots) - (return)) - (write-char #\space stream) - (pprint-newline :linear stream)))))))) + (cond ((not dd) + (%print-structure-sans-layout-info name stream)) + ((not (dd-slots dd)) + (%print-structure-sans-slots name stream)) + (t + (pprint-logical-block (stream nil :prefix "#S(" :suffix ")") + (prin1 name stream) + (let ((remaining-slots (dd-slots dd))) + (when remaining-slots + (write-char #\space stream) + ;; CMU CL had (PPRINT-INDENT :BLOCK 2 STREAM) here, + ;; but I can't see why. -- WHN 20000205 + (pprint-newline :linear stream) + (loop + (pprint-pop) + (let ((slot (pop remaining-slots))) + (write-char #\: stream) + (output-symbol-name (symbol-name (dsd-name slot)) stream) + (write-char #\space stream) + (pprint-newline :miser stream) + (output-object (funcall (fdefinition (dsd-accessor-name slot)) + structure) + stream) + (when (null remaining-slots) + (return)) + (write-char #\space stream) + (pprint-newline :linear stream)))))))))) + (defun %default-structure-ugly-print (structure stream) (let* ((layout (%instance-layout structure)) (name (classoid-name (layout-classoid layout))) (dd (layout-info layout))) - (when (and dd (null (dd-slots dd))) - (write-string "#S(" stream) - (prin1 name stream) - (write-char #\) stream) - (return-from %default-structure-ugly-print nil)) - (descend-into (stream) - (write-string "#S(" stream) - (prin1 name stream) - (do ((index 0 (1+ index)) - (remaining-slots (dd-slots dd) (cdr remaining-slots))) - ((or (null remaining-slots) - (and (not *print-readably*) - *print-length* - (>= index *print-length*))) - (if (null remaining-slots) - (write-string ")" stream) - (write-string " ...)" stream))) - (declare (type index index)) - (write-char #\space stream) - (write-char #\: stream) - (let ((slot (first remaining-slots))) - (output-symbol-name (symbol-name (dsd-name slot)) stream) - (write-char #\space stream) - (output-object - (funcall (fdefinition (dsd-accessor-name slot)) - structure) - stream)))))) + (cond ((not dd) + (%print-structure-sans-layout-info name stream)) + ((not (dd-slots dd)) + (%print-structure-sans-slots name stream)) + (t + (descend-into (stream) + (write-string "#S(" stream) + (prin1 name stream) + (do ((index 0 (1+ index)) + (remaining-slots (dd-slots dd) (cdr remaining-slots))) + ((or (null remaining-slots) + (and (not *print-readably*) + *print-length* + (>= index *print-length*))) + (if (null remaining-slots) + (write-string ")" stream) + (write-string " ...)" stream))) + (declare (type index index)) + (write-string " :" stream) + (let ((slot (first remaining-slots))) + (output-symbol-name (symbol-name (dsd-name slot)) stream) + (write-char #\space stream) + (output-object + (funcall (fdefinition (dsd-accessor-name slot)) + structure) + stream)))))))) + (defun default-structure-print (structure stream depth) (declare (ignore depth)) (cond ((funcallable-instance-p structure) @@ -512,6 +516,7 @@ (%default-structure-pretty-print structure stream)) (t (%default-structure-ugly-print structure stream)))) + (def!method print-object ((x structure-object) stream) (default-structure-print x stream *current-level-in-print*)) diff --git a/version.lisp-expr b/version.lisp-expr index bf8a96b01..0674a340f 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.6.31" +"1.0.6.32" -- 2.11.4.GIT