\f
;;;; support for the PRINT-UNREADABLE-OBJECT macro
-;;; MNA: cmucl-commit: Mon, 1 Jan 2001 01:30:53 -0800 (PST)
-;;; Correct the pretty printing by print-unreadable-object. Only attempt
-;;; to print pretty when the stream is a pretty-stream (and when *print-pretty*)
-;;; to ensure that all output goes to the same stream.
-
-;;; MNA: cmucl-commit: Wed, 27 Dec 2000 05:24:30 -0800 (PST)
-;;; Have print-unreadable-object respect *print-pretty*.
-
-;;; Guts of print-unreadable-object.
-;;;
-;;; When *print-pretty* and the stream is a pretty-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.
-;;;
+;;; guts of PRINT-UNREADABLE-OBJECT
(defun %print-unreadable-object (object stream type identity body)
(when *print-readably*
(error 'print-not-readable :object object))
(write (get-lisp-obj-address object) :stream stream
:radix nil :base 16)
(write-char #\} stream))))
- (cond ((and (sb!pretty:pretty-stream-p stream) *print-pretty*)
- (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
- (print-description)))
+ (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)
;;; character has. At characters have at least one bit set, so we can
;;; search for any character with a positive test.
(defvar *character-attributes*
- (make-array char-code-limit :element-type '(unsigned-byte 16)
+ (make-array char-code-limit
+ :element-type '(unsigned-byte 16)
:initial-element 0))
(declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit))
*character-attributes*))
(defun output-vector (vector stream)
(declare (vector vector))
(cond ((stringp vector)
- (cond ((or *print-escape* *print-readably*)
- (write-char #\" stream)
- (quote-string vector stream)
- (write-char #\" stream))
- (t
- (write-string vector stream))))
+ (cond ((or *print-escape* *print-readably*)
+ (write-char #\" stream)
+ (quote-string vector stream)
+ (write-char #\" stream))
+ (t
+ (write-string vector stream))))
((not (or *print-array* *print-readably*))
- (output-terse-array vector stream))
+ (output-terse-array vector stream))
((bit-vector-p vector)
- (write-string "#*" stream)
- (dotimes (i (length vector))
- (output-object (aref vector i) stream)))
+ (write-string "#*" stream)
+ (dotimes (i (length vector))
+ (output-object (aref vector i) stream)))
(t
- (when (and *print-readably*
- (not (eq (array-element-type vector) 't)))
- (error 'print-not-readable :object vector))
- (descend-into (stream)
- (write-string "#(" stream)
- (dotimes (i (length vector))
- (unless (zerop i)
- (write-char #\space stream))
- (punt-print-if-too-long i stream)
- (output-object (aref vector i) stream))
- (write-string ")" stream)))))
-
-;;; This function outputs a string quoting characters sufficiently that so
-;;; someone can read it in again. Basically, put a slash in front of an
-;;; character satisfying NEEDS-SLASH-P
+ (when (and *print-readably*
+ (not (eq (array-element-type vector) 't)))
+ (error 'print-not-readable :object vector))
+ (descend-into (stream)
+ (write-string "#(" stream)
+ (dotimes (i (length vector))
+ (unless (zerop i)
+ (write-char #\space stream))
+ (punt-print-if-too-long i stream)
+ (output-object (aref vector i) stream))
+ (write-string ")" stream)))))
+
+;;; This function outputs a string quoting characters sufficiently
+;;; that so someone can read it in again. Basically, put a slash in
+;;; front of an character satisfying NEEDS-SLASH-P.
(defun quote-string (string stream)
(macrolet ((needs-slash-p (char)
;; KLUDGE: We probably should look at the readtable, but just do
(long-float #\L))
plusp exp))))
-;;; Write out an infinity using #. notation, or flame out if
-;;; *print-readably* is true and *read-eval* is false.
-#!+sb-infinities
+;;; Write out an infinity using #. notation, or flame out if
+;;; *PRINT-READABLY* is true and *READ-EVAL* is false.
(defun output-float-infinity (x stream)
(declare (type float x) (type stream stream))
(cond (*read-eval*
\f
;;;; other leaf objects
-;;; MNA: cmucl-commit: Mon, 1 Jan 2001 03:41:18 -0800 (PST)
-;;; Fix output-character to escape the char-name. Reworking quote-string
-;;; to not write the delimiting quotes so that is can be used by
-;;; output-character.
-
-
-;;; If *PRINT-ESCAPE* is false, just do a WRITE-CHAR, otherwise output the
-;;; character name or the character in the #\char format.
+;;; If *PRINT-ESCAPE* is false, just do a WRITE-CHAR, otherwise output
+;;; the character name or the character in the #\char format.
(defun output-character (char stream)
(if (or *print-escape* *print-readably*)
(let ((name (char-name char)))
projects / sbcl.git / blobdiff