fixed rounding for rationals.

scheme/ikarus.numerics.ss

@@ -2644,20 +2644,12 @@
 
   (define ($ratnum-round x)
     (let ([n ($ratnum-n x)] [d ($ratnum-d x)])
-      (let-values ([(q r) (quotient+remainder n d)])
+      (let-values ([(q r) (div-and-mod n d)])
-        (let ([r2 (+ r r)]) 
+        (let ([r2 (+ r r)])
-          (if (> n 0) 
+          (cond
-              (cond
+            [(< r2 d) q]
-                [(< r2 d) q]
+            [(> r2 d) (+ q 1)]
-                [(> r2 d) (+ q 1)]
+            [else (if (even? q) q (+ q 1))])))))
-                [else
-                 (if (even? q) q (+ q 1))])
-              (let ([r2 (- r2)])
-                (cond
-                  [(< r2 d) q]
-                  [(< r2 d) (- q 1)]
-                  [else
-                   (if (even? q) q (- q 1))])))))))
 
   (define ($ratnum-truncate x)
     (let ([n ($ratnum-n x)] [d ($ratnum-d x)])

scheme/last-revision

@@ -1 +1 @@
-1527
+1528

scheme/run-tests.ss

@@ -23,6 +23,7 @@
         (tests bytevectors)
         (tests strings)
         (tests hashtables)
+        (tests numerics)
         ;(tests numbers)
         (tests bignums)
         (tests fixnums)
@@ -53,7 +54,6 @@
   (printf "[exact-integer-sqrt] Happy Happy Joy Joy\n"))
 
 (test-bitwise-op)
-
 (test-parse-flonums)
 (test-case-folding)
 (test-reader)
@@ -67,7 +67,6 @@
 (test-div-and-mod)
 (test-bignums)
 (test-bignum-length)
-
 (test-fxcarry)
 (test-lists)
 (test-hashtables)
@@ -82,4 +81,5 @@
 (test-io)
 (test-sorting)
 (test-fasl)
+(test-numerics)
 (printf "Happy Happy Joy Joy\n")

scheme/tests/numerics.ss

@@ -0,0 +1,39 @@
+
+(library (tests numerics)
+  (export test-numerics)
+  (import (ikarus))
+
+  (define (test-round x)
+    (let ([rx (round x)])
+      (unless (integer? rx)
+        (error 'test-round "not an integer result for" x rx))
+      (let ([diff (abs (- (abs x) (abs rx)))])
+        (cond
+          [(= diff 1/2) 
+           (unless (even? rx)
+             (error 'test-round "non-even rounding for" x rx))]
+          [else
+           (unless (< diff 1/2)
+             (error 'test-round "rounding the wrong way for" x rx))]))))
+
+  (define (test-numerics)
+    (test-round -251/100)
+    (test-round -250/100)
+    (test-round -249/100)
+    (test-round +251/100)
+    (test-round +250/100)
+    (test-round +249/100)
+
+    (test-round -151/100)
+    (test-round -150/100)
+    (test-round -149/100)
+    (test-round +151/100)
+    (test-round +150/100)
+    (test-round +149/100)
+
+    (test-round -351/100)
+    (test-round -350/100)
+    (test-round -349/100)
+    (test-round +351/100)
+    (test-round +350/100)
+    (test-round +349/100)))