use *SUPPRESS-PRINT-ERRORS* for backtraces and DESCRIBE

 The suppression mechanism is a bit more informative than the old #<error
 printing object> marker for BACKTRACE, and DESCRIBE didn't really have
 anything before this.

 Also bind *PRINT-CIRCLE* to T for BACKTRACE, and use the PRINT-UNREADABLY
 restart for PRINT-NOT-READABLE errors.

diff --git a/NEWS b/NEWS
index 13dce89..5c384d4 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -15,6 +15,8 @@ changes relative to sbcl-1.0.54:
   * enhancement: SB-EXT:*SUPPRESS-PRINT-ERRORS* can be used to suppress errors
     from the printer by type, causing an error marker to be printed instead.
     (Thanks to Attila Lendvai)
+  * enhancement: BACKTRACE and DESCRIBE now bind *PRINT-CIRCLE* to T, and
+    generally behave better when errors occur during printing.
   * optimization: the compiler is smarter about representation selection for
     floating point constants used in full calls.
   * bug fix: deadlock detection could report the same deadlock twice, for

diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index 6791ac9..9852810 100644 (file)
--- a/src/code/debug.lisp
+++ b/src/code/debug.lisp
@@ -191,9 +191,14 @@ Other commands:
 In the debugger, the current frame is indicated by the prompt. COUNT
 is how many frames to show."
   (fresh-line stream)
-  (map-backtrace (lambda (frame)
-                   (print-frame-call frame stream :number t))
-                 :count count)
+  (let ((*suppress-print-errors* (if (subtypep 'serious-condition *suppress-print-errors*)
+                                     *suppress-print-errors*
+                                     'serious-condition))
+        (*print-circle* t))
+    (handler-bind ((print-not-readable #'print-unreadably))
+        (map-backtrace (lambda (frame)
+                         (print-frame-call frame stream :number t))
+                       :count count)))
   (fresh-line stream)
   (values))
 
@@ -413,21 +418,20 @@ thread, NIL otherwise."
           ;; For the function arguments, we can just print normally.
           (let ((*print-length* nil)
                 (*print-level* nil))
-            (prin1 (ensure-printable-object name) stream))
-          ;; If we hit a &REST arg, then print as many of the values as
-          ;; possible, punting the loop over lambda-list variables since any
-          ;; other arguments will be in the &REST arg's list of values.
-          (let ((print-args (ensure-printable-object args))
-                ;; Special case *PRINT-PRETTY* for eval frames: if
-                ;; *PRINT-LINES* is 1, turn off pretty-printing.
-                (*print-pretty*
-                 (if (and (eql 1 *print-lines*)
-                          (member name '(eval simple-eval-in-lexenv)))
-                     nil
-                     *print-pretty*)))
-            (if (listp print-args)
-                (format stream "~{ ~_~S~}" print-args)
-                (format stream " ~S" print-args))))
+            (prin1 name stream))
+          ;; If we hit a &REST arg, then print as many of the values
+          ;; as possible, punting the loop over lambda-list variables
+          ;; since any other arguments will be in the &REST arg's list
+          ;; of values. Special case *PRINT-PRETTY* for eval frames:
+          ;; if *PRINT-LINES* is 1, turn off pretty-printing.
+          (let ((*print-pretty*
+                  (if (and (eql 1 *print-lines*)
+                           (member name '(eval simple-eval-in-lexenv)))
+                      nil
+                      *print-pretty*))))
+          (if (listp args)
+              (format stream "~{ ~_~S~}" args)
+              (format stream " ~S" args)))
         (when kind
           (format stream "[~S]" kind))))
   (when (>= verbosity 2)

diff --git a/src/code/describe.lisp b/src/code/describe.lisp
index 504cc66..828227a 100644 (file)
--- a/src/code/describe.lisp
+++ b/src/code/describe.lisp
@@ -49,7 +49,12 @@
   #+sb-doc
   "Print a description of OBJECT to STREAM-DESIGNATOR."
   (let ((stream (out-synonym-of stream-designator))
-        (*print-right-margin* (or *print-right-margin* 72)))
+        (*print-right-margin* (or *print-right-margin* 72))
+        (*print-circle* t)
+        (*suppress-print-errors*
+          (if (subtypep 'serious-condition *suppress-print-errors*)
+              *suppress-print-errors*
+              'serious-condition)))
     ;; Until sbcl-0.8.0.x, we did
     ;;   (FRESH-LINE STREAM)
     ;;   (PPRINT-LOGICAL-BLOCK (STREAM NIL)
@@ -65,7 +70,8 @@
     ;; here. (The example method for DESCRIBE-OBJECT does its own
     ;; FRESH-LINEing, which is a physical directive which works poorly
     ;; inside a pretty-printer logical block.)
-    (describe-object object stream)
+    (handler-bind ((print-not-readable #'print-unreadably))
+      (describe-object object stream))
     ;; We don't TERPRI here either (any more since sbcl-0.8.0.x), because
     ;; again ANSI's specification of DESCRIBE doesn't mention it and
     ;; ANSI's example of DESCRIBE-OBJECT does its own final TERPRI.

diff --git a/tests/interface.impure.lisp b/tests/interface.impure.lisp
index ac4776a..613bc66 100644 (file)
--- a/tests/interface.impure.lisp
+++ b/tests/interface.impure.lisp
@@ -264,5 +264,33 @@
   (assert (equal "foo" (documentation 'bug-643958-test 'function)))
   (setf (documentation 'bug-643958-test 'function) "bar")
   (assert (equal "bar" (documentation 'bug-643958-test 'function))))
+
+(defclass cannot-print-this ()
+  ())
+(defmethod print-object ((oops cannot-print-this) stream)
+  (error "No go!"))
+(with-test (:name :describe-suppresses-print-errors)
+  (handler-bind ((error #'continue))
+    (with-output-to-string (s)
+      (describe (make-instance 'cannot-print-this) s))))
+(with-test (:name :backtrace-suppresses-print-errors)
+  (handler-bind ((error #'continue))
+    (with-output-to-string (s)
+      (labels ((foo (n x)
+                 (when (plusp n)
+                   (foo (1- n) x))
+                 (when (zerop n)
+                   (sb-debug:backtrace 100 s))))
+        (foo 100 (make-instance 'cannot-print-this))))))
+(with-test (:name :backtrace-and-circles)
+  (handler-bind ((error #'continue))
+    (with-output-to-string (s)
+      (labels ((foo (n x)
+                 (when (plusp n)
+                   (foo (1- n) x))
+                 (when (zerop n)
+                   (sb-debug:backtrace 100 s))))
+        (foo 100 (let ((list (list t)))
+                   (nconc list list)))))))
 \f
 ;;;; success