diff --git a/code/format.lisp b/code/format.lisp index 8f810d1b49f2d9e4da0a70ed4eaaa6a46a303964..7096bd923927deebc02bdde4100cb42b20a782f7 100644 --- a/code/format.lisp +++ b/code/format.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.73 2007/10/09 16:11:54 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.74 2007/10/09 16:45:07 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1219,19 +1219,17 @@ ;; This scale function is basically the same as the one in ;; FLONUM-TO-DIGITS, except we don't return the computed ;; digits. We only want the exponent. - (labels ((flog (v) - (declare (optimize speed)) - ;; Compute (ceiling (- (log v 10d0) 1d-10)) - (ceiling (the (double-float -400d0 400d0) - (- (log (the (double-float (0d0)) - (etypecase v - (single-float - (coerce v 'double-float)) - (double-float - v) - (double-double-float - (double-double-hi v)))) - 10d0) + (labels ((flog (x) + (declare (type (float (0.0)) x)) + (let ((xd (etypecase x + (single-float + (float x 1d0)) + (double-float + x) + #+double-double-float + (double-double-float + (double-double-hi x))))) + (ceiling (- (the (double-float -400d0 400d0) (log xd 10d0)) 1d-10)))) (fixup (r s m+ k) (if (if high-ok @@ -1240,15 +1238,12 @@ (+ k 1) k)) (scale (r s m+) - (declare (integer r s m+) - (optimize speed)) - (let ((est (flog v))) + (let* ((est (flog v)) + (scale (the integer (aref lisp::*powers-of-ten* (abs est))))) (if (>= est 0) - (fixup r (* s (the integer (aref lisp::*powers-of-ten* est))) m+ est) - (let ((scale (the integer (aref lisp::*powers-of-ten* (- est))))) - (fixup (* r scale) s (* m+ scale) est)))))) + (fixup r (* s scale) m+ est) + (fixup (* r scale) s (* m+ scale) est))))) (let (r s m+) - (declare (optimize speed)) (if (>= e 0) (let* ((be (expt float-radix e)) (be1 (* be float-radix))) diff --git a/code/print.lisp b/code/print.lisp index 6d0a2fc765677a2c276917d8ca9dce0f4705b857..4d4225b39d38090def46046c1f03c85a58a4fff8 100644 --- a/code/print.lisp +++ b/code/print.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.113 2007/10/09 16:11:54 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.114 2007/10/09 16:45:07 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1838,6 +1838,8 @@ radix-R. If you have a power-list then pass it in as PL." #+double-double (defconstant double-double-float-min-e double-float-min-e) +;; Exact powers of ten. Must be large enough to cover the range from +;; least-positive-double-float to most-positive-double-float (declaim (type (simple-array integer (326)) *powers-of-ten*)) (defparameter *powers-of-ten* (make-array 326 @@ -1881,18 +1883,30 @@ radix-R. If you have a power-list then pass it in as PL." (low-ok (evenp f)) (result (make-array 50 :element-type 'base-char :fill-pointer 0 :adjustable t))) - (labels ((fixup (r s m+ m- k) + (labels ((flog (x) + (declare (type (float (0.0)) x)) + (let ((xd (etypecase x + (single-float + (float x 1d0)) + (double-float + x) + #+double-double-float + (double-double-float + (double-double-hi x))))) + (ceiling (- (the (double-float -400d0 400d0) (log xd 10d0)) + 1d-10)))) + (fixup (r s m+ m- k) (if (if high-ok (>= (+ r m+) s) (> (+ r m+) s)) (values (+ k 1) (generate r (* s print-base) m+ m-)) (values k (generate r s m+ m-)))) (scale (r s m+ m-) - (let ((est (ceiling (- (log v 10d0) 1d-10)))) + (let* ((est (flog v)) + (scale (the integer (aref lisp::*powers-of-ten* (abs est))))) (if (>= est 0) - (fixup r (* s (aref *powers-of-ten* est)) m+ m- est) - (let ((scale (aref *powers-of-ten* (- est)))) - (fixup (* r scale) s (* m+ scale) (* m- scale) est))))) + (fixup r (* s scale) m+ m- est) + (fixup (* r scale) s (* m+ scale) (* m- scale) est)))) (generate (r s m+ m-) (multiple-value-bind (d r) (truncate (* r print-base) s)