0.8.0.24:

[sbcl.git] / src / code / print.lisp

diff --git a/src/code/print.lisp b/src/code/print.lisp
index ac90cfe..48889e5 100644 (file)
--- 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
@@ -397,16 +398,16 @@
                  (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))
@@ -682,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)))
@@ -830,6 +830,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))))
 \f
@@ -973,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 array)))
           (error 'print-not-readable :object vector))
         (descend-into (stream)
                       (write-string "#(" stream)
@@ -1000,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)
@@ -1016,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))
@@ -1381,30 +1392,36 @@
 ;;; 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 (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)
+                    ((>= z 0.1e0)
                      (values (float z original-x) ex))))))))))
+(eval-when (:compile-toplevel :execute)
+  (setf *read-default-float-format* 'single-float))
 \f
 ;;;; entry point for the float printer