X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/6ba93f9d7ba1b20ee69c441ecba2cbb8cce5203c..c7fea3257f7198b8381dc4ec39c1a306042610ce:/src/floatfns.c diff --git a/src/floatfns.c b/src/floatfns.c index 8a555aad64..d5ca50f916 100644 --- a/src/floatfns.c +++ b/src/floatfns.c @@ -1,5 +1,6 @@ /* Primitive operations on floating point for GNU Emacs Lisp interpreter. - Copyright (C) 1988, 1993 Free Software Foundation, Inc. + Copyright (C) 1988, 1993, 1994, 1999, 2002, 2003, 2004, + 2005, 2006 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -15,7 +16,8 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs; see the file COPYING. If not, write to -the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ +the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ /* ANSI C requires only these float functions: @@ -24,7 +26,7 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, 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. @@ -37,27 +39,29 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ (What systems actually do this? Please let us know.) Define FLOAT_CHECK_DOMAIN if the float library doesn't handle errors by - either setting errno, or signalling SIGFPE/SIGILL. Otherwise, domain and + either setting errno, or signaling SIGFPE/SIGILL. Otherwise, domain and range checking will happen before calling the float routines. This has no effect if HAVE_MATHERR is defined (since matherr will be called when a domain error occurs.) */ -#include - #include +#include #include "lisp.h" #include "syssignal.h" -Lisp_Object Qarith_error; - -#ifdef LISP_FLOAT_TYPE +#if STDC_HEADERS +#include +#endif -#ifdef MSDOS -/* These are redefined (correctly, but differently) in values.h. */ -#undef INTBITS -#undef LONGBITS -#undef SHORTBITS +/* 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 @@ -73,18 +77,16 @@ Lisp_Object Qarith_error; #include /* This declaration is omitted on some systems, like Ultrix. */ -#if !defined (HPUX) && defined (HAVE_LOGB) +#if !defined (HPUX) && defined (HAVE_LOGB) && !defined (logb) extern double logb (); -#endif /* not HPUX and HAVE_LOGB */ +#endif /* not HPUX and HAVE_LOGB and no logb macro */ -#ifndef MSDOS #if defined(DOMAIN) && defined(SING) && defined(OVERFLOW) /* If those are defined, then this is probably a `matherr' machine. */ # ifndef HAVE_MATHERR # define HAVE_MATHERR # endif #endif -#endif #ifdef NO_MATHERR #undef HAVE_MATHERR @@ -106,8 +108,10 @@ extern double logb (); #ifdef FLOAT_CHECK_ERRNO # include +#ifndef USE_CRT_DLL extern int errno; #endif +#endif /* Avoid traps on VMS from sinh and cosh. All the other functions set errno instead. */ @@ -119,11 +123,9 @@ 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 - +#ifdef FLOAT_CATCH_SIGILL static SIGTYPE float_error (); +#endif /* Nonzero while executing in floating point. This tells float_error what to do. */ @@ -131,7 +133,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; @@ -182,17 +186,17 @@ static char *float_error_fn_name; #define FLOAT_TO_INT(x, i, name, num) \ do \ { \ - if ((x) >= (1 << (VALBITS-1)) || (x) <= - (1 << (VALBITS-1)) - 1) \ + if (FIXNUM_OVERFLOW_P (x)) \ range_error (name, num); \ - XSET (i, Lisp_Int, (int)(x)); \ + XSETINT (i, (EMACS_INT)(x)); \ } \ while (0) #define FLOAT_TO_INT2(x, i, name, num1, num2) \ do \ { \ - if ((x) >= (1 << (VALBITS-1)) || (x) <= - (1 << (VALBITS-1)) - 1) \ + if (FIXNUM_OVERFLOW_P (x)) \ range_error2 (name, num1, num2); \ - XSET (i, Lisp_Int, (int)(x)); \ + XSETINT (i, (EMACS_INT)(x)); \ } \ while (0) @@ -215,18 +219,18 @@ double extract_float (num) Lisp_Object num; { - CHECK_NUMBER_OR_FLOAT (num, 0); + CHECK_NUMBER_OR_FLOAT (num); - if (XTYPE (num) == Lisp_Float) - return XFLOAT (num)->data; + if (FLOATP (num)) + return XFLOAT_DATA (num); return (double) XINT (num); } /* Trig functions. */ DEFUN ("acos", Facos, Sacos, 1, 1, 0, - "Return the inverse cosine of ARG.") - (arg) + doc: /* Return the inverse cosine of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -239,8 +243,8 @@ DEFUN ("acos", Facos, Sacos, 1, 1, 0, } DEFUN ("asin", Fasin, Sasin, 1, 1, 0, - "Return the inverse sine of ARG.") - (arg) + doc: /* Return the inverse sine of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -252,19 +256,31 @@ DEFUN ("asin", Fasin, Sasin, 1, 1, 0, return make_float (d); } -DEFUN ("atan", Fatan, Satan, 1, 1, 0, - "Return the inverse tangent of ARG.") - (arg) - register Lisp_Object arg; +DEFUN ("atan", Fatan, Satan, 1, 2, 0, + doc: /* Return the inverse tangent of the arguments. +If only one argument Y is given, return the inverse tangent of Y. +If two arguments Y and X are given, return the inverse tangent of Y +divided by X, i.e. the angle in radians between the vector (X, Y) +and the x-axis. */) + (y, x) + register Lisp_Object y, x; { - double d = extract_float (arg); - IN_FLOAT (d = atan (d), "atan", arg); + double d = extract_float (y); + + if (NILP (x)) + IN_FLOAT (d = atan (d), "atan", y); + else + { + double d2 = extract_float (x); + + IN_FLOAT2 (d = atan2 (d, d2), "atan", y, x); + } return make_float (d); } DEFUN ("cos", Fcos, Scos, 1, 1, 0, - "Return the cosine of ARG.") - (arg) + doc: /* Return the cosine of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -273,8 +289,8 @@ DEFUN ("cos", Fcos, Scos, 1, 1, 0, } DEFUN ("sin", Fsin, Ssin, 1, 1, 0, - "Return the sine of ARG.") - (arg) + doc: /* Return the sine of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -283,8 +299,8 @@ DEFUN ("sin", Fsin, Ssin, 1, 1, 0, } DEFUN ("tan", Ftan, Stan, 1, 1, 0, - "Return the tangent of ARG.") - (arg) + doc: /* Return the tangent of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -300,8 +316,8 @@ DEFUN ("tan", Ftan, Stan, 1, 1, 0, #if 0 /* Leave these out unless we find there's a reason for them. */ DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0, - "Return the bessel function j0 of ARG.") - (arg) + doc: /* Return the bessel function j0 of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -310,8 +326,8 @@ DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0, } DEFUN ("bessel-j1", Fbessel_j1, Sbessel_j1, 1, 1, 0, - "Return the bessel function j1 of ARG.") - (arg) + doc: /* Return the bessel function j1 of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -320,21 +336,21 @@ DEFUN ("bessel-j1", Fbessel_j1, Sbessel_j1, 1, 1, 0, } DEFUN ("bessel-jn", Fbessel_jn, Sbessel_jn, 2, 2, 0, - "Return the order N bessel function output jn of ARG.\n\ -The first arg (the order) is truncated to an integer.") - (arg1, arg2) - register Lisp_Object arg1, arg2; + doc: /* Return the order N bessel function output jn of ARG. +The first arg (the order) is truncated to an integer. */) + (n, arg) + register Lisp_Object n, arg; { - int i1 = extract_float (arg1); - double f2 = extract_float (arg2); + int i1 = extract_float (n); + double f2 = extract_float (arg); - IN_FLOAT (f2 = jn (i1, f2), "bessel-jn", arg1); + IN_FLOAT (f2 = jn (i1, f2), "bessel-jn", n); return make_float (f2); } DEFUN ("bessel-y0", Fbessel_y0, Sbessel_y0, 1, 1, 0, - "Return the bessel function y0 of ARG.") - (arg) + doc: /* Return the bessel function y0 of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -343,8 +359,8 @@ DEFUN ("bessel-y0", Fbessel_y0, Sbessel_y0, 1, 1, 0, } DEFUN ("bessel-y1", Fbessel_y1, Sbessel_y1, 1, 1, 0, - "Return the bessel function y1 of ARG.") - (arg) + doc: /* Return the bessel function y1 of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -353,15 +369,15 @@ DEFUN ("bessel-y1", Fbessel_y1, Sbessel_y1, 1, 1, 0, } DEFUN ("bessel-yn", Fbessel_yn, Sbessel_yn, 2, 2, 0, - "Return the order N bessel function output yn of ARG.\n\ -The first arg (the order) is truncated to an integer.") - (arg1, arg2) - register Lisp_Object arg1, arg2; + doc: /* Return the order N bessel function output yn of ARG. +The first arg (the order) is truncated to an integer. */) + (n, arg) + register Lisp_Object n, arg; { - int i1 = extract_float (arg1); - double f2 = extract_float (arg2); + int i1 = extract_float (n); + double f2 = extract_float (arg); - IN_FLOAT (f2 = yn (i1, f2), "bessel-yn", arg1); + IN_FLOAT (f2 = yn (i1, f2), "bessel-yn", n); return make_float (f2); } @@ -370,8 +386,8 @@ The first arg (the order) is truncated to an integer.") #if 0 /* Leave these out unless we see they are worth having. */ DEFUN ("erf", Ferf, Serf, 1, 1, 0, - "Return the mathematical error function of ARG.") - (arg) + doc: /* Return the mathematical error function of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -380,8 +396,8 @@ DEFUN ("erf", Ferf, Serf, 1, 1, 0, } DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0, - "Return the complementary error function of ARG.") - (arg) + doc: /* Return the complementary error function of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -390,8 +406,8 @@ DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0, } DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0, - "Return the log gamma of ARG.") - (arg) + doc: /* Return the log gamma of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -400,8 +416,8 @@ DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0, } DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0, - "Return the cube root of ARG.") - (arg) + doc: /* Return the cube root of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -419,8 +435,8 @@ DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0, #endif DEFUN ("exp", Fexp, Sexp, 1, 1, 0, - "Return the exponential base e of ARG.") - (arg) + doc: /* Return the exponential base e of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -436,24 +452,25 @@ DEFUN ("exp", Fexp, Sexp, 1, 1, 0, } DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, - "Return the exponential X ** Y.") - (arg1, arg2) + doc: /* Return the exponential ARG1 ** ARG2. */) + (arg1, arg2) register Lisp_Object arg1, arg2; { double f1, f2; - CHECK_NUMBER_OR_FLOAT (arg1, 0); - CHECK_NUMBER_OR_FLOAT (arg2, 0); - if (XTYPE (arg1) == Lisp_Int /* common lisp spec */ - && XTYPE (arg2) == Lisp_Int) /* don't promote, if both are ints */ + 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, and */ + && 0 <= XINT (arg2)) /* we are sure the result is not fractional */ { /* this can be improved by pre-calculating */ - int acc, x, y; /* some binary powers of x then accumulating */ + EMACS_INT acc, x, y; /* some binary powers of x then accumulating */ Lisp_Object val; x = XINT (arg1); y = XINT (arg2); acc = 1; - + if (y < 0) { if (x == 1) @@ -473,11 +490,11 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, y = (unsigned)y >> 1; } } - XSET (val, Lisp_Int, acc); + XSETINT (val, acc); return val; } - f1 = (XTYPE (arg1) == Lisp_Float) ? XFLOAT (arg1)->data : XINT (arg1); - f2 = (XTYPE (arg2) == Lisp_Float) ? 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; @@ -490,9 +507,9 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, } DEFUN ("log", Flog, Slog, 1, 2, 0, - "Return the natural logarithm of ARG.\n\ -If second optional argument BASE is given, return log ARG using that base.") - (arg, base) + doc: /* Return the natural logarithm of ARG. +If the optional argument BASE is given, return log ARG using that base. */) + (arg, base) register Lisp_Object arg, base; { double d = extract_float (arg); @@ -520,8 +537,8 @@ If second optional argument BASE is given, return log ARG using that base.") } DEFUN ("log10", Flog10, Slog10, 1, 1, 0, - "Return the logarithm base 10 of ARG.") - (arg) + doc: /* Return the logarithm base 10 of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -534,8 +551,8 @@ DEFUN ("log10", Flog10, Slog10, 1, 1, 0, } DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0, - "Return the square root of ARG.") - (arg) + doc: /* Return the square root of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -550,8 +567,8 @@ DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0, #if 0 /* Not clearly worth adding. */ DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0, - "Return the inverse hyperbolic cosine of ARG.") - (arg) + doc: /* Return the inverse hyperbolic cosine of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -568,8 +585,8 @@ DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0, } DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0, - "Return the inverse hyperbolic sine of ARG.") - (arg) + doc: /* Return the inverse hyperbolic sine of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -582,8 +599,8 @@ DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0, } DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0, - "Return the inverse hyperbolic tangent of ARG.") - (arg) + doc: /* Return the inverse hyperbolic tangent of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -600,8 +617,8 @@ DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0, } DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0, - "Return the hyperbolic cosine of ARG.") - (arg) + doc: /* Return the hyperbolic cosine of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -614,8 +631,8 @@ DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0, } DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0, - "Return the hyperbolic sine of ARG.") - (arg) + doc: /* Return the hyperbolic sine of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -628,8 +645,8 @@ DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0, } DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0, - "Return the hyperbolic tangent of ARG.") - (arg) + doc: /* Return the hyperbolic tangent of ARG. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -639,53 +656,54 @@ DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0, #endif DEFUN ("abs", Fabs, Sabs, 1, 1, 0, - "Return the absolute value of ARG.") - (arg) + doc: /* Return the absolute value of ARG. */) + (arg) register Lisp_Object arg; { - CHECK_NUMBER_OR_FLOAT (arg, 0); + CHECK_NUMBER_OR_FLOAT (arg); - if (XTYPE (arg) == Lisp_Float) - IN_FLOAT (arg = make_float (fabs (XFLOAT (arg)->data)), "abs", arg); + if (FLOATP (arg)) + IN_FLOAT (arg = make_float (fabs (XFLOAT_DATA (arg))), "abs", arg); else if (XINT (arg) < 0) - XSETINT (arg, - XFASTINT (arg)); + XSETINT (arg, - XINT (arg)); return arg; } DEFUN ("float", Ffloat, Sfloat, 1, 1, 0, - "Return the floating point number equal to ARG.") - (arg) + doc: /* Return the floating point number equal to ARG. */) + (arg) register Lisp_Object arg; { - CHECK_NUMBER_OR_FLOAT (arg, 0); + CHECK_NUMBER_OR_FLOAT (arg); - if (XTYPE (arg) == Lisp_Int) + if (INTEGERP (arg)) return make_float ((double) XINT (arg)); else /* give 'em the same float back */ return arg; } DEFUN ("logb", Flogb, Slogb, 1, 1, 0, - "Returns largest integer <= the base 2 log of the magnitude of ARG.\n\ -This is the same as the exponent of a float.") + doc: /* Returns largest integer <= the base 2 log of the magnitude of ARG. +This is the same as the exponent of a float. */) (arg) Lisp_Object arg; { Lisp_Object val; - int value; + EMACS_INT value; double f = extract_float (arg); if (f == 0.0) - value = -(VALMASK >> 1); + value = MOST_NEGATIVE_FIXNUM; else { #ifdef HAVE_LOGB IN_FLOAT (value = logb (f), "logb", arg); #else #ifdef HAVE_FREXP - IN_FLOAT (frexp (f, &value), "logb", arg); - value--; + int ivalue; + IN_FLOAT (frexp (f, &ivalue), "logb", arg); + value = ivalue - 1; #else int i; double d; @@ -709,63 +727,41 @@ This is the same as the exponent of a float.") #endif #endif } - XSET (val, Lisp_Int, value); + XSETINT (val, value); 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 (XTYPE (arg) == Lisp_Float) - { - 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)) { - int i1, i2; + EMACS_INT i1, i2; - CHECK_NUMBER_OR_FLOAT (divisor, 1); + CHECK_NUMBER_OR_FLOAT (divisor); -#ifdef LISP_FLOAT_TYPE - if (XTYPE (arg) == Lisp_Float || XTYPE (divisor) == Lisp_Float) + if (FLOATP (arg) || FLOATP (divisor)) { double f1, f2; - f1 = XTYPE (arg) == Lisp_Float ? XFLOAT (arg)->data : XINT (arg); - f2 = (XTYPE (divisor) == Lisp_Float - ? 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); @@ -773,74 +769,159 @@ 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)); - - XSET (arg, Lisp_Int, i1); + XSETINT (arg, (*int_round2) (i1, i2)); return arg; } -#ifdef LISP_FLOAT_TYPE - if (XTYPE (arg) == Lisp_Float) + 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 (XTYPE (arg) == Lisp_Float) - { - 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); } -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; +/* 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 (XTYPE (arg) == Lisp_Float) - { - double d; +static double +double_identity (d) + double d; +{ + return d; +} - d = XFLOAT (arg)->data; - FLOAT_TO_INT (d, arg, "truncate", arg); - } +DEFUN ("ceiling", Fceiling, Sceiling, 1, 2, 0, + doc: /* Return the smallest integer no less than ARG. +This rounds the value towards +inf. +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, + doc: /* Return the largest integer no greater than ARG. +This rounds the value towards -inf. +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, + doc: /* Return the nearest integer to ARG. +With optional DIVISOR, return the nearest integer to ARG/DIVISOR. + +Rounding a value equidistant between two integers may choose the +integer closer to zero, or it may prefer an even integer, depending on +your machine. For example, \(round 2.5\) can return 3 on some +systems, but 2 on others. */) + (arg, divisor) + Lisp_Object arg, divisor; +{ + return rounding_driver (arg, divisor, emacs_rint, round2, "round"); +} + +DEFUN ("truncate", Ftruncate, Struncate, 1, 2, 0, + doc: /* Truncate a floating point number to an int. +Rounds ARG toward zero. +With optional DIVISOR, truncate ARG/DIVISOR. */) + (arg, divisor) + Lisp_Object arg, divisor; +{ + return rounding_driver (arg, divisor, double_identity, truncate2, + "truncate"); +} + + +Lisp_Object +fmod_float (x, y) + register Lisp_Object x, y; +{ + double f1, f2; + + 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. */ DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0, - "Return the smallest integer no less than ARG, as a float.\n\ -\(Round toward +inf.\)") - (arg) + doc: /* Return the smallest integer no less than ARG, as a float. +\(Round toward +inf.\) */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -849,9 +930,9 @@ DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0, } DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0, - "Return the largest integer no greater than ARG, as a float.\n\ -\(Round towards -inf.\)") - (arg) + doc: /* Return the largest integer no greater than ARG, as a float. +\(Round towards -inf.\) */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -860,19 +941,19 @@ DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0, } DEFUN ("fround", Ffround, Sfround, 1, 1, 0, - "Return the nearest integer to ARG, as a float.") - (arg) + doc: /* Return the nearest integer to ARG, as a float. */) + (arg) 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\ -Rounds the value toward zero.") - (arg) + doc: /* Truncate a floating point number to an integral float value. +Rounds the value toward zero. */) + (arg) register Lisp_Object arg; { double d = extract_float (arg); @@ -891,7 +972,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 */ @@ -900,8 +981,9 @@ float_error (signo) #else /* Must reestablish handler each time it is called. */ signal (SIGILL, float_error); -#endif /* BSD */ +#endif /* BSD_SYSTEM */ + SIGNAL_THREAD_CHECK (signo); in_float = 0; Fsignal (Qarith_error, Fcons (float_error_arg, Qnil)); @@ -913,7 +995,7 @@ float_error (signo) #endif /* FLOAT_CATCH_SIGILL */ #ifdef HAVE_MATHERR -int +int matherr (x) struct exception *x; { @@ -942,24 +1024,18 @@ matherr (x) } #endif /* HAVE_MATHERR */ +void init_floatfns () { #ifdef FLOAT_CATCH_SIGILL signal (SIGILL, float_error); -#endif +#endif 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); @@ -998,8 +1074,10 @@ syms_of_floatfns () defsubr (&Sfloat); defsubr (&Slogb); defsubr (&Sceiling); + defsubr (&Sfloor); defsubr (&Sround); defsubr (&Struncate); -#endif /* LISP_FLOAT_TYPE */ - defsubr (&Sfloor); } + +/* arch-tag: be05bf9d-049e-4e31-91b9-e6153d483ae7 + (do not change this comment) */