X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=a6539ee60258ddedc7a3aac4bd32ed5bff234370;hb=9719063b661a99d2cc2a1d9b2ea7dd81145ded59;hp=5b1ae0502d22534b79b5d70bb9f22e859e5753ba;hpb=29a9ccc860532b32c566aec095f570e999a9c52c;p=sbcl.git

diff --git a/src/code/print.lisp b/src/code/print.lisp
index 5b1ae05..a6539ee 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -97,6 +97,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 +241,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 +378,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 +390,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 +464,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 "#<INSTANCE but not STRUCTURE-OBJECT>" stream))))
     (function
@@ -688,7 +682,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 +829,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))))
 
@@ -979,7 +975,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)
@@ -1006,6 +1002,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 +1026,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 +1058,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 +1391,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))
 
 ;;;; entry point for the float printer