X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=7cd5d3692b8409b2455b1093be5e215f45d01c8e;hb=c7de1989d006e0b3a4f26143b7a81c9bdb754101;hp=03bfd1b2f6c6b67b20817b3e7b8d091118f77144;hpb=165bb53b405ab95ce76615ab77cee8284df0a36e;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index 03bfd1b..7cd5d36 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 @@ -94,9 +95,10 @@ *READ-EVAL* T *READ-SUPPRESS* NIL *READTABLE* the standard readtable" - `(%with-standard-io-syntax #'(lambda () ,@body))) + `(%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,13 +465,13 @@ *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 (unless (and (funcallable-instance-p object) (printed-as-funcallable-standard-class object stream)) - (output-function object stream))) + (output-fun object stream))) (symbol (output-symbol object stream)) (number @@ -519,12 +514,12 @@ ;;; This variable contains the current definition of one of three ;;; symbol printers. SETUP-PRINTER-STATE sets this variable. -(defvar *internal-symbol-output-function* nil) +(defvar *internal-symbol-output-fun* nil) ;;; This function sets the internal global symbol -;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* to the right function depending -;;; on the value of *PRINT-CASE*. See the manual for details. The -;;; print buffer stream is also reset. +;;; *INTERNAL-SYMBOL-OUTPUT-FUN* to the right function depending on +;;; the value of *PRINT-CASE*. See the manual for details. The print +;;; buffer stream is also reset. (defun setup-printer-state () (unless (and (eq *print-case* *previous-case*) (eq (readtable-case *readtable*) *previous-readtable-case*)) @@ -538,7 +533,7 @@ (setf (readtable-case *readtable*) :upcase) (error "invalid READTABLE-CASE value: ~S" *previous-readtable-case*)) - (setq *internal-symbol-output-function* + (setq *internal-symbol-output-fun* (case *previous-readtable-case* (:upcase (case *print-case* @@ -602,11 +597,11 @@ ;;; 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)) + (declare (type simple-string name)) (setup-printer-state) (if (and maybe-quote (symbol-quotep name)) (output-quoted-symbol-name name stream) - (funcall *internal-symbol-output-function* name stream))) + (funcall *internal-symbol-output-fun* name stream))) ;;;; escaping symbols @@ -688,7 +683,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,13 +830,16 @@ (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)))) -;;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* +;;;; *INTERNAL-SYMBOL-OUTPUT-FUN* ;;;; -;;;; Case hackery. These functions are stored in -;;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* according to the values of +;;;; case hackery: These functions are stored in +;;;; *INTERNAL-SYMBOL-OUTPUT-FUN* according to the values of ;;;; *PRINT-CASE* and READTABLE-CASE. ;;; called when: @@ -979,7 +976,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 +1003,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 +1027,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 +1059,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) @@ -1387,30 +1392,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 @@ -1570,12 +1585,12 @@ (declare (ignore object stream)) nil) -(defun output-function (object stream) +(defun output-fun (object stream) (let* ((*print-length* 3) ; in case we have to.. (*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)))