X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=53507ee16007bbe2d09bb79f859c3ab84bfe7fa3;hb=2d0b882f9eabffe5e2d32c0e2e7ab06c96f4fea3;hp=7b4d3fe1f754a3428584ebaff51e960f8e693323;hpb=02ce4b1b927f1312c300047bd5a0db6663a1d2c6;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index 7b4d3fe..53507ee 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 @@ -598,7 +612,8 @@ ;;; 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*)) @@ -925,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)) @@ -940,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) @@ -954,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 @@ -1020,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*)) @@ -1422,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* @@ -1489,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)))