Merge pull request #524 from yorickhardy/master

Implement r7rs round to even behaviour for half integers

4 files changed, 11 insertions, 2 deletions

diff --git a/include/cyclone/runtime.h b/include/cyclone/runtime.h
index 82608b30..432be667 100644
--- a/include/cyclone/runtime.h
+++ b/include/cyclone/runtime.h
@@ -504,6 +504,7 @@ int Cyc_have_mstreams();
   } \
   return_closcall1(data, cont, &d)
 
+double round_to_nearest_even(double);
 void Cyc_exact(void *data, object cont, object z);
 object Cyc_exact_no_cps(void *data, object ptr, object z);
 
diff --git a/runtime.c b/runtime.c
index 3448cecb..59143b47 100644
--- a/runtime.c
+++ b/runtime.c
@@ -8765,6 +8765,11 @@ int num2ratio(double x, double *numerator, double *denominator)
   return 0;
 }
 
+double round_to_nearest_even(double x)
+{
+ return x-remainder(x,1.0);
+}
+
 /**
  * Receive a Scheme number and pass requested portion of a rational number to
  * the continuation `cont`. Pass numerator if `numerator` is true, else the
diff --git a/scheme/base.sld b/scheme/base.sld
index 669b8cde..ae585953 100644
--- a/scheme/base.sld
+++ b/scheme/base.sld
@@ -1372,9 +1372,9 @@
     " return_double_op_no_cps(data, ptr, trunc, z);")
   (define-c round
     "(void *data, int argc, closure _, object k, object z)"
-    " return_double_op(data, k, round, z); "
+    " return_double_op(data, k, round_to_nearest_even, z); "
     "(void *data, object ptr, object z)"
-    " return_double_op_no_cps(data, ptr, round, z);")
+    " return_double_op_no_cps(data, ptr, round_to_nearest_even, z);")
   (define-c exact
     "(void *data, int argc, closure _, object k, object z)"
     " Cyc_exact(data, k, z); "
diff --git a/tests/base.scm b/tests/base.scm
index 3fea3896..fdd366fe 100644
--- a/tests/base.scm
+++ b/tests/base.scm
@@ -91,6 +91,9 @@
   (test 4.0  (ceiling 3.5))
   (test 3.0  (truncate 3.5))
   (test 4.0  (round 3.5))
+  (test 2.0  (round 2.5))
+  (test -4.0 (round -3.5))
+  (test -2.0 (round -2.5))
   (test 4.0  (round 7/2)) ;; Rationals not supported, so result is inexact
   (test 7    (round 7))