From cc27e35fc73e6765679d6f426ee144abdfac7c27 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 29 Jun 2011 15:52:35 +0100 Subject: [PATCH] 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* "~@") + (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 -- 1.7.10.4