X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/41790b5a0bc07e44768de62a30ee0d2818e85f24..ecfb39ee8e14337d40328c8248c6d27793798025:/src/floatfns.c diff --git a/src/floatfns.c b/src/floatfns.c index 1b74c786ce..d6cbb876e3 100644 --- a/src/floatfns.c +++ b/src/floatfns.c @@ -1,5 +1,5 @@ /* 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. @@ -25,7 +25,7 @@ Boston, MA 02111-1307, USA. */ 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. @@ -44,13 +44,24 @@ Boston, MA 02111-1307, USA. */ a domain error occurs.) */ -#include - #include +#include #include "lisp.h" #include "syssignal.h" -#ifdef LISP_FLOAT_TYPE +#if STDC_HEADERS +#include +#endif + +/* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */ +#ifndef IEEE_FLOATING_POINT +#if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \ + && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128) +#define IEEE_FLOATING_POINT 1 +#else +#define IEEE_FLOATING_POINT 0 +#endif +#endif /* Work around a problem that happens because math.h on hpux 7 defines two static variables--which, in Emacs, are not really static, @@ -109,10 +120,6 @@ extern int errno; #define sinh(x) ((exp(x)-exp(-x))*0.5) #endif /* VMS */ -#ifndef HAVE_RINT -#define rint(x) (floor((x)+0.5)) -#endif - static SIGTYPE float_error (); /* Nonzero while executing in floating point. @@ -121,7 +128,9 @@ static SIGTYPE float_error (); static int in_float; /* If an argument is out of range for a mathematical function, - here is the actual argument value to use in the error message. */ + here is the actual argument value to use in the error message. + These variables are used only across the floating point library call + so there is no need to staticpro them. */ static Lisp_Object float_error_arg, float_error_arg2; @@ -210,7 +219,7 @@ extract_float (num) CHECK_NUMBER_OR_FLOAT (num, 0); if (FLOATP (num)) - return XFLOAT (num)->data; + return XFLOAT_DATA (num); return (double) XINT (num); } @@ -468,8 +477,8 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, 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; @@ -638,7 +647,7 @@ DEFUN ("abs", Fabs, Sabs, 1, 1, 0, CHECK_NUMBER_OR_FLOAT (arg, 0); 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)); @@ -706,34 +715,15 @@ 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 */ +/* 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); @@ -743,21 +733,19 @@ With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR.") CHECK_NUMBER_OR_FLOAT (divisor, 1); -#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)); - if (f2 == 0) + 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); @@ -765,66 +753,144 @@ 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; } -#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. */ -DEFUN ("round", Fround, Sround, 1, 1, 0, - "Return the nearest integer to ARG.") - (arg) - register Lisp_Object arg; +static EMACS_INT +ceiling2 (i1, i2) + EMACS_INT i1, i2; { - CHECK_NUMBER_OR_FLOAT (arg, 0); + return (i2 < 0 + ? (i1 < 0 ? ((-1 - i1) / -i2) + 1 : - (i1 / -i2)) + : (i1 <= 0 ? - (-i1 / i2) : ((i1 - 1) / i2) + 1)); +} - if (FLOATP (arg)) - { - double d; +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)); +} - /* Screw the prevailing rounding mode. */ - IN_FLOAT (d = rint (XFLOAT (arg)->data), "round", arg); - FLOAT_TO_INT (d, arg, "round", arg); - } +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)); +} - return arg; +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); +} + +/* 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; +{ + return floor (d + 0.5); +} +#endif + +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 ("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); } /* It's not clear these are worth adding. */ @@ -857,12 +923,12 @@ DEFUN ("fround", Ffround, Sfround, 1, 1, 0, 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; @@ -883,7 +949,7 @@ float_error (signo) if (! in_float) fatal_error_signal (signo); -#ifdef BSD +#ifdef BSD_SYSTEM #ifdef BSD4_1 sigrelse (SIGILL); #else /* not BSD4_1 */ @@ -892,7 +958,7 @@ float_error (signo) #else /* Must reestablish handler each time it is called. */ signal (SIGILL, float_error); -#endif /* BSD */ +#endif /* BSD_SYSTEM */ in_float = 0; @@ -934,6 +1000,7 @@ matherr (x) } #endif /* HAVE_MATHERR */ +void init_floatfns () { #ifdef FLOAT_CATCH_SIGILL @@ -942,16 +1009,9 @@ init_floatfns () 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); @@ -990,8 +1050,7 @@ syms_of_floatfns () defsubr (&Sfloat); defsubr (&Slogb); defsubr (&Sceiling); + defsubr (&Sfloor); defsubr (&Sround); defsubr (&Struncate); -#endif /* LISP_FLOAT_TYPE */ - defsubr (&Sfloor); }