X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=b0a4e72b31441a6dc4a17f10ec1c425a3a120f86;hb=6caf3ed5713773cb423f46bf40a29f2438c97c78;hp=50de743125f7f360da20262476ec3006780d11af;hpb=58187b3f2ab87bce54657c9c94ac2b3090103ba1;p=sbcl.git

diff --git a/src/code/print.lisp b/src/code/print.lisp
index 50de743..b0a4e72 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))
@@ -1297,7 +1333,9 @@
                    (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
@@ -1315,7 +1353,10 @@
             (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)))))
@@ -1555,7 +1596,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)