/* Primitive operations on floating point for GNU Emacs Lisp interpreter.
- Copyright (C) 1988, 1993, 1994 Free Software Foundation, Inc.
+ Copyright (C) 1988, 1993, 1994, 1999 Free Software Foundation, Inc.
This file is part of GNU Emacs.
Define HAVE_INVERSE_HYPERBOLIC if you have acosh, asinh, and atanh.
Define HAVE_CBRT if you have cbrt.
- Define HAVE_RINT if you have rint.
+ Define HAVE_RINT if you have a working rint.
If you don't define these, then the appropriate routines will be simulated.
Define HAVE_MATHERR if on a system supporting the SysV matherr callback.
a domain error occurs.)
*/
-#include <signal.h>
-
#include <config.h>
+#include <signal.h>
#include "lisp.h"
#include "syssignal.h"
-#ifdef LISP_FLOAT_TYPE
-
#if STDC_HEADERS
#include <float.h>
#endif
#ifdef FLOAT_CHECK_ERRNO
# include <errno.h>
+#ifndef USE_CRT_DLL
extern int errno;
#endif
+#endif
/* Avoid traps on VMS from sinh and cosh.
All the other functions set errno instead. */
#define sinh(x) ((exp(x)-exp(-x))*0.5)
#endif /* VMS */
-#ifndef HAVE_RINT
-#define rint(x) (floor((x)+0.5))
-#endif
-
+#ifdef FLOAT_CATCH_SIGILL
static SIGTYPE float_error ();
+#endif
/* Nonzero while executing in floating point.
This tells float_error what to do. */
#define FLOAT_TO_INT(x, i, name, num) \
do \
{ \
- if ((x) >= (((EMACS_INT) 1) << (VALBITS-1)) || \
- (x) <= - (((EMACS_INT) 1) << (VALBITS-1)) - 1) \
+ if (FIXNUM_OVERFLOW_P (x)) \
range_error (name, num); \
XSETINT (i, (EMACS_INT)(x)); \
} \
#define FLOAT_TO_INT2(x, i, name, num1, num2) \
do \
{ \
- if ((x) >= (((EMACS_INT) 1) << (VALBITS-1)) || \
- (x) <= - (((EMACS_INT) 1) << (VALBITS-1)) - 1) \
+ if (FIXNUM_OVERFLOW_P (x)) \
range_error2 (name, num1, num2); \
XSETINT (i, (EMACS_INT)(x)); \
} \
extract_float (num)
Lisp_Object num;
{
- CHECK_NUMBER_OR_FLOAT (num, 0);
+ CHECK_NUMBER_OR_FLOAT (num);
if (FLOATP (num))
- return XFLOAT (num)->data;
+ return XFLOAT_DATA (num);
return (double) XINT (num);
}
\f
{
double f1, f2;
- CHECK_NUMBER_OR_FLOAT (arg1, 0);
- CHECK_NUMBER_OR_FLOAT (arg2, 0);
+ CHECK_NUMBER_OR_FLOAT (arg1);
+ CHECK_NUMBER_OR_FLOAT (arg2);
if (INTEGERP (arg1) /* common lisp spec */
&& INTEGERP (arg2)) /* don't promote, if both are ints */
{ /* this can be improved by pre-calculating */
XSETINT (val, acc);
return val;
}
- f1 = FLOATP (arg1) ? XFLOAT (arg1)->data : XINT (arg1);
- f2 = FLOATP (arg2) ? XFLOAT (arg2)->data : XINT (arg2);
+ f1 = FLOATP (arg1) ? XFLOAT_DATA (arg1) : XINT (arg1);
+ f2 = FLOATP (arg2) ? XFLOAT_DATA (arg2) : XINT (arg2);
/* Really should check for overflow, too */
if (f1 == 0.0 && f2 == 0.0)
f1 = 1.0;
(arg)
register Lisp_Object arg;
{
- CHECK_NUMBER_OR_FLOAT (arg, 0);
+ CHECK_NUMBER_OR_FLOAT (arg);
if (FLOATP (arg))
- IN_FLOAT (arg = make_float (fabs (XFLOAT (arg)->data)), "abs", arg);
+ IN_FLOAT (arg = make_float (fabs (XFLOAT_DATA (arg))), "abs", arg);
else if (XINT (arg) < 0)
XSETINT (arg, - XINT (arg));
(arg)
register Lisp_Object arg;
{
- CHECK_NUMBER_OR_FLOAT (arg, 0);
+ CHECK_NUMBER_OR_FLOAT (arg);
if (INTEGERP (arg))
return make_float ((double) XINT (arg));
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 */
+/* the rounding functions */
-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)
+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);
+ CHECK_NUMBER_OR_FLOAT (arg);
if (! NILP (divisor))
{
EMACS_INT i1, i2;
- CHECK_NUMBER_OR_FLOAT (divisor, 1);
+ CHECK_NUMBER_OR_FLOAT (divisor);
-#ifdef LISP_FLOAT_TYPE
if (FLOATP (arg) || FLOATP (divisor))
{
double f1, f2;
- f1 = FLOATP (arg) ? XFLOAT (arg)->data : XINT (arg);
- f2 = (FLOATP (divisor) ? XFLOAT (divisor)->data : XINT (divisor));
+ f1 = FLOATP (arg) ? XFLOAT_DATA (arg) : XINT (arg);
+ f2 = (FLOATP (divisor) ? XFLOAT_DATA (divisor) : XINT (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
i1 = XINT (arg);
i2 = XINT (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;
}
-#ifdef LISP_FLOAT_TYPE
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_DATA (arg)), name, arg);
+ FLOAT_TO_INT (d, arg, name, arg);
}
-#endif
return arg;
}
-#ifdef LISP_FLOAT_TYPE
+/* With C's /, the result is implementation-defined if either operand
+ is negative, so take care with negative operands in the following
+ integer functions. */
-Lisp_Object
-fmod_float (x, y)
- register Lisp_Object x, y;
+static EMACS_INT
+ceiling2 (i1, i2)
+ EMACS_INT i1, i2;
{
- double f1, f2;
+ return (i2 < 0
+ ? (i1 < 0 ? ((-1 - i1) / -i2) + 1 : - (i1 / -i2))
+ : (i1 <= 0 ? - (-i1 / i2) : ((i1 - 1) / i2) + 1));
+}
- f1 = FLOATP (x) ? XFLOAT (x)->data : XINT (x);
- f2 = FLOATP (y) ? XFLOAT (y)->data : XINT (y);
+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));
+}
- if (! IEEE_FLOATING_POINT && f2 == 0)
- Fsignal (Qarith_error, Qnil);
+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));
+}
- /* If the "remainder" comes out with the wrong sign, fix it. */
- IN_FLOAT2 ((f1 = fmod (f1, f2),
- f1 = (f2 < 0 ? f1 > 0 : f1 < 0) ? f1 + f2 : f1),
- "mod", x, y);
- return make_float (f1);
+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);
}
-DEFUN ("round", Fround, Sround, 1, 1, 0,
- "Return the nearest integer to ARG.")
- (arg)
- register Lisp_Object arg;
+/* The code uses emacs_rint, so that it works to undefine HAVE_RINT
+ if `rint' exists but does not work right. */
+#ifdef HAVE_RINT
+#define emacs_rint rint
+#else
+static double
+emacs_rint (d)
+ double d;
{
- CHECK_NUMBER_OR_FLOAT (arg, 0);
+ return floor (d + 0.5);
+}
+#endif
- if (FLOATP (arg))
- {
- double d;
+static double
+double_identity (d)
+ double d;
+{
+ return d;
+}
- /* Screw the prevailing rounding mode. */
- IN_FLOAT (d = rint (XFLOAT (arg)->data), "round", arg);
- FLOAT_TO_INT (d, arg, "round", arg);
- }
+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");
+}
- return arg;
+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 ("truncate", Ftruncate, Struncate, 1, 1, 0,
+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, emacs_rint, round2, "round");
+}
+
+DEFUN ("truncate", Ftruncate, Struncate, 1, 2, 0,
"Truncate a floating point number to an int.\n\
-Rounds the value toward zero.")
- (arg)
- register Lisp_Object arg;
+Rounds ARG toward zero.\n\
+With optional DIVISOR, truncate ARG/DIVISOR.")
+ (arg, divisor)
+ Lisp_Object arg, divisor;
{
- CHECK_NUMBER_OR_FLOAT (arg, 0);
+ return rounding_driver (arg, divisor, double_identity, truncate2,
+ "truncate");
+}
- if (FLOATP (arg))
- {
- double d;
- d = XFLOAT (arg)->data;
- FLOAT_TO_INT (d, arg, "truncate", arg);
- }
+Lisp_Object
+fmod_float (x, y)
+ register Lisp_Object x, y;
+{
+ double f1, f2;
- return arg;
+ f1 = FLOATP (x) ? XFLOAT_DATA (x) : XINT (x);
+ f2 = FLOATP (y) ? XFLOAT_DATA (y) : XINT (y);
+
+ if (! IEEE_FLOATING_POINT && f2 == 0)
+ Fsignal (Qarith_error, Qnil);
+
+ /* If the "remainder" comes out with the wrong sign, fix it. */
+ IN_FLOAT2 ((f1 = fmod (f1, f2),
+ f1 = (f2 < 0 ? f1 > 0 : f1 < 0) ? f1 + f2 : f1),
+ "mod", x, y);
+ return make_float (f1);
}
\f
/* It's not clear these are worth adding. */
register Lisp_Object arg;
{
double d = extract_float (arg);
- IN_FLOAT (d = rint (d), "fround", arg);
+ IN_FLOAT (d = emacs_rint (d), "fround", arg);
return make_float (d);
}
DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0,
- "Truncate a floating point number to an integral float value.\n\
+ "Truncate a floating point number to an integral float value.\n\
Rounds the value toward zero.")
(arg)
register Lisp_Object arg;
}
#endif /* HAVE_MATHERR */
+void
init_floatfns ()
{
#ifdef FLOAT_CATCH_SIGILL
in_float = 0;
}
-#else /* not LISP_FLOAT_TYPE */
-
-init_floatfns ()
-{}
-
-#endif /* not LISP_FLOAT_TYPE */
-
+void
syms_of_floatfns ()
{
-#ifdef LISP_FLOAT_TYPE
defsubr (&Sacos);
defsubr (&Sasin);
defsubr (&Satan);
defsubr (&Sfloat);
defsubr (&Slogb);
defsubr (&Sceiling);
+ defsubr (&Sfloor);
defsubr (&Sround);
defsubr (&Struncate);
-#endif /* LISP_FLOAT_TYPE */
- defsubr (&Sfloor);
}
HCoop / bpt / emacs.git / blobdiff