X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=53507ee16007bbe2d09bb79f859c3ab84bfe7fa3;hb=2d0b882f9eabffe5e2d32c0e2e7ab06c96f4fea3;hp=5c6dd4f1826753e08dbaf23a07a5b04345c82f74;hpb=099d6dd1f6a5ac2ffec5c14d07a4b905322ef968;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index 5c6dd4f..53507ee 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -236,21 +236,7 @@ ;;;; support for the PRINT-UNREADABLE-OBJECT macro -;;; MNA: cmucl-commit: Mon, 1 Jan 2001 01:30:53 -0800 (PST) -;;; Correct the pretty printing by print-unreadable-object. Only attempt -;;; to print pretty when the stream is a pretty-stream (and when *print-pretty*) -;;; to ensure that all output goes to the same stream. - -;;; MNA: cmucl-commit: Wed, 27 Dec 2000 05:24:30 -0800 (PST) -;;; Have print-unreadable-object respect *print-pretty*. - -;;; Guts of print-unreadable-object. -;;; -;;; When *print-pretty* and the stream is a pretty-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. -;;; +;;; guts of PRINT-UNREADABLE-OBJECT (defun %print-unreadable-object (object stream type identity body) (when *print-readably* (error 'print-not-readable :object object)) @@ -271,9 +257,13 @@ (write (get-lisp-obj-address object) :stream stream :radix nil :base 16) (write-char #\} stream)))) - (cond ((and (sb!pretty:pretty-stream-p stream) *print-pretty*) - (pprint-logical-block (stream nil :prefix "#<" :suffix ">") - (print-description))) + (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) @@ -622,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*)) @@ -964,34 +955,34 @@ (defun output-vector (vector stream) (declare (vector vector)) (cond ((stringp vector) - (cond ((or *print-escape* *print-readably*) - (write-char #\" stream) - (quote-string vector stream) - (write-char #\" stream)) - (t - (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-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 + (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 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 @@ -1447,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* @@ -1514,14 +1504,8 @@ ;;;; other leaf objects -;;; MNA: cmucl-commit: Mon, 1 Jan 2001 03:41:18 -0800 (PST) -;;; Fix output-character to escape the char-name. Reworking quote-string -;;; to not write the delimiting quotes so that is can be used by -;;; output-character. - - -;;; 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)))