1.0.33.6: prettier PRINT-OBJECT default method

If *PRINT-PRETTY*, the default method of PRINT-OBJECT now establishes
a logical block around PRINT-UNREADABLE-OBJECT that, in turn, adds a
few PPRINT-NEWLINES to allow for the stuff between #< and > be broken
into multiple lines as the pretty printer sees fit. This allows #<...>
to be wrapped properly.

https://bugs.launchpad.net/sbcl/+bug/488979

diff --git a/NEWS b/NEWS
index 364bfc2..3d11b7d 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -6,6 +6,8 @@ changes relative to sbcl-1.0.33:
     Willem Broekema; launchpad bug lp#489698).
   * bug fix: some minor code rearrangements to reenable warning-free building
     from CMUCL (reported by xme@gmx.net; launchpad bug lp#491104)
+  * bug fix: PRINT-OBJECT for clos instances respects the right margin when
+    pretty printing
 
 changes in sbcl-1.0.33 relative to sbcl-1.0.32:
   * new port: support added for x86-64 NetBSD.  (thanks to Aymeric Vincent)

diff --git a/src/code/print.lisp b/src/code/print.lisp
index 31b48ab..8e6e0c8 100644 (file)
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -316,10 +316,12 @@
                     :level nil :length nil)
              (write-char #\space stream))
            (when body
+             (pprint-newline :fill stream)
              (funcall body))
            (when identity
              (when (or body (not type))
                (write-char #\space stream))
+             (pprint-newline :fill stream)
              (write-char #\{ stream)
              (write (get-lisp-obj-address object) :stream stream
                     :radix nil :base 16)
@@ -332,9 +334,9 @@
            (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
              (print-description)))
           (t
-            (write-string "#<" stream)
-            (print-description)
-            (write-char #\> stream))))
+           (write-string "#<" stream)
+           (print-description)
+           (write-char #\> stream))))
   nil)
 \f
 ;;;; OUTPUT-OBJECT -- the main entry point

diff --git a/src/pcl/print-object.lisp b/src/pcl/print-object.lisp
index b5c2500..7711dab 100644 (file)
--- a/src/pcl/print-object.lisp
+++ b/src/pcl/print-object.lisp
@@ -46,7 +46,10 @@
   (fmakunbound 'print-object)
   (defgeneric print-object (object stream))
   (defmethod print-object ((x t) stream)
-    (print-unreadable-object (x stream :type t :identity t))))
+    (if *print-pretty*
+        (pprint-logical-block (stream nil)
+          (print-unreadable-object (x stream :type t :identity t)))
+        (print-unreadable-object (x stream :type t :identity t)))))
 (/show0 "done replacing placeholder PRINT-OBJECT with DEFGENERIC")
 \f
 ;;;; a hook called by the printer to take care of dispatching to PRINT-OBJECT

diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp
index 7766b39..382483a 100644 (file)
--- a/tests/print.impure.lisp
+++ b/tests/print.impure.lisp
@@ -456,4 +456,20 @@
       (let ((*print-pretty* t))
         (assert (string= (princ-to-string 'bar) "BAR"))))))
 
+;;; bug-lp#488979
+
+(defclass a-class-name () ())
+
+(assert (find #\Newline
+              (let ((*print-pretty* t)
+                    (*print-right-margin* 10))
+                (format nil "~A" (make-instance 'a-class-name)))
+              :test #'char=))
+
+(assert (not (find #\Newline
+                   (let ((*print-pretty* nil)
+                         (*print-right-margin* 10))
+                     (format nil "~A" (make-instance 'a-class-name)))
+                   :test #'char=)))
+
 ;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 8a41bfe..436b013 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.33.5"
+"1.0.33.6"