refactor PRINT-NOT-READABLE condition signaling

[sbcl.git] / src / code / print.lisp

diff --git a/src/code/print.lisp b/src/code/print.lisp
index 50de743..ee80b94 100644 (file)
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -308,38 +308,54 @@
 \f
 ;;;; support for the PRINT-UNREADABLE-OBJECT macro
 
+(defun print-not-readable-error (object stream)
+  (restart-case
+      (error 'print-not-readable :object object)
+    (print-unreadably ()
+      :report "Print unreadably."
+      (let ((*print-readably* nil))
+        (output-object object stream)
+        object))
+    (use-value (o)
+      :report "Supply an object to be printed instead."
+      :interactive
+      (lambda ()
+        (read-evaluated-form "~@<Enter an object (evaluated): ~@:>"))
+      (output-object o stream)
+      o)))
+
 ;;; 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))
-  (flet ((print-description ()
-           (when type
-             (write (type-of object) :stream stream :circle nil
-                    :level nil :length nil)
-             (write-char #\space stream)
-             (pprint-newline :fill stream))
-           (when body
-             (funcall body))
-           (when identity
-             (when (or body (not type))
-               (write-char #\space stream))
-             (pprint-newline :fill stream)
-             (write-char #\{ stream)
-             (write (get-lisp-obj-address object) :stream stream
-                    :radix nil :base 16)
-             (write-char #\} stream))))
-    (cond ((print-pretty-on-stream-p stream)
-           ;; Since we're printing prettily on STREAM, format the
-           ;; object within a logical block. PPRINT-LOGICAL-BLOCK does
-           ;; not rebind the stream when it is already a pretty stream,
-           ;; so output from the body will go to the same stream.
-           (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
-             (print-description)))
-          (t
-           (write-string "#<" stream)
-           (print-description)
-           (write-char #\> stream))))
+  (if *print-readably*
+      (print-not-readable-error object stream)
+      (flet ((print-description ()
+               (when type
+                 (write (type-of object) :stream stream :circle nil
+                                         :level nil :length nil)
+                 (write-char #\space stream)
+                 (pprint-newline :fill stream))
+               (when body
+                 (funcall body))
+               (when identity
+                 (when (or body (not type))
+                   (write-char #\space stream))
+                 (pprint-newline :fill stream)
+                 (write-char #\{ stream)
+                 (write (get-lisp-obj-address object) :stream stream
+                                                      :radix nil :base 16)
+                 (write-char #\} stream))))
+        (cond ((print-pretty-on-stream-p stream)
+               ;; Since we're printing prettily on STREAM, format the
+               ;; object within a logical block. PPRINT-LOGICAL-BLOCK does
+               ;; not rebind the stream when it is already a pretty stream,
+               ;; so output from the body will go to the same stream.
+               (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
+                 (print-description)))
+              (t
+               (write-string "#<" stream)
+               (print-description)
+               (write-char #\> stream)))))
   nil)
 \f
 ;;;; OUTPUT-OBJECT -- the main entry point
@@ -941,7 +957,7 @@
                               (load-time-value
                                (array-element-type
                                 (make-array 0 :element-type 'character))))))
-                (error 'print-not-readable :object vector))
+                (print-not-readable-error vector stream))
                ((or *print-escape* *print-readably*)
                 (write-char #\" stream)
                 (quote-string vector stream)
@@ -959,7 +975,8 @@
         (t
          (when (and *print-readably*
                     (not (array-readably-printable-p vector)))
-           (error 'print-not-readable :object vector))
+           (return-from output-vector
+             (print-not-readable-error vector stream)))
          (descend-into (stream)
                        (write-string "#(" stream)
                        (dotimes (i (length vector))
@@ -1011,7 +1028,8 @@
 (defun output-array-guts (array stream)
   (when (and *print-readably*
              (not (array-readably-printable-p array)))
-    (error 'print-not-readable :object array))
+    (return-from output-array-guts
+      (print-not-readable-error array stream)))
   (write-char #\# stream)
   (let ((*print-base* 10)
         (*print-radix* nil))
@@ -1297,7 +1315,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 +1335,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 +1578,8 @@
   (cond (*read-eval*
          (write-string "#." stream))
         (*print-readably*
-         (error 'print-not-readable :object x))
+         (return-from output-float-infinity
+           (print-not-readable-error x stream)))
         (t
          (write-string "#<" stream)))
   (write-string "SB-EXT:" stream)
@@ -1684,15 +1708,15 @@
   nil)
 
 (defun output-fun (object stream)
-    (let* ((*print-length* 3)  ; in case we have to..
-           (*print-level* 3)  ; ..print an interpreted function definition
-           (name (%fun-name object))
-           (proper-name-p (and (legal-fun-name-p name) (fboundp name)
-                               (eq (fdefinition name) object))))
-      (print-unreadable-object (object stream :identity (not proper-name-p))
-        (format stream "~:[FUNCTION~;CLOSURE~]~@[ ~S~]"
-                (closurep object)
-                name))))
+  (let* ((*print-length* 4)  ; in case we have to..
+         (*print-level* 3)  ; ..print an interpreted function definition
+         (name (%fun-name object))
+         (proper-name-p (and (legal-fun-name-p name) (fboundp name)
+                             (eq (fdefinition name) object))))
+    (print-unreadable-object (object stream :identity (not proper-name-p))
+      (format stream "~:[FUNCTION~;CLOSURE~]~@[ ~S~]"
+              (closurep object)
+              name))))
 \f
 ;;;; catch-all for unknown things