\f
;;;; support for the PRINT-UNREADABLE-OBJECT macro
+;;; guts of PRINT-UNREADABLE-OBJECT
(defun %print-unreadable-object (object stream type identity body)
(when *print-readably*
(error 'print-not-readable :object object))
- (write-string "#<" stream)
- (when type
- (write (type-of object) :stream stream :circle nil
- :level nil :length nil)
- (write-char #\space stream))
- (when body
- (funcall body))
- (when identity
- (unless (and type (null body))
- (write-char #\space stream))
- (write-char #\{ stream)
- (write (get-lisp-obj-address object) :stream stream
- :radix nil :base 16)
- (write-char #\} stream))
- (write-char #\> stream)
+ (flet ((print-description ()
+ (when type
+ (write (type-of object) :stream stream :circle nil
+ :level nil :length nil)
+ (when (or body identity)
+ (write-char #\space stream)
+ (pprint-newline :fill stream)))
+ (when body
+ (funcall body))
+ (when identity
+ (when body
+ (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
;;;; WHITESPACE-CHAR-P
;;; 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*))
(let ((length 0)
(list list))
(loop
- (punt-if-too-long length stream)
+ (punt-print-if-too-long length stream)
(output-object (pop list) stream)
(unless list
(return))
(defun output-vector (vector stream)
(declare (vector vector))
(cond ((stringp vector)
- (if (or *print-escape* *print-readably*)
- (quote-string vector stream)
- (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))
((bit-vector-p vector)
(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-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
+ (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
;; this for now. [noted by anonymous long ago] -- WHN 19991130
`(or (char= ,char #\\)
- (char= ,char #\"))))
- (write-char #\" stream)
+ (char= ,char #\"))))
(with-array-data ((data string) (start) (end (length string)))
(do ((index start (1+ index)))
((>= index end))
(let ((char (schar data index)))
(when (needs-slash-p char) (write-char #\\ stream))
- (write-char char stream))))
- (write-char #\" stream)))
+ (write-char char stream))))))
(defun output-array (array stream)
#!+sb-doc
(dotimes (i dimension)
(unless (zerop i)
(write-char #\space stream))
- (punt-if-too-long i stream)
+ (punt-print-if-too-long i stream)
(sub-output-array-guts array dimensions stream index)
(incf index count)))
(write-char #\) stream)))))
-;;; a trivial non-generic-function placeholder for PRINT-OBJECT, for use
-;;; until CLOS is set up (at which time it will be replaced with
+;;; a trivial non-generic-function placeholder for PRINT-OBJECT, for
+;;; use until CLOS is set up (at which time it will be replaced with
;;; the real generic function implementation)
(defun print-object (instance stream)
(default-structure-print instance stream *current-level*))
(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
-;;; 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)))
(write-string "#\\" stream)
(if name
- (write-string name stream)
+ (quote-string name stream)
(write-char char stream)))
(write-char char stream)))
projects / sbcl.git / blobdiff