X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/f6196b87e1ceee0d56f2fe6f3aa2b9d1d82c44b0..6bc76cee212aab0a2c02f8c28213fc842cc7880f:/src/floatfns.c diff --git a/src/floatfns.c b/src/floatfns.c index 8a9a9fd088..ac0447ce6d 100644 --- a/src/floatfns.c +++ b/src/floatfns.c @@ -1,7 +1,7 @@ /* Primitive operations on floating point for GNU Emacs Lisp interpreter. -Copyright (C) 1988, 1993-1994, 1999, 2001-2012 - Free Software Foundation, Inc. +Copyright (C) 1988, 1993-1994, 1999, 2001-2014 Free Software Foundation, +Inc. Author: Wolfgang Rupprecht (according to ack.texi) @@ -22,30 +22,45 @@ You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see . */ -/* C89 requires only these math.h functions: - acos, asin, atan, atan2, ceil, cos, cosh, exp, fabs, floor, fmod, - frexp, ldexp, log, log10, modf, pow, sin, sinh, sqrt, tan, tanh. +/* C89 requires only the following math.h functions, and Emacs omits + the starred functions since we haven't found a use for them: + acos, asin, atan, atan2, ceil, cos, *cosh, exp, fabs, floor, fmod, + frexp, ldexp, log, log10 [via (log X 10)], *modf, pow, sin, *sinh, + sqrt, tan, *tanh. + + C99 and C11 require the following math.h functions in addition to + the C89 functions. Of these, Emacs currently exports only the + starred ones to Lisp, since we haven't found a use for the others: + acosh, atanh, cbrt, *copysign, erf, erfc, exp2, expm1, fdim, fma, + fmax, fmin, fpclassify, hypot, ilogb, isfinite, isgreater, + isgreaterequal, isinf, isless, islessequal, islessgreater, *isnan, + isnormal, isunordered, lgamma, log1p, *log2 [via (log X 2)], *logb + (approximately), lrint/llrint, lround/llround, nan, nearbyint, + nextafter, nexttoward, remainder, remquo, *rint, round, scalbln, + scalbn, signbit, tgamma, trunc. */ #include -#include -#include "lisp.h" -#include "syssignal.h" -#include -#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 +#include "lisp.h" #include -/* This declaration is omitted on some systems, like Ultrix. */ -#if !defined (HPUX) && defined (HAVE_LOGB) && !defined (logb) -extern double logb (double); -#endif /* not HPUX and HAVE_LOGB and no logb macro */ +/* 'isfinite' and 'isnan' cause build failures on Solaris 10 with the + bundled GCC in c99 mode. Work around the bugs with simple + implementations that are good enough. */ +#undef isfinite +#define isfinite(x) ((x) - (x) == 0) +#undef isnan +#define isnan(x) ((x) != (x)) + +/* Check that X is a floating point number. */ + +static void +CHECK_FLOAT (Lisp_Object x) +{ + CHECK_TYPE (FLOATP (x), Qfloatp, x); +} /* Extract a Lisp number as a `double', or signal an error. */ @@ -126,9 +141,6 @@ DEFUN ("tan", Ftan, Stan, 1, 1, 0, return make_float (d); } -#undef isnan -#define isnan(x) ((x) != (x)) - DEFUN ("isnan", Fisnan, Sisnan, 1, 1, 0, doc: /* Return non nil iff argument X is a NaN. */) (Lisp_Object x) @@ -153,6 +165,7 @@ Cause an error if X1 or X2 is not a float. */) return make_float (copysign (f1, f2)); } +#endif DEFUN ("frexp", Ffrexp, Sfrexp, 1, 1, 0, doc: /* Get significand and exponent of a floating point number. @@ -167,15 +180,9 @@ If X is zero, both parts (SGNFCAND and EXP) are zero. */) (Lisp_Object x) { double f = XFLOATINT (x); - - if (f == 0.0) - return Fcons (make_float (0.0), make_number (0)); - else - { - int exponent; - double sgnfcand = frexp (f, &exponent); - return Fcons (make_float (sgnfcand), make_number (exponent)); - } + int exponent; + double sgnfcand = frexp (f, &exponent); + return Fcons (make_float (sgnfcand), make_number (exponent)); } DEFUN ("ldexp", Fldexp, Sldexp, 1, 2, 0, @@ -187,118 +194,6 @@ Returns the floating point value resulting from multiplying SGNFCAND CHECK_NUMBER (exponent); return make_float (ldexp (XFLOATINT (sgnfcand), XINT (exponent))); } -#endif - -#if 0 /* Leave these out unless we find there's a reason for them. */ - -DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0, - doc: /* Return the bessel function j0 of ARG. */) - (Lisp_Object arg) -{ - double d = extract_float (arg); - d = j0 (d); - return make_float (d); -} - -DEFUN ("bessel-j1", Fbessel_j1, Sbessel_j1, 1, 1, 0, - doc: /* Return the bessel function j1 of ARG. */) - (Lisp_Object arg) -{ - double d = extract_float (arg); - d = j1 (d); - return make_float (d); -} - -DEFUN ("bessel-jn", Fbessel_jn, Sbessel_jn, 2, 2, 0, - doc: /* Return the order N bessel function output jn of ARG. -The first arg (the order) is truncated to an integer. */) - (Lisp_Object n, Lisp_Object arg) -{ - int i1 = extract_float (n); - double f2 = extract_float (arg); - - f2 = jn (i1, f2); - return make_float (f2); -} - -DEFUN ("bessel-y0", Fbessel_y0, Sbessel_y0, 1, 1, 0, - doc: /* Return the bessel function y0 of ARG. */) - (Lisp_Object arg) -{ - double d = extract_float (arg); - d = y0 (d); - return make_float (d); -} - -DEFUN ("bessel-y1", Fbessel_y1, Sbessel_y1, 1, 1, 0, - doc: /* Return the bessel function y1 of ARG. */) - (Lisp_Object arg) -{ - double d = extract_float (arg); - d = y1 (d); - return make_float (d); -} - -DEFUN ("bessel-yn", Fbessel_yn, Sbessel_yn, 2, 2, 0, - doc: /* Return the order N bessel function output yn of ARG. -The first arg (the order) is truncated to an integer. */) - (Lisp_Object n, Lisp_Object arg) -{ - int i1 = extract_float (n); - double f2 = extract_float (arg); - - f2 = yn (i1, f2); - return make_float (f2); -} - -#endif - -#if 0 /* Leave these out unless we see they are worth having. */ - -DEFUN ("erf", Ferf, Serf, 1, 1, 0, - doc: /* Return the mathematical error function of ARG. */) - (Lisp_Object arg) -{ - double d = extract_float (arg); - d = erf (d); - return make_float (d); -} - -DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0, - doc: /* Return the complementary error function of ARG. */) - (Lisp_Object arg) -{ - double d = extract_float (arg); - d = erfc (d); - return make_float (d); -} - -DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0, - doc: /* Return the log gamma of ARG. */) - (Lisp_Object arg) -{ - double d = extract_float (arg); - d = lgamma (d); - return make_float (d); -} - -DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0, - doc: /* Return the cube root of ARG. */) - (Lisp_Object arg) -{ - double d = extract_float (arg); -#ifdef HAVE_CBRT - d = cbrt (d); -#else - if (d >= 0.0) - d = pow (d, 1.0/3.0); - else - d = -pow (-d, 1.0/3.0); -#endif - return make_float (d); -} - -#endif DEFUN ("exp", Fexp, Sexp, 1, 1, 0, doc: /* Return the exponential base e of ARG. */) @@ -319,7 +214,7 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, 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 */ + && XINT (arg2) >= 0) /* we are sure the result is not fractional */ { /* this can be improved by pre-calculating */ EMACS_INT y; /* some binary powers of x then accumulating */ EMACS_UINT acc, x; /* Unsigned so that overflow is well defined. */ @@ -359,21 +254,16 @@ If the optional argument BASE is given, return log ARG using that base. */) if (b == 10.0) d = log10 (d); +#if HAVE_LOG2 + else if (b == 2.0) + d = log2 (d); +#endif else d = log (d) / log (b); } return make_float (d); } -DEFUN ("log10", Flog10, Slog10, 1, 1, 0, - doc: /* Return the logarithm base 10 of ARG. */) - (Lisp_Object arg) -{ - double d = extract_float (arg); - d = log10 (d); - return make_float (d); -} - DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0, doc: /* Return the square root of ARG. */) (Lisp_Object arg) @@ -383,63 +273,6 @@ DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0, return make_float (d); } -#if 0 /* Not clearly worth adding. */ - -DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0, - doc: /* Return the inverse hyperbolic cosine of ARG. */) - (Lisp_Object arg) -{ - double d = extract_float (arg); - d = acosh (d); - return make_float (d); -} - -DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0, - doc: /* Return the inverse hyperbolic sine of ARG. */) - (Lisp_Object arg) -{ - double d = extract_float (arg); - d = asinh (d); - return make_float (d); -} - -DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0, - doc: /* Return the inverse hyperbolic tangent of ARG. */) - (Lisp_Object arg) -{ - double d = extract_float (arg); - d = atanh (d); - return make_float (d); -} - -DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0, - doc: /* Return the hyperbolic cosine of ARG. */) - (Lisp_Object arg) -{ - double d = extract_float (arg); - d = cosh (d); - return make_float (d); -} - -DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0, - doc: /* Return the hyperbolic sine of ARG. */) - (Lisp_Object arg) -{ - double d = extract_float (arg); - d = sinh (d); - return make_float (d); -} - -DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0, - doc: /* Return the hyperbolic tangent of ARG. */) - (Lisp_Object arg) -{ - double d = extract_float (arg); - d = tanh (d); - return make_float (d); -} -#endif - DEFUN ("abs", Fabs, Sabs, 1, 1, 0, doc: /* Return the absolute value of ARG. */) (register Lisp_Object arg) @@ -477,16 +310,15 @@ This is the same as the exponent of a float. */) if (f == 0.0) value = MOST_NEGATIVE_FIXNUM; - else + else if (isfinite (f)) { -#ifdef HAVE_LOGB - value = logb (f); -#else int ivalue; frexp (f, &ivalue); value = ivalue - 1; -#endif } + else + value = MOST_POSITIVE_FIXNUM; + XSETINT (val, value); return val; } @@ -583,8 +415,8 @@ round2 (EMACS_INT i1, EMACS_INT i2) 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; + EMACS_INT abs_r = eabs (r); + EMACS_INT abs_r1 = eabs (i2) - abs_r; return q + (abs_r + (q & 1) <= abs_r1 ? 0 : (i2 ^ r) < 0 ? -1 : 1); } @@ -596,7 +428,9 @@ round2 (EMACS_INT i1, EMACS_INT i2) static double emacs_rint (double d) { - return floor (d + 0.5); + double d1 = d + 0.5; + double r = floor (d1); + return r - (r == d1 && fmod (r, 2) != 0); } #endif @@ -659,7 +493,7 @@ fmod_float (Lisp_Object x, Lisp_Object y) f1 = fmod (f1, f2); /* If the "remainder" comes out with the wrong sign, fix it. */ - if (f2 < 0 ? 0 < f1 : f1 < 0) + if (f2 < 0 ? f1 > 0 : f1 < 0) f1 += f2; return make_float (f1); @@ -719,27 +553,9 @@ syms_of_floatfns (void) defsubr (&Sisnan); #ifdef HAVE_COPYSIGN defsubr (&Scopysign); +#endif defsubr (&Sfrexp); defsubr (&Sldexp); -#endif -#if 0 - defsubr (&Sacosh); - defsubr (&Sasinh); - defsubr (&Satanh); - defsubr (&Scosh); - defsubr (&Ssinh); - defsubr (&Stanh); - defsubr (&Sbessel_y0); - defsubr (&Sbessel_y1); - defsubr (&Sbessel_yn); - defsubr (&Sbessel_j0); - defsubr (&Sbessel_j1); - defsubr (&Sbessel_jn); - defsubr (&Serf); - defsubr (&Serfc); - defsubr (&Slog_gamma); - defsubr (&Scube_root); -#endif defsubr (&Sfceiling); defsubr (&Sffloor); defsubr (&Sfround); @@ -747,7 +563,6 @@ syms_of_floatfns (void) defsubr (&Sexp); defsubr (&Sexpt); defsubr (&Slog); - defsubr (&Slog10); defsubr (&Ssqrt); defsubr (&Sabs);