#!+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)
(*read-default-float-format* 'single-float)
(*read-eval* t)
(*read-suppress* nil)
- (*readtable* *standard-readtable*))
+ (*readtable* *standard-readtable*)
+ (*suppress-print-errors* nil))
(funcall function)))
\f
;;;; routines to print objects
: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*)
*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))
((: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))
(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
+ "#<error printing a " stream)
+ (let ((*in-print-error* "type"))
+ (output-object (type-of object) stream))
+ (write-string ": " stream)
+ (let ((*in-print-error* "condition"))
+ (output-object condition stream))
+ (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)
;; 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
(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
(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
(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))
(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)
;; (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)))
- (return-from output-vector
- (print-not-readable-error vector stream)))
+ ((or (not *print-readably*)
+ (array-readably-printable-p vector))
(descend-into (stream)
(write-string "#(" stream)
(dotimes (i (length vector))
(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
(*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)))
- (return-from output-array-guts
- (print-not-readable-error array stream)))
- (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))
projects / sbcl.git / blobdiff