From 1d25a3db07ab618bad2924e3f861983b6fdc656a Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Fri, 6 Feb 2009 23:46:12 +0300
Subject: [PATCH] fixed rounding error for flonums (now rounding to even as
 required).

---
 scheme/ikarus.numerics.ss | 32 ++++++++++++++++++++++++++++++--
 scheme/last-revision      |  2 +-
 scheme/tests/numerics.ss  | 33 ++++++++++++++++++++++++++++++++-
 3 files changed, 63 insertions(+), 4 deletions(-)

diff --git a/scheme/ikarus.numerics.ss b/scheme/ikarus.numerics.ss
index 81ca0b5..e7e0361 100644
--- a/scheme/ikarus.numerics.ss
+++ b/scheme/ikarus.numerics.ss
@@ -92,11 +92,39 @@
               ($fx= ($flonum-u8-ref x 1) 0))]
         [($fx< be ($fx+ 1075 -52)) ;;; too small to be an integer
          #f]
-        [else ($fl= x ($flround x))])))
+        [else ($fl= x ($$flround x))])))
 
 
+  (define ($$flround x)
+    (foreign-call "ikrt_fl_round" x ($make-flonum)))
+
   (define ($flround x) 
-    (foreign-call "ikrt_fl_round" x ($make-flonum)))
+    ;;; optimize for integer flonums case
+    (define (ratnum-round n nbe)
+      (let ([d (sll 1 nbe)])
+        (let ([q (sra n nbe)]
+              [r (bitwise-and n (sub1 d))])
+          (let ([r2 (+ r r)])
+            (cond
+              [(< r2 d) q]
+              [(> r2 d) (+ q 1)]
+              [else (if (even? q) q (+ q 1))])))))
+    (let ([sbe ($flonum-sbe x)])
+      (let ([be ($fxlogand sbe #x7FF)])
+        (cond
+          ;;; nans/infs/magnitude large enough to be an integer
+          [($fx>= be 1075) x]
+          [else
+           ;;; this really needs to get optimized.
+           (let-values ([(pos? be m) (flonum-parts x)])
+             (cond
+               [(= be 0) ;;; denormalized
+                (if pos? +0.0 -0.0)]
+               [else ; normalized flonum
+                (let ([r 
+                       (inexact 
+                         (ratnum-round (+ m (expt 2 52)) (- 1075 be)))])
+                  (if pos? r ($fl* r -1.0)))]))]))))
 
   (define (flround x)
     (if (flonum? x)
diff --git a/scheme/last-revision b/scheme/last-revision
index a8c5937..2a81cfe 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1745
+1746
diff --git a/scheme/tests/numerics.ss b/scheme/tests/numerics.ss
index 69d90e0..f8d5f97 100644
--- a/scheme/tests/numerics.ss
+++ b/scheme/tests/numerics.ss
@@ -35,7 +35,38 @@
     (test-round -349/100)
     (test-round +351/100)
     (test-round +350/100)
-    (test-round +349/100))
+    (test-round +349/100)
+    
+    (test-round +0.00)
+    (test-round -0.00)
+    (test-round +0.49)
+    (test-round -0.49)
+    (test-round +1.49)
+    (test-round -1.49)
+    (test-round +2.49)
+    (test-round -2.49)
+    (test-round +3.49)
+    (test-round -3.49)
+    (test-round +0.51)
+    (test-round -0.51)
+    (test-round +1.51)
+    (test-round -1.51)
+    (test-round +2.51)
+    (test-round -2.51)
+    (test-round +3.51)
+    (test-round -3.51)
+    (test-round +0.50)
+    (test-round -0.50)
+    (test-round +1.50)
+    (test-round -1.50)
+    (test-round +2.50)
+    (test-round -2.50)
+    (test-round +3.50)
+    (test-round -3.50)
+
+
+
+    )
 
   (define (test-eqv)
     (define (test-eqv x y result)