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.

diff --git a/NEWS b/NEWS
index 66949cc..13dce89 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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)))
 \f
 ;;;; 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
+                                                "#<error printing a " stream)
+                                               (let ((*in-print-error* "type"))
+                                                 (output-object (type-of object) stream))
+                                               (write-string ": " stream)
+                                               (let ((*in-print-error* "condition"))
+                                                 (output-object condition stream))
+                                               (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