X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=4981c77f2e0a32f9b8354b5fb5531509e9b7e04b;hb=7b384da95e6a30e1434523213aeeed3a90448c78;hp=a7d4ed2e77ff53991a4407d4278e25859f6561d8;hpb=d40a76606c86722b0aef8179155f9f2840739b72;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index a7d4ed2..4981c77 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -66,9 +66,10 @@ is less than this, then print using ``miser-style'' output. Miser style conditional newlines are turned on, and all indentations are turned off. If NIL, never use miser mode.") -(defvar *print-pprint-dispatch* nil - #!+sb-doc - "the pprint-dispatch-table that controls how to pretty-print objects") +(defvar *print-pprint-dispatch*) +#!+sb-doc +(setf (fdocumentation '*print-pprint-dispatch* 'variable) + "the pprint-dispatch-table that controls how to pretty-print objects") (defmacro with-standard-io-syntax (&body body) #!+sb-doc @@ -97,6 +98,7 @@ `(%with-standard-io-syntax (lambda () ,@body))) (defun %with-standard-io-syntax (function) + (declare (type function function)) (let ((*package* (find-package "COMMON-LISP-USER")) (*print-array* t) (*print-base* 10) @@ -240,6 +242,7 @@ ;;; guts of PRINT-UNREADABLE-OBJECT (defun %print-unreadable-object (object stream type identity body) + (declare (type (or null function) body)) (when *print-readably* (error 'print-not-readable :object object)) (flet ((print-description () @@ -376,11 +379,6 @@ ;;;; OUTPUT-OBJECT -- the main entry point -;;; the current pretty printer. This should be either a function that -;;; takes two arguments (the object and the stream) or NIL to indicate -;;; that there is no pretty printer installed. -(defvar *pretty-printer* nil) - ;;; Objects whose print representation identifies them EQLly don't ;;; need to be checked for circularity. (defun uniquely-identified-by-print-p (x) @@ -393,26 +391,23 @@ (defun output-object (object stream) (labels ((print-it (stream) (if *print-pretty* - (if *pretty-printer* - (funcall *pretty-printer* object stream) - (let ((*print-pretty* nil)) - (output-ugly-object object stream))) + (sb!pretty:output-pretty-object object stream) (output-ugly-object object stream))) (check-it (stream) (multiple-value-bind (marker initiate) (check-for-circularity object t) ;; initialization of the circulation detect noise ... (if (eq initiate :initiate) - (let ((*circularity-hash-table* - (make-hash-table :test 'eq))) - (check-it (make-broadcast-stream)) - (let ((*circularity-counter* 0)) - (check-it stream))) - ;; otherwise - (if marker - (when (handle-circularity marker stream) - (print-it stream)) - (print-it stream)))))) + (let ((*circularity-hash-table* + (make-hash-table :test 'eq))) + (check-it (make-broadcast-stream)) + (let ((*circularity-counter* 0)) + (check-it stream))) + ;; otherwise + (if marker + (when (handle-circularity marker stream) + (print-it stream)) + (print-it stream)))))) (cond (;; Maybe we don't need to bother with circularity detection. (or (not *print-circle*) (uniquely-identified-by-print-p object)) @@ -470,7 +465,7 @@ *print-object-is-disabled-p*)) (print-object object stream)) ((typep object 'structure-object) - (default-structure-print object stream *current-level*)) + (default-structure-print object stream *current-level-in-print*)) (t (write-string "#" stream)))) (function @@ -602,11 +597,12 @@ ;;; words, diddle its case according to *PRINT-CASE* and ;;; READTABLE-CASE. (defun output-symbol-name (name stream &optional (maybe-quote t)) - (declare (type simple-base-string name)) - (setup-printer-state) - (if (and maybe-quote (symbol-quotep name)) - (output-quoted-symbol-name name stream) - (funcall *internal-symbol-output-fun* name stream))) + (declare (type simple-string name)) + (let ((*readtable* (if *print-readably* *standard-readtable* *readtable*))) + (setup-printer-state) + (if (and maybe-quote (symbol-quotep name)) + (output-quoted-symbol-name name stream) + (funcall *internal-symbol-output-fun* name stream)))) ;;;; escaping symbols @@ -688,7 +684,6 @@ :initial-element 36)) (declaim (type (simple-array (unsigned-byte 8) (#.char-code-limit)) *digit-bases*)) - (dotimes (i 36) (let ((char (digit-char i 36))) (setf (aref *digit-bases* (char-code char)) i))) @@ -836,6 +831,9 @@ (return t) MARKER ; number marker in a numeric number... + ;; ("What," you may ask, "is a 'number marker'?" It's something + ;; that a conforming implementation might use in number syntax. + ;; See ANSI 2.3.1.1 "Potential Numbers as Tokens".) (when (test letter) (advance OTHER nil)) (go DIGIT)))) @@ -878,19 +876,19 @@ ;;; :DOWNCASE :CAPITALIZE (defun output-capitalize-symbol (pname stream) (declare (simple-string pname)) - (let ((prev-not-alpha t) + (let ((prev-not-alphanum t) (up (eq (readtable-case *readtable*) :upcase))) (dotimes (i (length pname)) (let ((char (char pname i))) (write-char (if up - (if (or prev-not-alpha (lower-case-p char)) + (if (or prev-not-alphanum (lower-case-p char)) char (char-downcase char)) - (if prev-not-alpha + (if prev-not-alphanum (char-upcase char) char)) stream) - (setq prev-not-alpha (not (alpha-char-p char))))))) + (setq prev-not-alphanum (not (alphanumericp char))))))) ;;; called when: ;;; READTABLE-CASE *PRINT-CASE* @@ -979,7 +977,7 @@ (write-char (if (zerop bit) #\0 #\1) stream))) (t (when (and *print-readably* - (not (eq (array-element-type vector) t))) + (not (array-readably-printable-p vector))) (error 'print-not-readable :object vector)) (descend-into (stream) (write-string "#(" stream) @@ -1006,6 +1004,14 @@ (when (needs-slash-p char) (write-char #\\ stream)) (write-char char stream)))))) +(defun array-readably-printable-p (array) + (and (eq (array-element-type array) t) + (let ((zero (position 0 (array-dimensions array))) + (number (position 0 (array-dimensions array) + :test (complement #'eql) + :from-end t))) + (or (null zero) (null number) (> zero number))))) + ;;; Output the printed representation of any array in either the #< or #A ;;; form. (defun output-array (array stream) @@ -1022,7 +1028,7 @@ ;;; Output the readable #A form of an array. (defun output-array-guts (array stream) (when (and *print-readably* - (not (eq (array-element-type array) t))) + (not (array-readably-printable-p array))) (error 'print-not-readable :object array)) (write-char #\# stream) (let ((*print-base* 10)) @@ -1054,7 +1060,7 @@ ;;; 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*)) + (default-structure-print instance stream *current-level-in-print*)) ;;;; integer, ratio, and complex printing (i.e. everything but floats) @@ -1158,8 +1164,8 @@ (2 (write-char #\b stream)) (8 (write-char #\o stream)) (16 (write-char #\x stream)) - (t (write *print-base* :stream stream :radix nil :base 10))) - (write-char #\r stream)) + (t (write *print-base* :stream stream :radix nil :base 10) + (write-char #\r stream)))) (let ((*print-radix* nil)) (output-integer (numerator ratio) stream) (write-char #\/ stream) @@ -1387,30 +1393,40 @@ ;;; part of the computation to avoid over/under flow. When ;;; denormalized, we must pull out a large factor, since there is more ;;; negative exponent range than positive range. + +(eval-when (:compile-toplevel :execute) + (setf *read-default-float-format* + #!+long-float 'long-float #!-long-float 'double-float)) (defun scale-exponent (original-x) (let* ((x (coerce original-x 'long-float))) (multiple-value-bind (sig exponent) (decode-float x) (declare (ignore sig)) - (if (= x 0.0l0) - (values (float 0.0l0 original-x) 1) - (let* ((ex (round (* exponent (log 2l0 10)))) + (if (= x 0.0e0) + (values (float 0.0e0 original-x) 1) + (let* ((ex (locally (declare (optimize (safety 0))) + (the fixnum + (round (* exponent (log 2e0 10)))))) (x (if (minusp ex) (if (float-denormalized-p x) #!-long-float - (* x 1.0l16 (expt 10.0l0 (- (- ex) 16))) + (* x 1.0e16 (expt 10.0e0 (- (- ex) 16))) #!+long-float - (* x 1.0l18 (expt 10.0l0 (- (- ex) 18))) - (* x 10.0l0 (expt 10.0l0 (- (- ex) 1)))) - (/ x 10.0l0 (expt 10.0l0 (1- ex)))))) - (do ((d 10.0l0 (* d 10.0l0)) + (* x 1.0e18 (expt 10.0e0 (- (- ex) 18))) + (* x 10.0e0 (expt 10.0e0 (- (- ex) 1)))) + (/ x 10.0e0 (expt 10.0e0 (1- ex)))))) + (do ((d 10.0e0 (* d 10.0e0)) (y x (/ x d)) (ex ex (1+ ex))) - ((< y 1.0l0) - (do ((m 10.0l0 (* m 10.0l0)) + ((< y 1.0e0) + (do ((m 10.0e0 (* m 10.0e0)) (z y (* y m)) (ex ex (1- ex))) - ((>= z 0.1l0) - (values (float z original-x) ex)))))))))) + ((>= z 0.1e0) + (values (float z original-x) ex)) + (declare (long-float m) (integer ex)))) + (declare (long-float d)))))))) +(eval-when (:compile-toplevel :execute) + (setf *read-default-float-format* 'single-float)) ;;;; entry point for the float printer @@ -1513,9 +1529,10 @@ ;;; 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))) + (let ((graphicp (graphic-char-p char)) + (name (char-name char))) (write-string "#\\" stream) - (if name + (if (and name (not graphicp)) (quote-string name stream) (write-char char stream))) (write-char char stream))) @@ -1575,7 +1592,7 @@ (*print-level* 3) ; ..print an interpreted function definition ;; FIXME: This find-the-function-name idiom ought to be ;; encapsulated in a function somewhere. - (name (case (function-subtype object) + (name (case (fun-subtype object) (#.sb!vm:closure-header-widetag "CLOSURE") (#.sb!vm:simple-fun-header-widetag (%simple-fun-name object)) (t 'no-name-available)))