(rounding_driver): New function for systematic support of

2-argument rounding functions, so that `floor' isn't the only one
that supports 2 arguments.
(Fceiling, Ffloor, Fround, Ftruncate): Use it.
(ceiling2, floor2, round2, truncate2, double_identity): New functions.
(syms_of_floatfns): Define ceiling, round, and truncate even if
LISP_FLOAT_TYPE is not defined.

1 files changed, 107 insertions, 75 deletions

diff --git a/src/floatfns.c b/src/floatfns.c
index 452bdc2ea54..1518006c5b2 100644
--- a/src/floatfns.c
+++ b/src/floatfns.c
@@ -722,34 +722,17 @@ This is the same as the exponent of a float.")
   return val;
 }
 
-/* the rounding functions  */
-
-DEFUN ("ceiling", Fceiling, Sceiling, 1, 1, 0,
-  "Return the smallest integer no less than ARG.  (Round toward +inf.)")
-  (arg)
-     register Lisp_Object arg;
-{
-  CHECK_NUMBER_OR_FLOAT (arg, 0);
-
-  if (FLOATP (arg))
-    {
-      double d;
-
-      IN_FLOAT (d = ceil (XFLOAT (arg)->data), "ceiling", arg);
-      FLOAT_TO_INT (d, arg, "ceiling", arg);
-    }
-
-  return arg;
-}
-
 #endif /* LISP_FLOAT_TYPE */
 
 
-DEFUN ("floor", Ffloor, Sfloor, 1, 2, 0,
-  "Return the largest integer no greater than ARG.  (Round towards -inf.)\n\
-With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR.")
-  (arg, divisor)
+/* the rounding functions  */
+
+static Lisp_Object
+rounding_driver (arg, divisor, double_round, int_round2, name)
      register Lisp_Object arg, divisor;
+     double (*double_round) ();
+     EMACS_INT (*int_round2) ();
+     char *name;
 {
   CHECK_NUMBER_OR_FLOAT (arg, 0);
 
@@ -769,8 +752,8 @@ With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR.")
           if (! IEEE_FLOATING_POINT && f2 == 0)
             Fsignal (Qarith_error, Qnil);
 
-          IN_FLOAT2 (f1 = floor (f1 / f2), "floor", arg, divisor);
-          FLOAT_TO_INT2 (f1, arg, "floor", arg, divisor);
+          IN_FLOAT2 (f1 = (*double_round) (f1 / f2), name, arg, divisor);
+          FLOAT_TO_INT2 (f1, arg, name, arg, divisor);
           return arg;
         }
 #endif
@@ -781,13 +764,7 @@ With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR.")
       if (i2 == 0)
         Fsignal (Qarith_error, Qnil);
 
-      /* With C's /, the result is implementation-defined if either operand
-         is negative, so use only nonnegative operands.  */
-      i1 = (i2 < 0
-            ? (i1 <= 0  ?  -i1 / -i2  :  -1 - ((i1 - 1) / -i2))
-            : (i1 < 0  ?  -1 - ((-1 - i1) / i2)  :  i1 / i2));
-
-      XSETINT (arg, i1);
+      XSETINT (arg, (*int_round2) (i1, i2));
       return arg;
     }
 
@@ -795,14 +772,107 @@ With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR.")
   if (FLOATP (arg))
     {
       double d;
-      IN_FLOAT (d = floor (XFLOAT (arg)->data), "floor", arg);
-      FLOAT_TO_INT (d, arg, "floor", arg);
+
+      IN_FLOAT (d = (*double_round) (XFLOAT (arg)->data), name, arg);
+      FLOAT_TO_INT (d, arg, name, arg);
     }
 #endif
 
   return arg;
 }
 
+/* With C's /, the result is implementation-defined if either operand
+   is negative, so take care with negative operands in the following
+   integer functions.  */
+
+static EMACS_INT
+ceiling2 (i1, i2)
+     EMACS_INT i1, i2;
+{
+  return (i2 < 0
+          ? (i1 < 0  ?  ((-1 - i1) / -i2) + 1  :  - (i1 / -i2))
+          : (i1 <= 0  ?  - (-i1 / i2)  :  ((i1 - 1) / i2) + 1));
+}
+
+static EMACS_INT
+floor2 (i1, i2)
+     EMACS_INT i1, i2;
+{
+  return (i2 < 0
+          ? (i1 <= 0  ?  -i1 / -i2  :  -1 - ((i1 - 1) / -i2))
+          : (i1 < 0  ?  -1 - ((-1 - i1) / i2)  :  i1 / i2));
+}
+
+static EMACS_INT
+truncate2 (i1, i2)
+     EMACS_INT i1, i2;
+{
+  return (i2 < 0
+          ? (i1 < 0  ?  -i1 / -i2  :  - (i1 / -i2))
+          : (i1 < 0  ?  - (-i1 / i2)  :  i1 / i2));
+}
+
+static EMACS_INT
+round2 (i1, i2)
+     EMACS_INT i1, i2;
+{
+  /* The C language's division operator gives us one remainder R, but
+     we want the remainder R1 on the other side of 0 if R1 is closer
+     to 0 than R is; because we want to round to even, we also want R1
+     if R and R1 are the same distance from 0 and if C's quotient is
+     odd.  */
+  EMACS_INT q = i1 / i2;
+  EMACS_INT r = i1 % i2;
+  EMACS_INT abs_r = r < 0 ? -r : r;
+  EMACS_INT abs_r1 = (i2 < 0 ? -i2 : i2) - abs_r;
+  return q + (abs_r + (q & 1) <= abs_r1 ? 0 : (i2 ^ r) < 0 ? -1 : 1);
+}
+
+static double
+double_identity (d)
+     double d;
+{
+  return d;
+}
+
+DEFUN ("ceiling", Fceiling, Sceiling, 1, 2, 0,
+  "Return the smallest integer no less than ARG.  (Round toward +inf.)\n\
+With optional DIVISOR, return the smallest integer no less than ARG/DIVISOR.")
+  (arg, divisor)
+     Lisp_Object arg, divisor;
+{
+  return rounding_driver (arg, divisor, ceil, ceiling2, "ceiling");
+}
+
+DEFUN ("floor", Ffloor, Sfloor, 1, 2, 0,
+  "Return the largest integer no greater than ARG.  (Round towards -inf.)\n\
+With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR.")
+  (arg, divisor)
+     Lisp_Object arg, divisor;
+{
+  return rounding_driver (arg, divisor, floor, floor2, "floor");
+}
+
+DEFUN ("round", Fround, Sround, 1, 2, 0,
+  "Return the nearest integer to ARG.\n\
+With optional DIVISOR, return the nearest integer to ARG/DIVISOR.")
+  (arg, divisor)
+     Lisp_Object arg, divisor;
+{
+  return rounding_driver (arg, divisor, rint, round2, "round");
+}
+
+DEFUN ("truncate", Ftruncate, Struncate, 1, 2, 0,
+       "Truncate a floating point number to an int.\n\
+Rounds ARG toward zero.\n\
+With optional DIVISOR, truncate ARG/DIVISOR.")
+  (arg, divisor)
+     Lisp_Object arg, divisor;
+{
+  return rounding_driver (arg, divisor, double_identity, truncate2,
+                          "truncate");
+}
+
 #ifdef LISP_FLOAT_TYPE
 
 Lisp_Object
@@ -823,44 +893,6 @@ fmod_float (x, y)
              "mod", x, y);
   return make_float (f1);
 }
-
-DEFUN ("round", Fround, Sround, 1, 1, 0,
-  "Return the nearest integer to ARG.")
-  (arg)
-     register Lisp_Object arg;
-{
-  CHECK_NUMBER_OR_FLOAT (arg, 0);
-
-  if (FLOATP (arg))
-    {
-      double d;
-
-      /* Screw the prevailing rounding mode.  */
-      IN_FLOAT (d = rint (XFLOAT (arg)->data), "round", arg);
-      FLOAT_TO_INT (d, arg, "round", arg);
-    }
-
-  return arg;
-}
-
-DEFUN ("truncate", Ftruncate, Struncate, 1, 1, 0,
-       "Truncate a floating point number to an int.\n\
-Rounds the value toward zero.")
-  (arg)
-     register Lisp_Object arg;
-{
-  CHECK_NUMBER_OR_FLOAT (arg, 0);
-
-  if (FLOATP (arg))
-    {
-      double d;
-
-      d = XFLOAT (arg)->data;
-      FLOAT_TO_INT (d, arg, "truncate", arg);
-    }
-
-  return arg;
-}
 
 /* It's not clear these are worth adding.  */
 
@@ -1024,9 +1056,9 @@ syms_of_floatfns ()
   defsubr (&Sabs);
   defsubr (&Sfloat);
   defsubr (&Slogb);
+#endif /* LISP_FLOAT_TYPE */
   defsubr (&Sceiling);
+  defsubr (&Sfloor);
   defsubr (&Sround);
   defsubr (&Struncate);
-#endif /* LISP_FLOAT_TYPE */
-  defsubr (&Sfloor);
 }