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.
"NAME-CONFLICT-DATUM" "NAME-CONFLICT-SYMBOLS"
"RESOLVE-CONFLICT"
"NAME-CONFLICT-DATUM" "NAME-CONFLICT-SYMBOLS"
"RESOLVE-CONFLICT"
;; and a mechanism for controlling same at compile time
"MUFFLE-CONDITIONS" "UNMUFFLE-CONDITIONS"
;; and a mechanism for controlling same at compile time
"MUFFLE-CONDITIONS" "UNMUFFLE-CONDITIONS"
"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"
"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
;; bootstrapping magic, to make things happen both in
;; the cross-compilation host compiler's environment and
(output-ugly-object array stream))
((and *print-readably*
(not (array-readably-printable-p array)))
(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
((vectorp array)
(pprint-vector stream array))
(t
\f
;;;; support for the PRINT-UNREADABLE-OBJECT macro
\f
;;;; 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*
;;; 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
(flet ((print-description ()
(when type
(write (type-of object) :stream stream :circle nil
(load-time-value
(array-element-type
(make-array 0 :element-type 'character))))))
(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)
((or *print-escape* *print-readably*)
(write-char #\" stream)
(quote-string vector stream)
(t
(when (and *print-readably*
(not (array-readably-printable-p vector)))
(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))
(descend-into (stream)
(write-string "#(" stream)
(dotimes (i (length vector))
(defun output-array-guts (array stream)
(when (and *print-readably*
(not (array-readably-printable-p array)))
(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))
(write-char #\# stream)
(let ((*print-base* 10)
(*print-radix* nil))
(cond (*read-eval*
(write-string "#." stream))
(*print-readably*
(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)
(t
(write-string "#<" stream)))
(write-string "SB-EXT:" stream)
(def!method print-object ((state random-state) stream)
(if (and *print-readably* (not *read-eval*))
(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
(format stream "#S(~S ~S #.~S)"
'random-state
':state