From 1aff5cbf9c7c79c1deb58d6b985f2bd03c51a4ba Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Sat, 25 Feb 2017 05:09:34 -0800
Subject: Adding round function.

* arith.c (round1): New static function.
(roundiv): New function.

* configure: New test for C99 round function.

* eval.c (eval_init): Register round intrinsic.

* txr.1: Documented.
---
 arith.c   | 60 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 configure | 19 +++++++++++++++++++
 eval.c    |  1 +
 lib.h     |  1 +
 txr.1     | 29 +++++++++++++++++++++++++----
 5 files changed, 106 insertions(+), 4 deletions(-)

diff --git a/arith.c b/arith.c
index 3bded75b..36ecad20 100644
--- a/arith.c
+++ b/arith.c
@@ -1231,6 +1231,66 @@ val ceildiv(val anum, val bnum)
   return neg(floordiv(neg(anum), bnum));
 }
 
+static val round1(val num)
+{
+  switch (type(num)) {
+  case NUM:
+  case BGNUM:
+    return num;
+  case FLNUM:
+#if HAVE_ROUND
+    return flo(round(c_flo(num)));
+#else
+    {
+      double n = c_flo(num);
+      return if3(n >= 0,
+                 flo(floor(0.5 + n)),
+                 flo(-floor(0.5 + fabs(n))));
+    }
+#endif
+  case RNG:
+    return rcons(round1(from(num)), round1(to(num)));
+  default:
+    break;
+  }
+  uw_throwf(error_s, lit("round: invalid operand ~s"), num);
+}
+
+
+val roundiv(val anum, val bnum)
+{
+  if (missingp(bnum))
+    return round1(anum);
+
+  if (minusp(bnum)) {
+    anum = neg(anum);
+    bnum = neg(bnum);
+  }
+
+  if (rangep(anum)) {
+    return rcons(roundiv(from(anum), bnum), roundiv(to(anum), bnum));
+  } else if (floatp(anum) || floatp(bnum)) {
+    val quot = divi(anum, bnum);
+#if HAVE_ROUND
+    return flo(round(c_flo(quot)));
+#else
+    {
+      double q = c_flo(quot);
+      return if3(q >= 0,
+                 flo(floor(0.5 + q)),
+                 flo(-ceil(0.5 + fabs(q))));
+    }
+#endif
+  } else {
+    val quot = floordiv(anum, bnum);
+    val rem = minus(anum, mul(quot, bnum));
+    val drem = ash(rem, one);
+    return if3(eq(drem, bnum),
+               if3(minusp(quot), quot, succ(quot)),
+               if3(lt(drem, bnum), quot, succ(quot)));
+  }
+}
+
 val wrap_star(val start, val end, val num)
 {
   val modulus = minus(end, start);
diff --git a/configure b/configure
index fe9aa954..7f7686df 100755
--- a/configure
+++ b/configure
@@ -2128,6 +2128,25 @@ else
   printf "no\n"
 fi
 
+printf "Checking for round ... "
+cat > conftest.c <<!
+#include <math.h>
+
+int main(void)
+{
+  double x = round(0.5);
+  return 0;
+}
+!
+if conftest ; then
+  printf "yes\n"
+  printf "#define HAVE_ROUND 1\n" >> $config_h
+else
+  printf "no\n"
+fi
+
+
+
 printf "Checking for glob ... "
 
 cat > conftest.c <<!
diff --git a/eval.c b/eval.c
index 41dd8e24..0312292a 100644
--- a/eval.c
+++ b/eval.c
@@ -5704,6 +5704,7 @@ void eval_init(void)
   reg_fun(intern(lit("lcm"), user_package), func_n0v(lcmv));
   reg_fun(intern(lit("floor"), user_package), func_n2o(floordiv, 1));
   reg_fun(intern(lit("ceil"), user_package), func_n2o(ceildiv, 1));
+  reg_fun(intern(lit("round"), user_package), func_n2o(roundiv, 1));
   reg_fun(intern(lit("sin"), user_package), func_n1(sine));
   reg_fun(intern(lit("cos"), user_package), func_n1(cosi));
   reg_fun(intern(lit("tan"), user_package), func_n1(tang));
diff --git a/lib.h b/lib.h
index 6162c84f..590a912d 100644
--- a/lib.h
+++ b/lib.h
@@ -682,6 +682,7 @@ val floorf(val);
 val floordiv(val, val);
 val ceili(val);
 val ceildiv(val anum, val bnum);
+val roundiv(val anum, val bnum);
 val sine(val);
 val cosi(val);
 val tang(val);
diff --git a/txr.1 b/txr.1
index 43cf2bf4..58eaf73e 100644
--- a/txr.1
+++ b/txr.1
@@ -31688,16 +31688,18 @@ is positive, it is returned. If
 is negative, its additive inverse is
 returned: a positive number of the same type with exactly the same magnitude.
 
-.coNP Functions @ floor and @ ceil
+.coNP Functions @, floor @ ceil and @ round
 .synb
 .mets (floor < dividend <> [ divisor ])
 .mets (ceil < dividend <> [ divisor ])
+.mets (round < dividend <> [ divisor ])
 .syne
 .desc
 The
-.code floor
-and
+.codn floor ,
 .code ceiling
+and
+.code round
 functions perform division of the
 .meta dividend
 by the
@@ -31739,12 +31741,31 @@ of the quotient.
 does not exceed the value of
 .metn dividend .
 That is to say, the division is truncated to an integer
-value toward positive infinity.
+value toward positive infinity. The
+.code round
+function returns the nearest integer to the quotient.
+Exact halfway cases are rounded to the integer away from
+zero so that
+.code "(round -1 2)"
+yields
+.code -1
+and
+.code "(round 1 2)"
+yields 1,
 
 Note that for large floating point values, due to the limited
 precision, the integer value corresponding to the mathematical
 floor or ceiling may not be available.
 
+.TP* "Dialect note:"
+In ANSI Common Lisp, the
+.code round
+function chooses the nearest even integer, rather than
+rounding halfway cases away from zero. \*(TX's choice
+harmonizes with the semantics of the
+.code round
+function in the C language.
+
 .coNP Functions @, sin @, cos @, tan @, asin @, acos @ atan and @ atan2
 .synb
 .mets (sin << radians )
-- 
cgit v1.2.3