+;;; 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))))))))
+\f
+;;; 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
+;;; original number. There may be some loss of precision due the
+;;; floating point representation. The scaling is always done with
+;;; long float arithmetic, which helps printing of lesser precisions
+;;; as well as avoiding generic arithmetic.
+;;;
+;;; When computing our initial scale factor using EXPT, we pull out
+;;; 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))