From 1463431b1efcc020533afeaa68d99dc70fb93f89 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 27 Nov 2011 14:23:35 +0200 Subject: [PATCH] refactor PRINT-NOT-READABLE condition signaling SB-INT:PRINT-NOT-READABLE-ERROR both signals the condition, and binds the restarts. --- package-data-list.lisp-expr | 1 + src/code/pprint.lisp | 11 +--- src/code/print.lisp | 128 +++++++++++++++++-------------------------- src/code/target-random.lisp | 10 +--- 4 files changed, 54 insertions(+), 96 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index be9c9ff..36cfd9a 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1034,6 +1034,7 @@ possibly temporariliy, because it might be used internally." "READ-EVALUATED-FORM" "MAKE-UNPRINTABLE-OBJECT" "POWER-OF-TWO-CEILING" + "PRINT-NOT-READABLE-ERROR" ;; ..and macros.. "COLLECT" diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index 08e25e9..ef17572 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -1007,16 +1007,7 @@ line break." (output-ugly-object array stream)) ((and *print-readably* (not (array-readably-printable-p 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)))) + (print-not-readable-error array stream)) ((vectorp array) (pprint-vector stream array)) (t diff --git a/src/code/print.lisp b/src/code/print.lisp index 924000b..ee80b94 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -308,51 +308,54 @@ ;;;; support for the PRINT-UNREADABLE-OBJECT macro -(defun read-unreadable-replacement () - (format *query-io* "~@") - (finish-output *query-io*) - (list (eval (read *query-io*)))) +(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 "~@")) + (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* - (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 - :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) ;;;; OUTPUT-OBJECT -- the main entry point @@ -954,16 +957,7 @@ (load-time-value (array-element-type (make-array 0 :element-type 'character)))))) - (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)))) + (print-not-readable-error vector stream)) ((or *print-escape* *print-readably*) (write-char #\" stream) (quote-string vector stream) @@ -981,14 +975,8 @@ (t (when (and *print-readably* (not (array-readably-printable-p 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))))) + (return-from output-vector + (print-not-readable-error vector stream))) (descend-into (stream) (write-string "#(" stream) (dotimes (i (length vector)) @@ -1040,14 +1028,8 @@ (defun output-array-guts (array stream) (when (and *print-readably* (not (array-readably-printable-p 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))))) + (return-from output-array-guts + (print-not-readable-error array stream))) (write-char #\# stream) (let ((*print-base* 10) (*print-radix* nil)) @@ -1596,16 +1578,8 @@ (cond (*read-eval* (write-string "#." stream)) (*print-readably* - (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)))) + (return-from output-float-infinity + (print-not-readable-error x 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 d4c98c3..57c57a7 100644 --- a/src/code/target-random.lisp +++ b/src/code/target-random.lisp @@ -42,15 +42,7 @@ (def!method print-object ((state random-state) stream) (if (and *print-readably* (not *read-eval*)) - (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))) + (print-not-readable-error state stream) (format stream "#S(~S ~S #.~S)" 'random-state ':state -- 1.7.10.4