* changed implementation of $flonum->exact.

benchmarks.larceny/results.Larceny-r6rs

@@ -8554,3 +8554,23 @@ Words allocated: 220925448
 Words reclaimed: 0
 Elapsed time...: 20757 ms (User: 10967 ms; System: 9775 ms)
 Elapsed GC time: 179 ms (CPU: 176 in 843 collections.)
+
+****************************
+Benchmarking Larceny-r6rs on Wed Nov 14 20:44:56 EST 2007 under Darwin Vesuvius.local 8.10.1 Darwin Kernel Version 8.10.1: Wed May 23 16:33:00 PDT 2007; root:xnu-792.22.5~1/RELEASE_I386 i386 i386
+
+Testing ray under Larceny-r6rs
+Compiling...
+Larceny v0.95 "First Safety" (Nov  8 2007 04:30:20, precise:BSD Unix:unified)
+larceny.heap, built on Thu Nov  8 04:39:44 EST 2007
+
+> 
+> 
+Running...
+Larceny v0.95 "First Safety" (Nov  8 2007 04:30:20, precise:BSD Unix:unified)
+larceny.heap, built on Thu Nov  8 04:39:44 EST 2007
+
+> 
+Words allocated: 220925448
+Words reclaimed: 0
+Elapsed time...: 20776 ms (User: 10963 ms; System: 9734 ms)
+Elapsed GC time: 164 ms (CPU: 166 in 843 collections.)

scheme/ikarus.numerics.ss

@@ -100,7 +100,7 @@
          #f]
         [else ($fl= x ($flround x))])))
 
-  (define ($flonum->integer x)
+  (module ($flonum->integer $flonum->exact)
     (define ($flonum-signed-mantissa x)
       (let ([b0 ($flonum-u8-ref x 0)])
         (let ([m0 ($fx+ ($flonum-u8-ref x 7) 
@@ -119,6 +119,7 @@
               (+ (bitwise-arithmetic-shift-left 
                    ($fx- 0 ($fxlogor m1 ($fxsll m2 24))) 24)
                  ($fx- 0 m0))))))
+    (define ($flonum->integer x)
       (let ([sbe ($flonum-sbe x)])
         (let ([be ($fxlogand sbe #x7FF)])
           (cond
@@ -133,7 +134,44 @@
                  [($fl= x ($fl/ x0 5e-324)) ;;; x == round(x)
                   ($flonum-signed-mantissa x0)]
                  [else #f]))]))))
+    (define ($flonum->exact x)
+      (let ([sbe ($flonum-sbe x)])
+        (let ([be ($fxlogand sbe #x7FF)])
+          (cond
+            [($fx= be 2047) #f] ;;; nans/infs
+            [($fx>= be 1075)    ;;; magnitude large enough to be an integer
+             (bitwise-arithmetic-shift-left 
+               ($flonum-signed-mantissa x)
+               (- be 1075))]
+            [else
+             (let* ([x0 ($fl* x 5e-324)]
+                    [x1 ($fl/ x0 5e-324)])
+               (cond
+                 [($fl= x x1) ;;; x == round(x)
+                  ($flonum-signed-mantissa x0)]
+                 [($fx= be 0) ;;; denormal
+                  (/ ($flonum-signed-mantissa x)
+                     (bitwise-arithmetic-shift-left 1 1074))]
+                 [else ;;; x has a fraction
+                  (let ([v ($flonum-signed-mantissa x)])
+                    (let ([bits (- 1075 be)])
+                      (let ([int (bitwise-arithmetic-shift-right v bits)]
+                            [frac 
+                             (let ([e (bitwise-arithmetic-shift-left 1 bits)])
+                               (/ (bitwise-and v (- e 1)) e))])
+                        (+ int frac))))]))])))))
 
+;;;OLD  (define ($flonum->exact x)
+;;;OLD    ;;; this really needs to get optimized.
+;;;OLD    (let-values ([(pos? be m) (flonum-parts x)])
+;;;OLD      (cond
+;;;OLD        [(<= 1 be 2046) ; normalized flonum
+;;;OLD         (* (if pos? 1 -1)
+;;;OLD            (* (+ m (expt 2 52)) (expt 2 (- be 1075))))]
+;;;OLD        [(= be 0) 
+;;;OLD         (* (if pos? 1 -1) 
+;;;OLD            (* m (expt 2 -1074)))]
+;;;OLD        [else #f])))
 
   (define (flnumerator x) 
     (unless (flonum? x) 
@@ -217,17 +255,6 @@
     (let ([b0 ($flonum-u8-ref x 0)])
       (fx> b0 127)))
 
-  (define ($flonum->exact x)
-    ;;; this really needs to get optimized.
-    (let-values ([(pos? be m) (flonum-parts x)])
-      (cond
-        [(<= 1 be 2046) ; normalized flonum
-         (* (if pos? 1 -1)
-            (* (+ m (expt 2 52)) (expt 2 (- be 1075))))]
-        [(= be 0) 
-         (* (if pos? 1 -1) 
-            (* m (expt 2 -1074)))]
-        [else #f])))