X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=f17f4f6cfc9b55169358399114e45fe47cef0924;hb=f575ddaffe838c611359430946fe26b80808a35a;hp=50de743125f7f360da20262476ec3006780d11af;hpb=58187b3f2ab87bce54657c9c94ac2b3090103ba1;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index 50de743..f17f4f6 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -70,32 +70,39 @@ #!+sb-doc (setf (fdocumentation '*print-pprint-dispatch* 'variable) "The pprint-dispatch-table that controls how to pretty-print objects.") +(defvar *suppress-print-errors* nil + #!+sb-doc + "Suppress printer errors when the condition is of the type designated by this +variable: an unreadable object representing the error is printed instead.") (defmacro with-standard-io-syntax (&body body) #!+sb-doc "Bind the reader and printer control variables to values that enable READ to reliably read the results of PRINT. These values are: - *PACKAGE* the COMMON-LISP-USER package - *PRINT-ARRAY* T - *PRINT-BASE* 10 - *PRINT-CASE* :UPCASE - *PRINT-CIRCLE* NIL - *PRINT-ESCAPE* T - *PRINT-GENSYM* T - *PRINT-LENGTH* NIL - *PRINT-LEVEL* NIL - *PRINT-LINES* NIL - *PRINT-MISER-WIDTH* NIL - *PRINT-PPRINT-DISPATCH* the standard pprint dispatch table - *PRINT-PRETTY* NIL - *PRINT-RADIX* NIL - *PRINT-READABLY* T - *PRINT-RIGHT-MARGIN* NIL - *READ-BASE* 10 - *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT - *READ-EVAL* T - *READ-SUPPRESS* NIL - *READTABLE* the standard readtable" + + *PACKAGE* the COMMON-LISP-USER package + *PRINT-ARRAY* T + *PRINT-BASE* 10 + *PRINT-CASE* :UPCASE + *PRINT-CIRCLE* NIL + *PRINT-ESCAPE* T + *PRINT-GENSYM* T + *PRINT-LENGTH* NIL + *PRINT-LEVEL* NIL + *PRINT-LINES* NIL + *PRINT-MISER-WIDTH* NIL + *PRINT-PPRINT-DISPATCH* the standard pprint dispatch table + *PRINT-PRETTY* NIL + *PRINT-RADIX* NIL + *PRINT-READABLY* T + *PRINT-RIGHT-MARGIN* NIL + *READ-BASE* 10 + *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT + *READ-EVAL* T + *READ-SUPPRESS* NIL + *READTABLE* the standard readtable + SB-EXT:*SUPPRESS-PRINT-ERRORS* NIL +" `(%with-standard-io-syntax (lambda () ,@body))) (defun %with-standard-io-syntax (function) @@ -120,7 +127,8 @@ (*read-default-float-format* 'single-float) (*read-eval* t) (*read-suppress* nil) - (*readtable* *standard-readtable*)) + (*readtable* *standard-readtable*) + (*suppress-print-errors* nil)) (funcall function))) ;;;; routines to print objects @@ -144,7 +152,8 @@ :right-margin *print-right-margin* :miser-width *print-miser-width* :lines *print-lines* - :pprint-dispatch *print-pprint-dispatch*))) + :pprint-dispatch *print-pprint-dispatch* + :suppress-errors *suppress-print-errors*))) (defun write (object &key ((:stream stream) *standard-output*) @@ -165,7 +174,9 @@ *print-miser-width*) ((:lines *print-lines*) *print-lines*) ((:pprint-dispatch *print-pprint-dispatch*) - *print-pprint-dispatch*)) + *print-pprint-dispatch*) + ((:suppress-errors *suppress-print-errors*) + *suppress-print-errors*)) #!+sb-doc "Output OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*." (output-object object (out-synonym-of stream)) @@ -253,7 +264,9 @@ ((:miser-width *print-miser-width*) *print-miser-width*) ((:lines *print-lines*) *print-lines*) ((:pprint-dispatch *print-pprint-dispatch*) - *print-pprint-dispatch*)) + *print-pprint-dispatch*) + ((:suppress-errors *suppress-print-errors*) + *suppress-print-errors*)) #!+sb-doc "Return the printed representation of OBJECT as a string." (stringify-object object)) @@ -308,38 +321,54 @@ ;;;; 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 "~@")) + (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) ;;;; OUTPUT-OBJECT -- the main entry point @@ -352,12 +381,41 @@ (and (symbolp x) (symbol-package x)))) +(defvar *in-print-error* nil) + ;;; Output OBJECT to STREAM observing all printer control variables. (defun output-object (object stream) (labels ((print-it (stream) (if *print-pretty* (sb!pretty:output-pretty-object object stream) (output-ugly-object object stream))) + (handle-it (stream) + (if *suppress-print-errors* + (handler-bind ((condition + (lambda (condition) nil + (when (typep condition *suppress-print-errors*) + (cond (*in-print-error* + (write-string "(error printing " stream) + (write-string *in-print-error* stream) + (write-string ")" stream)) + (t + ;; Give outer handlers a chance. + (with-simple-restart + (continue "Suppress the error.") + (signal condition)) + (let ((*print-readably* nil) + (*print-escape* t)) + (write-string + "#" stream)))) + (return-from handle-it object))))) + (print-it stream)) + (print-it stream))) (check-it (stream) (multiple-value-bind (marker initiate) (check-for-circularity object t) @@ -370,12 +428,12 @@ ;; otherwise (if marker (when (handle-circularity marker stream) - (print-it stream)) - (print-it stream)))))) + (handle-it stream)) + (handle-it stream)))))) (cond (;; Maybe we don't need to bother with circularity detection. (or (not *print-circle*) (uniquely-identified-by-print-p object)) - (print-it stream)) + (handle-it stream)) (;; If we have already started circularity detection, this ;; object might be a shared reference. If we have not, then ;; if it is a compound object it might contain a circular @@ -384,7 +442,7 @@ (compound-object-p object)) (check-it stream)) (t - (print-it stream))))) + (handle-it stream))))) ;;; a hack to work around recurring gotchas with printing while ;;; DEFGENERIC PRINT-OBJECT is being built @@ -526,7 +584,8 @@ (defun output-symbol (object stream) (if (or *print-escape* *print-readably*) (let ((package (symbol-package object)) - (name (symbol-name object))) + (name (symbol-name object)) + (current (sane-package))) (cond ;; The ANSI spec "22.1.3.3.1 Package Prefixes for Symbols" ;; requires that keywords be printed with preceding colons @@ -535,19 +594,24 @@ (write-char #\: stream)) ;; Otherwise, if the symbol's home package is the current ;; one, then a prefix is never necessary. - ((eq package (sane-package))) + ((eq package current)) ;; Uninterned symbols print with a leading #:. ((null package) (when (or *print-gensym* *print-readably*) (write-string "#:" stream))) (t (multiple-value-bind (symbol accessible) - (find-symbol name (sane-package)) + (find-symbol name current) ;; If we can find the symbol by looking it up, it need not ;; be qualified. This can happen if the symbol has been ;; inherited from a package other than its home package. + ;; + ;; To preserve read/print consistency, use the local nickname if + ;; one exists. (unless (and accessible (eq symbol object)) - (output-symbol-name (package-name package) stream) + (let ((prefix (or (car (rassoc package (package-%local-nicknames current))) + (package-name package)))) + (output-symbol-name prefix stream)) (multiple-value-bind (symbol externalp) (find-external-symbol name package) (declare (ignore symbol)) @@ -933,6 +997,13 @@ (incf length))) (write-char #\) stream))) +(defun output-unreadable-vector-readably (vector stream) + (declare (vector vector)) + (write-string "#." stream) + (write `(coerce ,(coerce vector '(vector t)) + '(simple-array ,(array-element-type vector) (*))) + :stream stream)) + (defun output-vector (vector stream) (declare (vector vector)) (cond ((stringp vector) @@ -941,7 +1012,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) @@ -956,10 +1027,8 @@ ;; (Don't use OUTPUT-OBJECT here, since this code ;; has to work for all possible *PRINT-BASE* values.) (write-char (if (zerop bit) #\0 #\1) stream))) - (t - (when (and *print-readably* - (not (array-readably-printable-p vector))) - (error 'print-not-readable :object vector)) + ((or (not *print-readably*) + (array-readably-printable-p vector)) (descend-into (stream) (write-string "#(" stream) (dotimes (i (length vector)) @@ -967,7 +1036,11 @@ (write-char #\space stream)) (punt-print-if-too-long i stream) (output-object (aref vector i) stream)) - (write-string ")" stream))))) + (write-string ")" stream))) + (*read-eval* + (output-unreadable-vector-readably vector stream)) + (t + (print-not-readable-error vector stream)))) ;;; This function outputs a string quoting characters sufficiently ;;; so that someone can read it in again. Basically, put a slash in @@ -1007,19 +1080,45 @@ (*print-length* nil)) (print-unreadable-object (array stream :type t :identity t)))) -;;; Output the readable #A form of an array. -(defun output-array-guts (array stream) - (when (and *print-readably* - (not (array-readably-printable-p array))) - (error 'print-not-readable :object array)) - (write-char #\# stream) - (let ((*print-base* 10) - (*print-radix* nil)) - (output-integer (array-rank array) stream)) - (write-char #\A stream) +;;; Convert an array into a list that can be used with MAKE-ARRAY's +;;; :INITIAL-CONTENTS keyword argument. +(defun listify-array (array) (with-array-data ((data array) (start) (end)) (declare (ignore end)) - (sub-output-array-guts data (array-dimensions array) stream start))) + (labels ((listify (dimensions index) + (if (null dimensions) + (aref data index) + (let* ((dimension (car dimensions)) + (dimensions (cdr dimensions)) + (count (reduce #'* dimensions))) + (loop for i below dimension + collect (listify dimensions index) + do (incf index count)))))) + (listify (array-dimensions array) start)))) + +(defun output-unreadable-array-readably (array stream) + (write-string "#." stream) + (write `(make-array ',(array-dimensions array) + :element-type ',(array-element-type array) + :initial-contents ',(listify-array array)) + :stream stream)) + +;;; Output the readable #A form of an array. +(defun output-array-guts (array stream) + (cond ((or (not *print-readably*) + (array-readably-printable-p array)) + (write-char #\# stream) + (let ((*print-base* 10) + (*print-radix* nil)) + (output-integer (array-rank array) stream)) + (write-char #\A stream) + (with-array-data ((data array) (start) (end)) + (declare (ignore end)) + (sub-output-array-guts data (array-dimensions array) stream start))) + (*read-eval* + (output-unreadable-array-readably array stream)) + (t + (print-not-readable-error array stream)))) (defun sub-output-array-guts (array dimensions stream index) (declare (type (simple-array * (*)) array) (fixnum index)) @@ -1297,7 +1396,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 +1416,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 +1659,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 +1789,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)))) ;;;; catch-all for unknown things