\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
(write-char #\: stream))
;; Otherwise, if the symbol's home package is the current
;; one, then a prefix is never necessary.
- ((eq package *package*))
+ ((eq package (sane-package)))
;; 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 *package*)
+ (multiple-value-bind (symbol accessible)
+ (find-symbol name (sane-package))
;; 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.
(declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit))
*character-attributes*))
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
;;; Constants which are a bit-mask for each interesting character attribute.
(defconstant other-attribute (ash 1 0)) ; Anything else legal.
(defconstant number-attribute (ash 1 1)) ; A numeric digit.
(defconstant slash-attribute (ash 1 7)) ; /
(defconstant funny-attribute (ash 1 8)) ; Anything illegal.
-;;; LETTER-ATTRIBUTE is a local of SYMBOL-QUOTEP. It matches letters that
-;;; don't need to be escaped (according to READTABLE-CASE.)
-(defconstant attribute-names
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+;;; LETTER-ATTRIBUTE is a local of SYMBOL-QUOTEP. It matches letters
+;;; that don't need to be escaped (according to READTABLE-CASE.)
+(defparameter *attribute-names*
`((number . number-attribute) (lowercase . lowercase-attribute)
(uppercase . uppercase-attribute) (letter . letter-attribute)
(sign . sign-attribute) (extension . extension-attribute)
(the fixnum
(logand
(logior ,@(mapcar
- #'(lambda (x)
- (or (cdr (assoc x attribute-names))
- (error "Blast!")))
+ (lambda (x)
+ (or (cdr (assoc x
+ *attribute-names*))
+ (error "Blast!")))
attributes))
bits)))))
(digitp ()
(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))
+ (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-if-too-long i stream)
- (output-object (aref vector i) stream))
- (write-string ")" stream)))))
+ (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
;; 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*))
(defun output-integer (integer stream)
;; FIXME: This UNLESS form should be pulled out into something like
- ;; GET-REASONABLE-PRINT-BASE, along the lines of GET-REASONABLE-PACKAGE
- ;; for the *PACKAGE* variable.
+ ;; (SANE-PRINT-BASE), along the lines of (SANE-PACKAGE) for the
+ ;; *PACKAGE* variable.
(unless (and (fixnump *print-base*)
(< 1 *print-base* 37))
(let ((obase *print-base*))
\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