[Sbcl-commits] master: restarts for PRINT-NOT-READABLE errors

[Christophe R. <cr...@us...>]

The branch "master" has been updated in SBCL:
       via  cc27e35fc73e6765679d6f426ee144abdfac7c27 (commit)
      from  d9479b4b4ca343e06886902d3a43eaf5a238fb9b (commit)

- Log -----------------------------------------------------------------
commit cc27e35fc73e6765679d6f426ee144abdfac7c27
Author: Christophe Rhodes <cs...@ca...>
Date:   Wed Jun 29 15:52:35 2011 +0100

    restarts for PRINT-NOT-READABLE errors
    
    Two restarts: USE-VALUE, to provide a value to be printed instead
    (under the same printer control variable bindings), and
    SB-EXT:PRINT-UNDREADABLY, printing the same object but with
    *PRINT-READABLY* bound to NIL.  Only minimally tested, but should
    meet requirements for lp#801255.
---
 package-data-list.lisp-expr |    4 +++
 src/code/pprint.lisp        |   12 ++++++++-
 src/code/print.lisp         |   55 +++++++++++++++++++++++++++++++++++++++----
 src/code/target-random.lisp |   10 +++++++-
 4 files changed, 73 insertions(+), 8 deletions(-)

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 51ba784..348bd69 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -688,6 +688,8 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
                "NAME-CONFLICT-DATUM" "NAME-CONFLICT-SYMBOLS"
                "RESOLVE-CONFLICT"
 
+               "PRINT-UNREADABLY"
+
                ;; and a mechanism for controlling same at compile time
                "MUFFLE-CONDITIONS" "UNMUFFLE-CONDITIONS"
 
@@ -961,6 +963,8 @@ possibly temporariliy, because it might be used internally."
                "C-STRING-ENCODING-ERROR" "C-STRING-ENCODING-ERROR-EXTERNAL-FORMAT"
                "C-STRING-DECODING-ERROR" "C-STRING-DECODING-ERROR-EXTERNAL-FORMAT"
                "ATTEMPT-RESYNC" "FORCE-END-OF-FILE"
+               "READ-UNREADABLE-REPLACEMENT"
+
 
                ;; bootstrapping magic, to make things happen both in
                ;; the cross-compilation host compiler's environment and
diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp
index c0ab247..c8e2301 100644
--- a/src/code/pprint.lisp
+++ b/src/code/pprint.lisp
@@ -1009,8 +1009,16 @@ line break."
          (output-ugly-object array stream))
         ((and *print-readably*
               (not (array-readably-printable-p array)))
-         (let ((*print-readably* nil))
-           (error 'print-not-readable :object array)))
+         (restart-case
+             (error 'print-not-readable :object array)
+           (print-unreadably ()
+             :report "Print unreadably."
+             (let ((*print-readably* nil))
+               (pprint-array stream array)))
+           (use-value (o)
+             :report "Supply an object to be printed instead."
+             :interactive read-unreadable-replacement
+             (write o :stream stream))))
         ((vectorp array)
          (pprint-vector stream array))
         (t
diff --git a/src/code/print.lisp b/src/code/print.lisp
index 50de743..a52648a 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -308,11 +308,24 @@
 
 ;;;; support for the PRINT-UNREADABLE-OBJECT macro
 
+(defun read-unreadable-replacement ()
+  (format *query-io* "~@<Enter an object (evaluated): ~@:>")
+  (finish-output *query-io*)
+  (list (eval (read *query-io*))))
+
 ;;; guts of PRINT-UNREADABLE-OBJECT
 (defun %print-unreadable-object (object stream type identity body)
   (declare (type (or null function) body))
   (when *print-readably*
-    (error 'print-not-readable :object object))
+    (restart-case
+        (error 'print-not-readable :object object)
+      (print-unreadably ()
+        :report "Print unreadably.")
+      (use-value (o)
+        :report "Supply an object to be printed instead."
+        :interactive read-unreadable-replacement
+        (write o :stream stream)
+        (return-from %print-unreadable-object nil))))
   (flet ((print-description ()
            (when type
              (write (type-of object) :stream stream :circle nil
@@ -941,7 +954,16 @@
                               (load-time-value
                                (array-element-type
                                 (make-array 0 :element-type 'character))))))
-                (error 'print-not-readable :object vector))
+                (restart-case
+                    (error 'print-not-readable :object vector)
+                  (print-unreadably ()
+                    :report "Print unreadably."
+                    (let ((*print-readably* nil))
+                      (output-vector vector stream)))
+                  (use-value (o)
+                    :report "Supply an object to be printed instead."
+                    :interactive read-unreadable-replacement
+                    (write o :stream stream))))
                ((or *print-escape* *print-readably*)
                 (write-char #\" stream)
                 (quote-string vector stream)
@@ -959,7 +981,14 @@
         (t
          (when (and *print-readably*
                     (not (array-readably-printable-p vector)))
-           (error 'print-not-readable :object vector))
+           (restart-case
+               (error 'print-not-readable :object vector)
+             (print-unreadably ()
+               :report "Print unreadably.")
+             (use-value (o)
+               :report "Supply an object to be printed instead."
+               :interactive read-unreadable-replacement
+               (return-from output-vector (write o :stream stream)))))
          (descend-into (stream)
                        (write-string "#(" stream)
                        (dotimes (i (length vector))
@@ -1011,7 +1040,14 @@
 (defun output-array-guts (array stream)
   (when (and *print-readably*
              (not (array-readably-printable-p array)))
-    (error 'print-not-readable :object array))
+    (restart-case
+        (error 'print-not-readable :object array)
+      (print-unreadably ()
+        :report "Print unreadably.")
+      (use-value (o)
+        :report "Supply an object to be printed instead."
+        :interactive read-unreadable-replacement
+        (return-from output-array-guts (write o :stream stream)))))
   (write-char #\# stream)
   (let ((*print-base* 10)
         (*print-radix* nil))
@@ -1555,7 +1591,16 @@
   (cond (*read-eval*
          (write-string "#." stream))
         (*print-readably*
-         (error 'print-not-readable :object x))
+         (restart-case
+             (error 'print-not-readable :object x)
+           (print-unreadably ()
+             :report "Print unreadably."
+             (let ((*print-readably* nil))
+               (output-float-infinity x stream)))
+           (use-value (o)
+             :report "Supply an object to be printed instead."
+             :interactive read-unreadable-replacement
+             (write o :stream stream))))
         (t
          (write-string "#<" stream)))
   (write-string "SB-EXT:" stream)
diff --git a/src/code/target-random.lisp b/src/code/target-random.lisp
index 2f7d1a6..d4c98c3 100644
--- a/src/code/target-random.lisp
+++ b/src/code/target-random.lisp
@@ -42,7 +42,15 @@
 
 (def!method print-object ((state random-state) stream)
   (if (and *print-readably* (not *read-eval*))
-      (error 'print-not-readable :object state)
+      (restart-case
+          (error 'print-not-readable :object state)
+        (print-unreadably ()
+          :report "Print unreadably."
+          (write state :stream stream :readably nil))
+        (use-value (object)
+          :report "Supply an object to be printed instead."
+          :interactive read-unreadable-replacement
+          (write object :stream stream)))
       (format stream "#S(~S ~S #.~S)"
               'random-state
               ':state

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL