From 026aef761bfe2e191fa38be357da233aacd6119e Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 4 Dec 2011 12:40:07 +0200 Subject: [PATCH] use *SUPPRESS-PRINT-ERRORS* for backtraces and DESCRIBE The suppression mechanism is a bit more informative than the old # 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. --- NEWS | 2 ++ src/code/debug.lisp | 40 ++++++++++++++++++++++------------------ src/code/describe.lisp | 10 ++++++++-- tests/interface.impure.lisp | 28 ++++++++++++++++++++++++++++ 4 files changed, 60 insertions(+), 20 deletions(-) diff --git a/NEWS b/NEWS index 13dce89..5c384d4 100644 --- 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 --- 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 --- 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 --- 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))))))) ;;;; success -- 1.7.10.4