From 171fde84561e232b8af8c05b82dfe8a8f9e08340 Mon Sep 17 00:00:00 2001 From: Attila Lendvai Date: Fri, 28 Jan 2011 16:09:47 +0100 Subject: [PATCH] add SB-EXT:*SUPPRESS-PRINT-ERRORS* modelled after *BREAK-ON-SIGNALS* When non-NIL, OUTPUT-OBJECT (our main entry to the printer) binds a handler that handles conditions of the specified type by printing an error marker instead of signaling an error. WRITE also accepts :SUPPRESS-ERRORS, and WITH-STANDARD-IO-SYNTAX binds it to NIL. Calls SIGNAL before handling the condition so outer handlers get a chance to use restarts, etc. --- NEWS | 3 ++ package-data-list.lisp-expr | 3 ++ src/code/print.lisp | 100 ++++++++++++++++++++++++++++++------------- 3 files changed, 77 insertions(+), 29 deletions(-) diff --git a/NEWS b/NEWS index 66949cc..13dce89 100644 --- a/NEWS +++ b/NEWS @@ -12,6 +12,9 @@ changes relative to sbcl-1.0.54: * enhancement: SB-EXT:PRINT-UNREADABLY restart for PRINT-NOT-READABLE conditions can be conveniently accessed through function with the same name, analogously to CONTINUE. + * 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) * 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/package-data-list.lisp-expr b/package-data-list.lisp-expr index 36cfd9a..79759bf 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -712,6 +712,9 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." ;; and one for controlling same at runtime "*MUFFLED-WARNINGS*" + ;; specification which print errors to ignore ala *break-on-signal* + "*SUPPRESS-PRINT-ERRORS*" + ;; extended declarations.. "ALWAYS-BOUND" "FREEZE-TYPE" "GLOBAL" "INHIBIT-WARNINGS" "MAYBE-INLINE" diff --git a/src/code/print.lisp b/src/code/print.lisp index ee80b94..ec2ad86 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -70,32 +70,39 @@ #!+sb-doc (setf (fdocumentation '*print-pprint-dispatch* 'variable) "The pprint-dispatch-table that controls how to pretty-print objects.") +(defvar *suppress-print-errors* nil + #!+sb-doc + "Suppress printer errors when the condition is of the type designated by this +variable: an unreadable object representing the error is printed instead.") (defmacro with-standard-io-syntax (&body body) #!+sb-doc "Bind the reader and printer control variables to values that enable READ to reliably read the results of PRINT. These values are: - *PACKAGE* the COMMON-LISP-USER package - *PRINT-ARRAY* T - *PRINT-BASE* 10 - *PRINT-CASE* :UPCASE - *PRINT-CIRCLE* NIL - *PRINT-ESCAPE* T - *PRINT-GENSYM* T - *PRINT-LENGTH* NIL - *PRINT-LEVEL* NIL - *PRINT-LINES* NIL - *PRINT-MISER-WIDTH* NIL - *PRINT-PPRINT-DISPATCH* the standard pprint dispatch table - *PRINT-PRETTY* NIL - *PRINT-RADIX* NIL - *PRINT-READABLY* T - *PRINT-RIGHT-MARGIN* NIL - *READ-BASE* 10 - *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT - *READ-EVAL* T - *READ-SUPPRESS* NIL - *READTABLE* the standard readtable" + + *PACKAGE* the COMMON-LISP-USER package + *PRINT-ARRAY* T + *PRINT-BASE* 10 + *PRINT-CASE* :UPCASE + *PRINT-CIRCLE* NIL + *PRINT-ESCAPE* T + *PRINT-GENSYM* T + *PRINT-LENGTH* NIL + *PRINT-LEVEL* NIL + *PRINT-LINES* NIL + *PRINT-MISER-WIDTH* NIL + *PRINT-PPRINT-DISPATCH* the standard pprint dispatch table + *PRINT-PRETTY* NIL + *PRINT-RADIX* NIL + *PRINT-READABLY* T + *PRINT-RIGHT-MARGIN* NIL + *READ-BASE* 10 + *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT + *READ-EVAL* T + *READ-SUPPRESS* NIL + *READTABLE* the standard readtable + SB-EXT:*SUPPRESS-PRINT-ERRORS* NIL +" `(%with-standard-io-syntax (lambda () ,@body))) (defun %with-standard-io-syntax (function) @@ -120,7 +127,8 @@ (*read-default-float-format* 'single-float) (*read-eval* t) (*read-suppress* nil) - (*readtable* *standard-readtable*)) + (*readtable* *standard-readtable*) + (*suppress-print-errors* nil)) (funcall function))) ;;;; routines to print objects @@ -144,7 +152,8 @@ :right-margin *print-right-margin* :miser-width *print-miser-width* :lines *print-lines* - :pprint-dispatch *print-pprint-dispatch*))) + :pprint-dispatch *print-pprint-dispatch* + :suppress-errors *suppress-print-errors*))) (defun write (object &key ((:stream stream) *standard-output*) @@ -165,7 +174,9 @@ *print-miser-width*) ((:lines *print-lines*) *print-lines*) ((:pprint-dispatch *print-pprint-dispatch*) - *print-pprint-dispatch*)) + *print-pprint-dispatch*) + ((:suppress-errors *suppress-print-errors*) + *suppress-print-errors*)) #!+sb-doc "Output OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*." (output-object object (out-synonym-of stream)) @@ -253,7 +264,9 @@ ((:miser-width *print-miser-width*) *print-miser-width*) ((:lines *print-lines*) *print-lines*) ((:pprint-dispatch *print-pprint-dispatch*) - *print-pprint-dispatch*)) + *print-pprint-dispatch*) + ((:suppress-errors *suppress-print-errors*) + *suppress-print-errors*)) #!+sb-doc "Return the printed representation of OBJECT as a string." (stringify-object object)) @@ -368,12 +381,41 @@ (and (symbolp x) (symbol-package x)))) +(defvar *in-print-error* nil) + ;;; Output OBJECT to STREAM observing all printer control variables. (defun output-object (object stream) (labels ((print-it (stream) (if *print-pretty* (sb!pretty:output-pretty-object object stream) (output-ugly-object object stream))) + (handle-it (stream) + (if *suppress-print-errors* + (handler-bind ((condition + (lambda (condition) nil + (when (typep condition *suppress-print-errors*) + (cond (*in-print-error* + (write-string "(error printing " stream) + (write-string *in-print-error* stream) + (write-string ")" stream)) + (t + ;; Give outer handlers a chance. + (with-simple-restart + (continue "Suppress the error.") + (signal condition)) + (let ((*print-readably* nil) + (*print-escape* t)) + (write-string + "#" stream)))) + (return-from handle-it object))))) + (print-it stream)) + (print-it stream))) (check-it (stream) (multiple-value-bind (marker initiate) (check-for-circularity object t) @@ -386,12 +428,12 @@ ;; otherwise (if marker (when (handle-circularity marker stream) - (print-it stream)) - (print-it stream)))))) + (handle-it stream)) + (handle-it stream)))))) (cond (;; Maybe we don't need to bother with circularity detection. (or (not *print-circle*) (uniquely-identified-by-print-p object)) - (print-it stream)) + (handle-it stream)) (;; If we have already started circularity detection, this ;; object might be a shared reference. If we have not, then ;; if it is a compound object it might contain a circular @@ -400,7 +442,7 @@ (compound-object-p object)) (check-it stream)) (t - (print-it stream))))) + (handle-it stream))))) ;;; a hack to work around recurring gotchas with printing while ;;; DEFGENERIC PRINT-OBJECT is being built -- 1.7.10.4