X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcode%2Fprint.lisp;h=3a5207253611097272f7902a87d722789036bc6c;hb=4f64f131a7bca59d0dc8be9e74d05a7645f27e67;hp=0c19b98c6c4c1aba408a6ec745285a149c62efdc;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index 0c19b98..3a52072 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -236,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 @@ -556,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. @@ -602,8 +617,6 @@ (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. @@ -615,9 +628,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) @@ -688,9 +703,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 () @@ -923,7 +939,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)) @@ -938,27 +954,30 @@ (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 @@ -968,15 +987,13 @@ ;; 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 @@ -1018,13 +1035,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*)) @@ -1033,8 +1050,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*)) @@ -1487,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)))