X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=4c945e8bb126e659dc74694b44419a5b4c5bfef8;hb=7c5138fcbdb302abc563a2060493f2f0304ae902;hp=4981c77f2e0a32f9b8354b5fb5531509e9b7e04b;hpb=b420873de742dd0e9ff0d2231d2cc37cf6aba3f8;p=sbcl.git

diff --git a/src/code/print.lisp b/src/code/print.lisp
index 4981c77..4c945e8 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -75,26 +75,26 @@
   #!+sb-doc
   "Bind the reader and printer control variables to values that enable READ
    to reliably read the results of PRINT. These values are:
-       *PACKAGE*			the COMMON-LISP-USER package
-       *PRINT-ARRAY*			T
-       *PRINT-BASE*			10
-       *PRINT-CASE*			:UPCASE
-       *PRINT-CIRCLE*			NIL
-       *PRINT-ESCAPE*			T
-       *PRINT-GENSYM*			T
-       *PRINT-LENGTH*			NIL
-       *PRINT-LEVEL*			NIL
-       *PRINT-LINES*			NIL
-       *PRINT-MISER-WIDTH*		NIL
-       *PRINT-PRETTY*			NIL
-       *PRINT-RADIX*			NIL
-       *PRINT-READABLY*			T
-       *PRINT-RIGHT-MARGIN*		NIL
-       *READ-BASE*			10
-       *READ-DEFAULT-FLOAT-FORMAT* 	SINGLE-FLOAT
-       *READ-EVAL*			T
-       *READ-SUPPRESS*			NIL
-       *READTABLE*			the standard readtable"
+       *PACKAGE*                        the COMMON-LISP-USER package
+       *PRINT-ARRAY*                    T
+       *PRINT-BASE*                     10
+       *PRINT-CASE*                     :UPCASE
+       *PRINT-CIRCLE*                   NIL
+       *PRINT-ESCAPE*                   T
+       *PRINT-GENSYM*                   T
+       *PRINT-LENGTH*                   NIL
+       *PRINT-LEVEL*                    NIL
+       *PRINT-LINES*                    NIL
+       *PRINT-MISER-WIDTH*              NIL
+       *PRINT-PRETTY*                   NIL
+       *PRINT-RADIX*                    NIL
+       *PRINT-READABLY*                 T
+       *PRINT-RIGHT-MARGIN*             NIL
+       *READ-BASE*                      10
+       *READ-DEFAULT-FLOAT-FORMAT*      SINGLE-FLOAT
+       *READ-EVAL*                      T
+       *READ-SUPPRESS*                  NIL
+       *READTABLE*                      the standard readtable"
   `(%with-standard-io-syntax (lambda () ,@body)))
 
 (defun %with-standard-io-syntax (function)
@@ -158,7 +158,7 @@
   #!+sb-doc
   "Output a mostly READable printed representation of OBJECT on the specified
   STREAM."
-  (let ((*print-escape* T))
+  (let ((*print-escape* t))
     (output-object object (out-synonym-of stream)))
   object)
 
@@ -166,8 +166,8 @@
   #!+sb-doc
   "Output an aesthetic but not necessarily READable printed representation
   of OBJECT on the specified STREAM."
-  (let ((*print-escape* NIL)
-	(*print-readably* NIL))
+  (let ((*print-escape* nil)
+	(*print-readably* nil))
     (output-object object (out-synonym-of stream)))
   object)
 
@@ -217,18 +217,21 @@
   #!+sb-doc
   "Return the printed representation of OBJECT as a string with
    slashification on."
-  (stringify-object object t))
+  (let ((*print-escape* t))
+    (stringify-object object)))
 
 (defun princ-to-string (object)
   #!+sb-doc
   "Return the printed representation of OBJECT as a string with
   slashification off."
-  (stringify-object object nil))
+  (let ((*print-escape* nil)
+	(*print-readably* nil))
+    (stringify-object object)))
 
 ;;; This produces the printed representation of an object as a string.
 ;;; The few ...-TO-STRING functions above call this.
 (defvar *string-output-streams* ())
-(defun stringify-object (object &optional (*print-escape* *print-escape*))
+(defun stringify-object (object)
   (let ((stream (if *string-output-streams*
 		    (pop *string-output-streams*)
 		    (make-string-output-stream))))
@@ -249,15 +252,12 @@
 	   (when type
 	     (write (type-of object) :stream stream :circle nil
 		    :level nil :length nil)
-	     (when (or body identity)
-	       (write-char #\space stream)
-	       (pprint-newline :fill stream)))
+	     (write-char #\space stream))
 	   (when body
 	     (funcall body))
 	   (when identity
-	     (when body
-	       (write-char #\space stream)
-	       (pprint-newline :fill stream))
+	     (when (or body (not type))
+	       (write-char #\space stream))
 	     (write-char #\{ stream)
 	     (write (get-lisp-obj-address object) :stream stream
 		    :radix nil :base 16)
@@ -360,7 +360,7 @@
      ;; Someone forgot to initiate circularity detection.
      (let ((*print-circle* nil))
        (error "trying to use CHECK-FOR-CIRCULARITY when ~
-	       circularity checking isn't initiated")))
+               circularity checking isn't initiated")))
     ((t)
      ;; It's a second (or later) reference to the object while we are
      ;; just looking. So don't bother groveling it again.
@@ -454,8 +454,6 @@
     ;; As long as no one comes up with a non-obscure way of detecting this
     ;; sleaziness, fixing this nonconformity will probably have a low
     ;; priority. -- WHN 2001-11-25
-    (fixnum
-     (output-integer object stream))
     (list
      (if (null object)
 	 (output-symbol object stream)
@@ -615,10 +613,10 @@
 ;;; 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
+  (make-array 160 ; FIXME
 	      :element-type '(unsigned-byte 16)
 	      :initial-element 0))
-(declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit))
+(declaim (type (simple-array (unsigned-byte 16) (#.160)) ; FIXME
 	       *character-attributes*))
 
 ;;; constants which are a bit-mask for each interesting character attribute
@@ -672,17 +670,17 @@
   (set-bit #\/ slash-attribute)
 
   ;; Mark anything not explicitly allowed as funny.
-  (dotimes (i char-code-limit)
+  (dotimes (i 160) ; FIXME
     (when (zerop (aref *character-attributes* i))
       (setf (aref *character-attributes* i) funny-attribute))))
 
 ;;; For each character, the value of the corresponding element is the
 ;;; lowest base in which that character is a digit.
 (defvar *digit-bases*
-  (make-array char-code-limit
+  (make-array 128 ; FIXME
 	      :element-type '(unsigned-byte 8)
 	      :initial-element 36))
-(declaim (type (simple-array (unsigned-byte 8) (#.char-code-limit))
+(declaim (type (simple-array (unsigned-byte 8) (#.128)) ; FIXME
 	       *digit-bases*))
 (dotimes (i 36)
   (let ((char (digit-char i 36)))
@@ -698,7 +696,11 @@
 		   ,(if at-end '(go TEST-SIGN) '(return nil)))
 		 (setq current (schar name index)
 		       code (char-code current)
-		       bits (aref attributes code))
+		       bits (cond ; FIXME
+                              ((< code 160) (aref attributes code))
+                              ((upper-case-p current) uppercase-attribute)
+                              ((lower-case-p current) lowercase-attribute)
+                              (t other-attribute)))
 		 (incf index)
 		 (go ,tag)))
 	     (test (&rest attributes)
@@ -713,7 +715,8 @@
 					attributes))
 			     bits)))))
 	     (digitp ()
-	       `(< (the fixnum (aref bases code)) base)))
+               `(and (< code 128) ; FIXME
+                     (< (the fixnum (aref bases code)) base))))
 
     (prog ((len (length name))
 	   (attributes *character-attributes*)
@@ -740,7 +743,13 @@
 			  letter-attribute)))
 	(do ((i (1- index) (1+ i)))
 	    ((= i len) (return-from symbol-quotep nil))
-	  (unless (zerop (logand (aref attributes (char-code (schar name i)))
+	  (unless (zerop (logand (let* ((char (schar name i))
+					(code (char-code char)))
+				   (cond 
+				     ((< code 160) (aref attributes code))
+				     ((upper-case-p char) uppercase-attribute)
+				     ((lower-case-p char) lowercase-attribute)
+				     (t other-attribute)))
 				 mask))
 	    (return-from symbol-quotep t))))
 
@@ -961,7 +970,13 @@
 (defun output-vector (vector stream)
   (declare (vector vector))
   (cond ((stringp vector)
-	 (cond ((or *print-escape* *print-readably*)
+	 (cond ((and *print-readably*
+		     (not (eq (array-element-type vector)
+			      (load-time-value
+			       (array-element-type
+				(make-array 0 :element-type 'character))))))
+		(error 'print-not-readable :object vector))
+	       ((or *print-escape* *print-readably*)
 		(write-char #\" stream)
 		(quote-string vector stream)
 		(write-char #\" stream))
@@ -1031,7 +1046,8 @@
 	     (not (array-readably-printable-p array)))
     (error 'print-not-readable :object array))
   (write-char #\# stream)
-  (let ((*print-base* 10))
+  (let ((*print-base* 10)
+	(*print-radix* nil))
     (output-integer (array-rank array) stream))
   (write-char #\A stream)
   (with-array-data ((data array) (start) (end))
@@ -1064,115 +1080,70 @@
 
 ;;;; integer, ratio, and complex printing (i.e. everything but floats)
 
+(defun %output-radix (base stream)
+  (write-char #\# stream)
+  (write-char (case base
+                (2 #\b)
+                (8 #\o)
+                (16 #\x)
+                (t (%output-fixnum-in-base base 10 stream)
+                   #\r))
+              stream))
+
+(defun %output-fixnum-in-base (n base stream)
+  (multiple-value-bind (q r)
+      (truncate n base)
+    ;; Recurse until you have all the digits pushed on
+    ;; the stack.
+    (unless (zerop q)
+      (%output-fixnum-in-base q base stream))
+    ;; Then as each recursive call unwinds, turn the
+    ;; digit (in remainder) into a character and output
+    ;; the character.
+    (write-char 
+     (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" r) 
+     stream)))
+
+(defun %output-bignum-in-base (n base stream)
+  (labels ((bisect (n power)
+             (if (fixnump n)
+                 (%output-fixnum-in-base n base stream)
+                 (let ((k (truncate power 2)))
+                   (multiple-value-bind (q r) (truncate n (expt base k))
+                     (bisect q (- power k))
+                     (let ((npower (if (zerop r) 0 (truncate (log r base)))))
+                       (dotimes (z (- k npower 1))
+                         (write-char #\0 stream))
+                       (bisect r npower)))))))
+    (bisect n (truncate (log n base)))))
+
+(defun %output-integer-in-base (integer base stream)
+  (when (minusp integer)
+    (write-char #\- stream)
+    (setf integer (- integer)))
+  (if (fixnump integer)
+      (%output-fixnum-in-base integer base stream)
+      (%output-bignum-in-base integer base stream)))
+
 (defun output-integer (integer stream)
-  ;; FIXME: This UNLESS form should be pulled out into something like
-  ;; (SANE-PRINT-BASE), along the lines of (SANE-PACKAGE) for the
-  ;; *PACKAGE* variable.
-  (unless (and (fixnump *print-base*)
-	       (< 1 *print-base* 37))
-    (let ((obase *print-base*))
-      (setq *print-base* 10.)
-      (error "~A is not a reasonable value for *PRINT-BASE*." obase)))
-  (when (and (not (= *print-base* 10.))
-	     *print-radix*)
-    ;; First print leading base information, if any.
-    (write-char #\# stream)
-    (write-char (case *print-base*
-		  (2. #\b)
-		  (8. #\o)
-		  (16. #\x)
-		  (T (let ((fixbase *print-base*)
-			   (*print-base* 10.)
-			   (*print-radix* ()))
-		       (sub-output-integer fixbase stream))
-		     #\r))
-		stream))
-  ;; Then output a minus sign if the number is negative, then output
-  ;; the absolute value of the number.
-  (cond ((bignump integer) (print-bignum integer stream))
-	((< integer 0)
-	 (write-char #\- stream)
-	 (sub-output-integer (- integer) stream))
-	(t
-	 (sub-output-integer integer stream)))
-  ;; Print any trailing base information, if any.
-  (if (and (= *print-base* 10.) *print-radix*)
-      (write-char #\. stream)))
-
-(defun sub-output-integer (integer stream)
-  (let ((quotient ())
-	(remainder ()))
-    ;; Recurse until you have all the digits pushed on the stack.
-    (if (not (zerop (multiple-value-setq (quotient remainder)
-		      (truncate integer *print-base*))))
-	(sub-output-integer quotient stream))
-    ;; Then as each recursive call unwinds, turn the digit (in remainder)
-    ;; into a character and output the character.
-    (write-char (code-char (if (and (> remainder 9.)
-				    (> *print-base* 10.))
-			       (+ (char-code #\A) (- remainder 10.))
-			       (+ (char-code #\0) remainder)))
-		stream)))
-
-;;;; bignum printing
-
-;;; *BASE-POWER* holds the number that we keep dividing into the
-;;; bignum for each *print-base*. We want this number as close to
-;;; *most-positive-fixnum* as possible, i.e. (floor (log
-;;; most-positive-fixnum *print-base*)).
-(defparameter *base-power* (make-array 37 :initial-element nil))
-
-;;; *FIXNUM-POWER--1* holds the number of digits for each *PRINT-BASE*
-;;; that fit in the corresponding *base-power*.
-(defparameter *fixnum-power--1* (make-array 37 :initial-element nil))
-
-;;; Print the bignum to the stream. We first generate the correct
-;;; value for *base-power* and *fixnum-power--1* if we have not
-;;; already. Then we call bignum-print-aux to do the printing.
-(defun print-bignum (big stream)
-  (unless (aref *base-power* *print-base*)
-    (do ((power-1 -1 (1+ power-1))
-	 (new-divisor *print-base* (* new-divisor *print-base*))
-	 (divisor 1 new-divisor))
-	((not (fixnump new-divisor))
-	 (setf (aref *base-power* *print-base*) divisor)
-	 (setf (aref *fixnum-power--1* *print-base*) power-1))))
-  (bignum-print-aux (cond ((minusp big)
-			   (write-char #\- stream)
-			   (- big))
-			  (t big))
-		    (aref *base-power* *print-base*)
-		    (aref *fixnum-power--1* *print-base*)
-		    stream)
-  big)
-
-(defun bignum-print-aux (big divisor power-1 stream)
-  (multiple-value-bind (newbig fix) (truncate big divisor)
-    (if (fixnump newbig)
-	(sub-output-integer newbig stream)
-	(bignum-print-aux newbig divisor power-1 stream))
-    (do ((zeros power-1 (1- zeros))
-	 (base-power *print-base* (* base-power *print-base*)))
-	((> base-power fix)
-	 (dotimes (i zeros) (write-char #\0 stream))
-	 (sub-output-integer fix stream)))))
+  (let ((base *print-base*))
+    (when (and (/= base 10) *print-radix*)
+      (%output-radix base stream))
+    (%output-integer-in-base integer base stream)
+    (when (and *print-radix* (= base 10))
+      (write-char #\. stream))))
 
 (defun output-ratio (ratio stream)
-  (when *print-radix*
-    (write-char #\# stream)
-    (case *print-base*
-      (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))))
-  (let ((*print-radix* nil))
-    (output-integer (numerator ratio) stream)
+  (let ((base *print-base*))
+    (when *print-radix*
+      (%output-radix base stream))
+    (%output-integer-in-base (numerator ratio) base stream)
     (write-char #\/ stream)
-    (output-integer (denominator ratio) stream)))
+    (%output-integer-in-base (denominator ratio) base stream)))
 
 (defun output-complex (complex stream)
   (write-string "#C(" stream)
+  ;; FIXME: Could this just be OUTPUT-NUMBER? 
   (output-object (realpart complex) stream)
   (write-char #\space stream)
   (output-object (imagpart complex) stream)
@@ -1244,8 +1215,6 @@
 ;;; [CMUC]<steele>tradix.press. DO NOT EVEN THINK OF ATTEMPTING TO
 ;;; UNDERSTAND THIS CODE WITHOUT READING THE PAPER!
 
-(defvar *digits* "0123456789")
-
 (defun flonum-to-string (x &optional width fdigits scale fmin)
   (cond ((zerop x)
 	 ;; Zero is a special case which FLOAT-STRING cannot handle.
@@ -1266,6 +1235,7 @@
 (defun float-string (fraction exponent precision width fdigits scale fmin)
   (let ((r fraction) (s 1) (m- 1) (m+ 1) (k 0)
 	(digits 0) (decpnt 0) (cutoff nil) (roundup nil) u low high
+        (digit-characters "0123456789")
 	(digit-string (make-array 50
 				  :element-type 'base-char
 				  :fill-pointer 0
@@ -1356,13 +1326,13 @@
       ;; Stop when either precision is exhausted or we have printed as
       ;; many fraction digits as permitted.
       (when (or low high (and cutoff (<= k cutoff))) (return))
-      (vector-push-extend (char *digits* u) digit-string)
+      (vector-push-extend (char digit-characters u) digit-string)
       (incf digits))
     ;; If cutoff occurred before first digit, then no digits are
     ;; generated at all.
     (when (or (not cutoff) (>= k cutoff))
       ;; Last digit may need rounding
-      (vector-push-extend (char *digits*
+      (vector-push-extend (char digit-characters
 				(cond ((and low (not high)) u)
 				      ((and high (not low)) (1+ u))
 				      (t (if (<= (ash r 1) s) u (1+ u)))))
@@ -1381,6 +1351,98 @@
     ;; all done
     (values digit-string (1+ digits) (= decpnt 0) (= decpnt digits) decpnt)))
 
+;;; implementation of figure 1 from Burger and Dybvig, 1996.  As the
+;;; implementation of the Dragon from Classic CMUCL (and above,
+;;; FLONUM-TO-STRING) says: "DO NOT EVEN THINK OF ATTEMPTING TO
+;;; UNDERSTAND THIS CODE WITHOUT READING THE PAPER!", and in this case
+;;; we have to add that even reading the paper might not bring
+;;; immediate illumination as CSR has attempted to turn idiomatic
+;;; Scheme into idiomatic Lisp.
+;;;
+;;; FIXME: figure 1 from Burger and Dybvig is the unoptimized
+;;; algorithm, noticeably slow at finding the exponent.  Figure 2 has
+;;; an improved algorithm, but CSR ran out of energy
+;;;
+;;; FIXME: Burger and Dybvig also provide an algorithm for
+;;; fixed-format floating point printing.  If it were implemented,
+;;; then we could delete the Dragon altogether (see FLONUM-TO-STRING).
+;;;
+;;; possible extension for the enthusiastic: printing floats in bases
+;;; other than base 10.
+(defconstant single-float-min-e
+  (nth-value 1 (decode-float least-positive-single-float)))
+(defconstant double-float-min-e
+  (nth-value 1 (decode-float least-positive-double-float)))
+#!+long-float
+(defconstant long-float-min-e
+  (nth-value 1 (decode-float least-positive-long-float)))
+
+(defun flonum-to-digits (v)
+  (let ((print-base 10) ; B
+	(float-radix 2) ; b
+	(float-digits (float-digits v)) ; p
+        (digit-characters "0123456789")
+	(min-e
+	 (etypecase v
+	   (single-float single-float-min-e)
+	   (double-float double-float-min-e)
+	   #!+long-float
+	   (long-float long-float-min-e))))
+    (multiple-value-bind (f e)
+	(integer-decode-float v)
+      (let (;; FIXME: these even tests assume normal IEEE rounding
+	    ;; mode.  I wonder if we should cater for non-normal?
+	    (high-ok (evenp f))
+	    (low-ok (evenp f))
+	    (result (make-array 50 :element-type 'base-char
+				:fill-pointer 0 :adjustable t)))
+	(labels ((scale (r s m+ m-)
+		   (do ((k 0 (1+ k))
+			(s s (* s print-base)))
+		       ((not (or (> (+ r m+) s)
+				 (and high-ok (= (+ r m+) s))))
+			(do ((k k (1- k))
+			     (r r (* r print-base))
+			     (m+ m+ (* m+ print-base))
+			     (m- m- (* m- print-base)))
+			    ((not (or (< (* (+ r m+) print-base) s)
+				      (and (not high-ok)
+                                           (= (* (+ r m+) print-base) s))))
+			     (values k (generate r s m+ m-)))))))
+		 (generate (r s m+ m-)
+		   (let (d tc1 tc2)
+		     (tagbody
+		      loop
+			(setf (values d r) (truncate (* r print-base) s))
+			(setf m+ (* m+ print-base))
+			(setf m- (* m- print-base))
+			(setf tc1 (or (< r m-) (and low-ok (= r m-))))
+			(setf tc2 (or (> (+ r m+) s)
+				      (and high-ok (= (+ r m+) s))))
+			(when (or tc1 tc2)
+			  (go end))
+			(vector-push-extend (char digit-characters d) result)
+			(go loop)
+		      end
+			(let ((d (cond
+				   ((and (not tc1) tc2) (1+ d))
+				   ((and tc1 (not tc2)) d)
+				   (t ; (and tc1 tc2)
+				    (if (< (* r 2) s) d (1+ d))))))
+			  (vector-push-extend (char digit-characters d) result)
+			  (return-from generate result))))))
+	  (if (>= e 0)
+	      (if (/= f (expt float-radix (1- float-digits)))
+		  (let ((be (expt float-radix e)))
+		    (scale (* f be 2) 2 be be))
+		  (let* ((be (expt float-radix e))
+			 (be1 (* be float-radix)))
+		    (scale (* f be1 2) (* float-radix 2) be1 be)))
+	      (if (or (= e min-e) (/= f (expt float-radix (1- float-digits))))
+		  (scale (* f 2) (* (expt float-radix (- e)) 2) 1 1)
+		  (scale (* f float-radix 2)
+			 (* (expt float-radix (- 1 e)) 2) float-radix 1))))))))
+
 ;;; Given a non-negative floating point number, SCALE-EXPONENT returns
 ;;; a new floating point number Z in the range (0.1, 1.0] and an
 ;;; exponent E such that Z * 10^E is (approximately) equal to the
@@ -1445,6 +1507,12 @@
 ;;; attractive to handle exponential notation with the same accuracy
 ;;; as non-exponential notation, using the method described in the
 ;;; Steele and White paper.
+;;;
+;;; NOTE II: this has been bypassed slightly by implementing Burger
+;;; and Dybvig, 1996.  When someone has time (KLUDGE) they can
+;;; probably (a) implement the optimizations suggested by Burger and
+;;; Dyvbig, and (b) remove all vestiges of Dragon4, including from
+;;; fixed-format printing.
 
 ;;; Print the appropriate exponent marker for X and the specified exponent.
 (defun print-float-exponent (x exp stream)
@@ -1502,26 +1570,34 @@
 	(write-string "0.0" stream)
 	(print-float-exponent x 0 stream))
        (t
-	(output-float-aux x stream (float 1/1000 x) (float 10000000 x))))))))
+	(output-float-aux x stream -3 8)))))))
 (defun output-float-aux (x stream e-min e-max)
-  (if (and (>= x e-min) (< x e-max))
-      ;; free format
-      (multiple-value-bind (str len lpoint tpoint) (flonum-to-string x)
-	(declare (ignore len))
-	(when lpoint (write-char #\0 stream))
-	(write-string str stream)
-	(when tpoint (write-char #\0 stream))
-	(print-float-exponent x 0 stream))
-      ;; exponential format
-      (multiple-value-bind (f ex) (scale-exponent x)
-	(multiple-value-bind (str len lpoint tpoint)
-	    (flonum-to-string f nil nil 1)
-	  (declare (ignore len))
-	  (when lpoint (write-char #\0 stream))
-	  (write-string str stream)
-	  (when tpoint (write-char #\0 stream))
-	  ;; Subtract out scale factor of 1 passed to FLONUM-TO-STRING.
-	  (print-float-exponent x (1- ex) stream)))))
+  (multiple-value-bind (e string)
+      (flonum-to-digits x)
+    (cond
+      ((< e-min e e-max)
+       (if (plusp e)
+	   (progn
+	     (write-string string stream :end (min (length string) e))
+	     (dotimes (i (- e (length string)))
+	       (write-char #\0 stream))
+	     (write-char #\. stream)
+	     (write-string string stream :start (min (length string) e))
+	     (when (<= (length string) e)
+	       (write-char #\0 stream))
+	     (print-float-exponent x 0 stream))
+	   (progn
+	     (write-string "0." stream)
+	     (dotimes (i (- e))
+	       (write-char #\0 stream))
+	     (write-string string stream)
+	     (print-float-exponent x 0 stream))))
+      (t (write-string string stream :end 1)
+	 (write-char #\. stream)
+	 (write-string string stream :start 1)
+	 (when (= (length string) 1)
+	   (write-char #\0 stream))
+	 (print-float-exponent x (1- e) stream)))))
 
 ;;;; other leaf objects