\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*
- (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
(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)
(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))
(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))
(values-list w))
(t (values-list f))))
(flonum-to-digits x)))
- (let ((e (+ e (or scale 0)))
+ (let ((e (if (zerop x)
+ e
+ (+ e (or scale 0))))
(stream (make-string-output-stream)))
(if (plusp e)
(progn
(write-string "." stream)
(dotimes (i (- e))
(write-char #\0 stream))
- (write-string string stream)
+ (write-string string stream :end (when fdigits
+ (min (length string)
+ (max (or fmin 0)
+ (+ fdigits e)))))
(when fdigits
(dotimes (i (+ fdigits e (- (length string))))
(write-char #\0 stream)))))
(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)