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.

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index ef0761f..2f462ef 100644 (file)
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -429,81 +429,85 @@
 \f
 ;;; 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*))
 \f

diff --git a/version.lisp-expr b/version.lisp-expr
index bf8a96b..0674a34 100644 (file)
--- 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"