X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=53507ee16007bbe2d09bb79f859c3ab84bfe7fa3;hb=2d0b882f9eabffe5e2d32c0e2e7ab06c96f4fea3;hp=4f3c28a1b97e6411e2a89aa6ad783891e1cd449b;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index 4f3c28a..53507ee 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -10,9 +10,6 @@ ;;;; files for more information. (in-package "SB!IMPL") - -(file-comment - "$Header$") ;;;; exported printer control variables @@ -239,24 +236,38 @@ ;;;; 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) ;;;; WHITESPACE-CHAR-P @@ -559,13 +570,14 @@ (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. @@ -600,13 +612,12 @@ ;;; 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*)) -(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. @@ -618,9 +629,11 @@ (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) @@ -691,9 +704,10 @@ (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 () @@ -926,7 +940,7 @@ (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)) @@ -941,9 +955,12 @@ (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) @@ -955,31 +972,29 @@ (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 @@ -1021,13 +1036,13 @@ (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*)) @@ -1036,8 +1051,8 @@ (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*)) @@ -1423,9 +1438,8 @@ (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* @@ -1490,14 +1504,14 @@ ;;;; 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)))