diff options
| author | Eli Zaretskii | 2013-09-05 11:01:04 +0300 |
|---|---|---|
| committer | Eli Zaretskii | 2013-09-05 11:01:04 +0300 |
| commit | 41306318777a942420bc4feadbfacf662ea179dc (patch) | |
| tree | 669e5cca02f95d6064ce73c0d3fbbf91b8c8b563 /src/floatfns.c | |
| parent | 141f1ff7a40cda10f0558e891dd196a943a5082e (diff) | |
| parent | 257b3b03cb1cff917e0b3b7832ad3eab5b59f257 (diff) | |
| download | emacs-41306318777a942420bc4feadbfacf662ea179dc.tar.gz emacs-41306318777a942420bc4feadbfacf662ea179dc.zip | |
Merge from trunk after a lot of time.
Diffstat (limited to 'src/floatfns.c')
| -rw-r--r-- | src/floatfns.c | 675 |
1 files changed, 91 insertions, 584 deletions
diff --git a/src/floatfns.c b/src/floatfns.c index eaa1b32eb17..f3d0936f888 100644 --- a/src/floatfns.c +++ b/src/floatfns.c | |||
| @@ -1,7 +1,7 @@ | |||
| 1 | /* Primitive operations on floating point for GNU Emacs Lisp interpreter. | 1 | /* Primitive operations on floating point for GNU Emacs Lisp interpreter. |
| 2 | 2 | ||
| 3 | Copyright (C) 1988, 1993-1994, 1999, 2001-2012 | 3 | Copyright (C) 1988, 1993-1994, 1999, 2001-2013 Free Software Foundation, |
| 4 | Free Software Foundation, Inc. | 4 | Inc. |
| 5 | 5 | ||
| 6 | Author: Wolfgang Rupprecht | 6 | Author: Wolfgang Rupprecht |
| 7 | (according to ack.texi) | 7 | (according to ack.texi) |
| @@ -22,172 +22,44 @@ You should have received a copy of the GNU General Public License | |||
| 22 | along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ | 22 | along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ |
| 23 | 23 | ||
| 24 | 24 | ||
| 25 | /* ANSI C requires only these float functions: | 25 | /* C89 requires only the following math.h functions, and Emacs omits |
| 26 | acos, asin, atan, atan2, ceil, cos, cosh, exp, fabs, floor, fmod, | 26 | the starred functions since we haven't found a use for them: |
| 27 | frexp, ldexp, log, log10, modf, pow, sin, sinh, sqrt, tan, tanh. | 27 | acos, asin, atan, atan2, ceil, cos, *cosh, exp, fabs, floor, fmod, |
| 28 | 28 | frexp, ldexp, log, log10 [via (log X 10)], *modf, pow, sin, *sinh, | |
| 29 | Define HAVE_INVERSE_HYPERBOLIC if you have acosh, asinh, and atanh. | 29 | sqrt, tan, *tanh. |
| 30 | Define HAVE_CBRT if you have cbrt. | 30 | |
| 31 | Define HAVE_RINT if you have a working rint. | 31 | C99 and C11 require the following math.h functions in addition to |
| 32 | If you don't define these, then the appropriate routines will be simulated. | 32 | the C89 functions. Of these, Emacs currently exports only the |
| 33 | 33 | starred ones to Lisp, since we haven't found a use for the others: | |
| 34 | Define HAVE_MATHERR if on a system supporting the SysV matherr callback. | 34 | acosh, atanh, cbrt, *copysign, erf, erfc, exp2, expm1, fdim, fma, |
| 35 | (This should happen automatically.) | 35 | fmax, fmin, fpclassify, hypot, ilogb, isfinite, isgreater, |
| 36 | 36 | isgreaterequal, isinf, isless, islessequal, islessgreater, *isnan, | |
| 37 | Define FLOAT_CHECK_ERRNO if the float library routines set errno. | 37 | isnormal, isunordered, lgamma, log1p, *log2 [via (log X 2)], *logb |
| 38 | This has no effect if HAVE_MATHERR is defined. | 38 | (approximately), lrint/llrint, lround/llround, nan, nearbyint, |
| 39 | 39 | nextafter, nexttoward, remainder, remquo, *rint, round, scalbln, | |
| 40 | Define FLOAT_CATCH_SIGILL if the float library routines signal SIGILL. | 40 | scalbn, signbit, tgamma, trunc. |
| 41 | (What systems actually do this? Please let us know.) | ||
| 42 | |||
| 43 | Define FLOAT_CHECK_DOMAIN if the float library doesn't handle errors by | ||
| 44 | either setting errno, or signaling SIGFPE/SIGILL. Otherwise, domain and | ||
| 45 | range checking will happen before calling the float routines. This has | ||
| 46 | no effect if HAVE_MATHERR is defined (since matherr will be called when | ||
| 47 | a domain error occurs.) | ||
| 48 | */ | 41 | */ |
| 49 | 42 | ||
| 50 | #include <config.h> | 43 | #include <config.h> |
| 51 | #include <signal.h> | 44 | |
| 52 | #include <setjmp.h> | ||
| 53 | #include "lisp.h" | 45 | #include "lisp.h" |
| 54 | #include "syssignal.h" | ||
| 55 | |||
| 56 | #include <float.h> | ||
| 57 | /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */ | ||
| 58 | #ifndef IEEE_FLOATING_POINT | ||
| 59 | #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \ | ||
| 60 | && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128) | ||
| 61 | #define IEEE_FLOATING_POINT 1 | ||
| 62 | #else | ||
| 63 | #define IEEE_FLOATING_POINT 0 | ||
| 64 | #endif | ||
| 65 | #endif | ||
| 66 | 46 | ||
| 67 | #include <math.h> | 47 | #include <math.h> |
| 68 | 48 | ||
| 69 | /* This declaration is omitted on some systems, like Ultrix. */ | 49 | #ifndef isfinite |
| 70 | #if !defined (HPUX) && defined (HAVE_LOGB) && !defined (logb) | 50 | # define isfinite(x) ((x) - (x) == 0) |
| 71 | extern double logb (double); | ||
| 72 | #endif /* not HPUX and HAVE_LOGB and no logb macro */ | ||
| 73 | |||
| 74 | #if defined (DOMAIN) && defined (SING) && defined (OVERFLOW) | ||
| 75 | /* If those are defined, then this is probably a `matherr' machine. */ | ||
| 76 | # ifndef HAVE_MATHERR | ||
| 77 | # define HAVE_MATHERR | ||
| 78 | # endif | ||
| 79 | #endif | ||
| 80 | |||
| 81 | #ifdef NO_MATHERR | ||
| 82 | #undef HAVE_MATHERR | ||
| 83 | #endif | ||
| 84 | |||
| 85 | #ifdef HAVE_MATHERR | ||
| 86 | # ifdef FLOAT_CHECK_ERRNO | ||
| 87 | # undef FLOAT_CHECK_ERRNO | ||
| 88 | # endif | ||
| 89 | # ifdef FLOAT_CHECK_DOMAIN | ||
| 90 | # undef FLOAT_CHECK_DOMAIN | ||
| 91 | # endif | ||
| 92 | #endif | 51 | #endif |
| 93 | 52 | #ifndef isnan | |
| 94 | #ifndef NO_FLOAT_CHECK_ERRNO | 53 | # define isnan(x) ((x) != (x)) |
| 95 | #define FLOAT_CHECK_ERRNO | ||
| 96 | #endif | ||
| 97 | |||
| 98 | #ifdef FLOAT_CHECK_ERRNO | ||
| 99 | # include <errno.h> | ||
| 100 | #endif | 54 | #endif |
| 101 | 55 | ||
| 102 | #ifdef FLOAT_CATCH_SIGILL | 56 | /* Check that X is a floating point number. */ |
| 103 | static void float_error (); | ||
| 104 | #endif | ||
| 105 | |||
| 106 | /* Nonzero while executing in floating point. | ||
| 107 | This tells float_error what to do. */ | ||
| 108 | |||
| 109 | static int in_float; | ||
| 110 | |||
| 111 | /* If an argument is out of range for a mathematical function, | ||
| 112 | here is the actual argument value to use in the error message. | ||
| 113 | These variables are used only across the floating point library call | ||
| 114 | so there is no need to staticpro them. */ | ||
| 115 | |||
| 116 | static Lisp_Object float_error_arg, float_error_arg2; | ||
| 117 | |||
| 118 | static const char *float_error_fn_name; | ||
| 119 | |||
| 120 | /* Evaluate the floating point expression D, recording NUM | ||
| 121 | as the original argument for error messages. | ||
| 122 | D is normally an assignment expression. | ||
| 123 | Handle errors which may result in signals or may set errno. | ||
| 124 | |||
| 125 | Note that float_error may be declared to return void, so you can't | ||
| 126 | just cast the zero after the colon to (void) to make the types | ||
| 127 | check properly. */ | ||
| 128 | |||
| 129 | #ifdef FLOAT_CHECK_ERRNO | ||
| 130 | #define IN_FLOAT(d, name, num) \ | ||
| 131 | do { \ | ||
| 132 | float_error_arg = num; \ | ||
| 133 | float_error_fn_name = name; \ | ||
| 134 | in_float = 1; errno = 0; (d); in_float = 0; \ | ||
| 135 | switch (errno) { \ | ||
| 136 | case 0: break; \ | ||
| 137 | case EDOM: domain_error (float_error_fn_name, float_error_arg); \ | ||
| 138 | case ERANGE: range_error (float_error_fn_name, float_error_arg); \ | ||
| 139 | default: arith_error (float_error_fn_name, float_error_arg); \ | ||
| 140 | } \ | ||
| 141 | } while (0) | ||
| 142 | #define IN_FLOAT2(d, name, num, num2) \ | ||
| 143 | do { \ | ||
| 144 | float_error_arg = num; \ | ||
| 145 | float_error_arg2 = num2; \ | ||
| 146 | float_error_fn_name = name; \ | ||
| 147 | in_float = 1; errno = 0; (d); in_float = 0; \ | ||
| 148 | switch (errno) { \ | ||
| 149 | case 0: break; \ | ||
| 150 | case EDOM: domain_error (float_error_fn_name, float_error_arg); \ | ||
| 151 | case ERANGE: range_error (float_error_fn_name, float_error_arg); \ | ||
| 152 | default: arith_error (float_error_fn_name, float_error_arg); \ | ||
| 153 | } \ | ||
| 154 | } while (0) | ||
| 155 | #else | ||
| 156 | #define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0) | ||
| 157 | #define IN_FLOAT2(d, name, num, num2) (in_float = 1, (d), in_float = 0) | ||
| 158 | #endif | ||
| 159 | 57 | ||
| 160 | /* Convert float to Lisp_Int if it fits, else signal a range error | 58 | static void |
| 161 | using the given arguments. */ | 59 | CHECK_FLOAT (Lisp_Object x) |
| 162 | #define FLOAT_TO_INT(x, i, name, num) \ | 60 | { |
| 163 | do \ | 61 | CHECK_TYPE (FLOATP (x), Qfloatp, x); |
| 164 | { \ | 62 | } |
| 165 | if (FIXNUM_OVERFLOW_P (x)) \ | ||
| 166 | range_error (name, num); \ | ||
| 167 | XSETINT (i, (EMACS_INT)(x)); \ | ||
| 168 | } \ | ||
| 169 | while (0) | ||
| 170 | #define FLOAT_TO_INT2(x, i, name, num1, num2) \ | ||
| 171 | do \ | ||
| 172 | { \ | ||
| 173 | if (FIXNUM_OVERFLOW_P (x)) \ | ||
| 174 | range_error2 (name, num1, num2); \ | ||
| 175 | XSETINT (i, (EMACS_INT)(x)); \ | ||
| 176 | } \ | ||
| 177 | while (0) | ||
| 178 | |||
| 179 | #define arith_error(op,arg) \ | ||
| 180 | xsignal2 (Qarith_error, build_string ((op)), (arg)) | ||
| 181 | #define range_error(op,arg) \ | ||
| 182 | xsignal2 (Qrange_error, build_string ((op)), (arg)) | ||
| 183 | #define range_error2(op,a1,a2) \ | ||
| 184 | xsignal3 (Qrange_error, build_string ((op)), (a1), (a2)) | ||
| 185 | #define domain_error(op,arg) \ | ||
| 186 | xsignal2 (Qdomain_error, build_string ((op)), (arg)) | ||
| 187 | #ifdef FLOAT_CHECK_DOMAIN | ||
| 188 | #define domain_error2(op,a1,a2) \ | ||
| 189 | xsignal3 (Qdomain_error, build_string ((op)), (a1), (a2)) | ||
| 190 | #endif | ||
| 191 | 63 | ||
| 192 | /* Extract a Lisp number as a `double', or signal an error. */ | 64 | /* Extract a Lisp number as a `double', or signal an error. */ |
| 193 | 65 | ||
| @@ -205,27 +77,19 @@ extract_float (Lisp_Object num) | |||
| 205 | 77 | ||
| 206 | DEFUN ("acos", Facos, Sacos, 1, 1, 0, | 78 | DEFUN ("acos", Facos, Sacos, 1, 1, 0, |
| 207 | doc: /* Return the inverse cosine of ARG. */) | 79 | doc: /* Return the inverse cosine of ARG. */) |
| 208 | (register Lisp_Object arg) | 80 | (Lisp_Object arg) |
| 209 | { | 81 | { |
| 210 | double d = extract_float (arg); | 82 | double d = extract_float (arg); |
| 211 | #ifdef FLOAT_CHECK_DOMAIN | 83 | d = acos (d); |
| 212 | if (d > 1.0 || d < -1.0) | ||
| 213 | domain_error ("acos", arg); | ||
| 214 | #endif | ||
| 215 | IN_FLOAT (d = acos (d), "acos", arg); | ||
| 216 | return make_float (d); | 84 | return make_float (d); |
| 217 | } | 85 | } |
| 218 | 86 | ||
| 219 | DEFUN ("asin", Fasin, Sasin, 1, 1, 0, | 87 | DEFUN ("asin", Fasin, Sasin, 1, 1, 0, |
| 220 | doc: /* Return the inverse sine of ARG. */) | 88 | doc: /* Return the inverse sine of ARG. */) |
| 221 | (register Lisp_Object arg) | 89 | (Lisp_Object arg) |
| 222 | { | 90 | { |
| 223 | double d = extract_float (arg); | 91 | double d = extract_float (arg); |
| 224 | #ifdef FLOAT_CHECK_DOMAIN | 92 | d = asin (d); |
| 225 | if (d > 1.0 || d < -1.0) | ||
| 226 | domain_error ("asin", arg); | ||
| 227 | #endif | ||
| 228 | IN_FLOAT (d = asin (d), "asin", arg); | ||
| 229 | return make_float (d); | 93 | return make_float (d); |
| 230 | } | 94 | } |
| 231 | 95 | ||
| @@ -235,56 +99,47 @@ If only one argument Y is given, return the inverse tangent of Y. | |||
| 235 | If two arguments Y and X are given, return the inverse tangent of Y | 99 | If two arguments Y and X are given, return the inverse tangent of Y |
| 236 | divided by X, i.e. the angle in radians between the vector (X, Y) | 100 | divided by X, i.e. the angle in radians between the vector (X, Y) |
| 237 | and the x-axis. */) | 101 | and the x-axis. */) |
| 238 | (register Lisp_Object y, Lisp_Object x) | 102 | (Lisp_Object y, Lisp_Object x) |
| 239 | { | 103 | { |
| 240 | double d = extract_float (y); | 104 | double d = extract_float (y); |
| 241 | 105 | ||
| 242 | if (NILP (x)) | 106 | if (NILP (x)) |
| 243 | IN_FLOAT (d = atan (d), "atan", y); | 107 | d = atan (d); |
| 244 | else | 108 | else |
| 245 | { | 109 | { |
| 246 | double d2 = extract_float (x); | 110 | double d2 = extract_float (x); |
| 247 | 111 | d = atan2 (d, d2); | |
| 248 | IN_FLOAT2 (d = atan2 (d, d2), "atan", y, x); | ||
| 249 | } | 112 | } |
| 250 | return make_float (d); | 113 | return make_float (d); |
| 251 | } | 114 | } |
| 252 | 115 | ||
| 253 | DEFUN ("cos", Fcos, Scos, 1, 1, 0, | 116 | DEFUN ("cos", Fcos, Scos, 1, 1, 0, |
| 254 | doc: /* Return the cosine of ARG. */) | 117 | doc: /* Return the cosine of ARG. */) |
| 255 | (register Lisp_Object arg) | 118 | (Lisp_Object arg) |
| 256 | { | 119 | { |
| 257 | double d = extract_float (arg); | 120 | double d = extract_float (arg); |
| 258 | IN_FLOAT (d = cos (d), "cos", arg); | 121 | d = cos (d); |
| 259 | return make_float (d); | 122 | return make_float (d); |
| 260 | } | 123 | } |
| 261 | 124 | ||
| 262 | DEFUN ("sin", Fsin, Ssin, 1, 1, 0, | 125 | DEFUN ("sin", Fsin, Ssin, 1, 1, 0, |
| 263 | doc: /* Return the sine of ARG. */) | 126 | doc: /* Return the sine of ARG. */) |
| 264 | (register Lisp_Object arg) | 127 | (Lisp_Object arg) |
| 265 | { | 128 | { |
| 266 | double d = extract_float (arg); | 129 | double d = extract_float (arg); |
| 267 | IN_FLOAT (d = sin (d), "sin", arg); | 130 | d = sin (d); |
| 268 | return make_float (d); | 131 | return make_float (d); |
| 269 | } | 132 | } |
| 270 | 133 | ||
| 271 | DEFUN ("tan", Ftan, Stan, 1, 1, 0, | 134 | DEFUN ("tan", Ftan, Stan, 1, 1, 0, |
| 272 | doc: /* Return the tangent of ARG. */) | 135 | doc: /* Return the tangent of ARG. */) |
| 273 | (register Lisp_Object arg) | 136 | (Lisp_Object arg) |
| 274 | { | 137 | { |
| 275 | double d = extract_float (arg); | 138 | double d = extract_float (arg); |
| 276 | double c = cos (d); | 139 | d = tan (d); |
| 277 | #ifdef FLOAT_CHECK_DOMAIN | ||
| 278 | if (c == 0.0) | ||
| 279 | domain_error ("tan", arg); | ||
| 280 | #endif | ||
| 281 | IN_FLOAT (d = sin (d) / c, "tan", arg); | ||
| 282 | return make_float (d); | 140 | return make_float (d); |
| 283 | } | 141 | } |
| 284 | 142 | ||
| 285 | #undef isnan | ||
| 286 | #define isnan(x) ((x) != (x)) | ||
| 287 | |||
| 288 | DEFUN ("isnan", Fisnan, Sisnan, 1, 1, 0, | 143 | DEFUN ("isnan", Fisnan, Sisnan, 1, 1, 0, |
| 289 | doc: /* Return non nil iff argument X is a NaN. */) | 144 | doc: /* Return non nil iff argument X is a NaN. */) |
| 290 | (Lisp_Object x) | 145 | (Lisp_Object x) |
| @@ -309,6 +164,7 @@ Cause an error if X1 or X2 is not a float. */) | |||
| 309 | 164 | ||
| 310 | return make_float (copysign (f1, f2)); | 165 | return make_float (copysign (f1, f2)); |
| 311 | } | 166 | } |
| 167 | #endif | ||
| 312 | 168 | ||
| 313 | DEFUN ("frexp", Ffrexp, Sfrexp, 1, 1, 0, | 169 | DEFUN ("frexp", Ffrexp, Sfrexp, 1, 1, 0, |
| 314 | doc: /* Get significand and exponent of a floating point number. | 170 | doc: /* Get significand and exponent of a floating point number. |
| @@ -323,15 +179,9 @@ If X is zero, both parts (SGNFCAND and EXP) are zero. */) | |||
| 323 | (Lisp_Object x) | 179 | (Lisp_Object x) |
| 324 | { | 180 | { |
| 325 | double f = XFLOATINT (x); | 181 | double f = XFLOATINT (x); |
| 326 | 182 | int exponent; | |
| 327 | if (f == 0.0) | 183 | double sgnfcand = frexp (f, &exponent); |
| 328 | return Fcons (make_float (0.0), make_number (0)); | 184 | return Fcons (make_float (sgnfcand), make_number (exponent)); |
| 329 | else | ||
| 330 | { | ||
| 331 | int exponent; | ||
| 332 | double sgnfcand = frexp (f, &exponent); | ||
| 333 | return Fcons (make_float (sgnfcand), make_number (exponent)); | ||
| 334 | } | ||
| 335 | } | 185 | } |
| 336 | 186 | ||
| 337 | DEFUN ("ldexp", Fldexp, Sldexp, 1, 2, 0, | 187 | DEFUN ("ldexp", Fldexp, Sldexp, 1, 2, 0, |
| @@ -343,138 +193,19 @@ Returns the floating point value resulting from multiplying SGNFCAND | |||
| 343 | CHECK_NUMBER (exponent); | 193 | CHECK_NUMBER (exponent); |
| 344 | return make_float (ldexp (XFLOATINT (sgnfcand), XINT (exponent))); | 194 | return make_float (ldexp (XFLOATINT (sgnfcand), XINT (exponent))); |
| 345 | } | 195 | } |
| 346 | #endif | ||
| 347 | |||
| 348 | #if 0 /* Leave these out unless we find there's a reason for them. */ | ||
| 349 | |||
| 350 | DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0, | ||
| 351 | doc: /* Return the bessel function j0 of ARG. */) | ||
| 352 | (register Lisp_Object arg) | ||
| 353 | { | ||
| 354 | double d = extract_float (arg); | ||
| 355 | IN_FLOAT (d = j0 (d), "bessel-j0", arg); | ||
| 356 | return make_float (d); | ||
| 357 | } | ||
| 358 | |||
| 359 | DEFUN ("bessel-j1", Fbessel_j1, Sbessel_j1, 1, 1, 0, | ||
| 360 | doc: /* Return the bessel function j1 of ARG. */) | ||
| 361 | (register Lisp_Object arg) | ||
| 362 | { | ||
| 363 | double d = extract_float (arg); | ||
| 364 | IN_FLOAT (d = j1 (d), "bessel-j1", arg); | ||
| 365 | return make_float (d); | ||
| 366 | } | ||
| 367 | |||
| 368 | DEFUN ("bessel-jn", Fbessel_jn, Sbessel_jn, 2, 2, 0, | ||
| 369 | doc: /* Return the order N bessel function output jn of ARG. | ||
| 370 | The first arg (the order) is truncated to an integer. */) | ||
| 371 | (register Lisp_Object n, Lisp_Object arg) | ||
| 372 | { | ||
| 373 | int i1 = extract_float (n); | ||
| 374 | double f2 = extract_float (arg); | ||
| 375 | |||
| 376 | IN_FLOAT (f2 = jn (i1, f2), "bessel-jn", n); | ||
| 377 | return make_float (f2); | ||
| 378 | } | ||
| 379 | |||
| 380 | DEFUN ("bessel-y0", Fbessel_y0, Sbessel_y0, 1, 1, 0, | ||
| 381 | doc: /* Return the bessel function y0 of ARG. */) | ||
| 382 | (register Lisp_Object arg) | ||
| 383 | { | ||
| 384 | double d = extract_float (arg); | ||
| 385 | IN_FLOAT (d = y0 (d), "bessel-y0", arg); | ||
| 386 | return make_float (d); | ||
| 387 | } | ||
| 388 | |||
| 389 | DEFUN ("bessel-y1", Fbessel_y1, Sbessel_y1, 1, 1, 0, | ||
| 390 | doc: /* Return the bessel function y1 of ARG. */) | ||
| 391 | (register Lisp_Object arg) | ||
| 392 | { | ||
| 393 | double d = extract_float (arg); | ||
| 394 | IN_FLOAT (d = y1 (d), "bessel-y0", arg); | ||
| 395 | return make_float (d); | ||
| 396 | } | ||
| 397 | |||
| 398 | DEFUN ("bessel-yn", Fbessel_yn, Sbessel_yn, 2, 2, 0, | ||
| 399 | doc: /* Return the order N bessel function output yn of ARG. | ||
| 400 | The first arg (the order) is truncated to an integer. */) | ||
| 401 | (register Lisp_Object n, Lisp_Object arg) | ||
| 402 | { | ||
| 403 | int i1 = extract_float (n); | ||
| 404 | double f2 = extract_float (arg); | ||
| 405 | |||
| 406 | IN_FLOAT (f2 = yn (i1, f2), "bessel-yn", n); | ||
| 407 | return make_float (f2); | ||
| 408 | } | ||
| 409 | |||
| 410 | #endif | ||
| 411 | |||
| 412 | #if 0 /* Leave these out unless we see they are worth having. */ | ||
| 413 | |||
| 414 | DEFUN ("erf", Ferf, Serf, 1, 1, 0, | ||
| 415 | doc: /* Return the mathematical error function of ARG. */) | ||
| 416 | (register Lisp_Object arg) | ||
| 417 | { | ||
| 418 | double d = extract_float (arg); | ||
| 419 | IN_FLOAT (d = erf (d), "erf", arg); | ||
| 420 | return make_float (d); | ||
| 421 | } | ||
| 422 | |||
| 423 | DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0, | ||
| 424 | doc: /* Return the complementary error function of ARG. */) | ||
| 425 | (register Lisp_Object arg) | ||
| 426 | { | ||
| 427 | double d = extract_float (arg); | ||
| 428 | IN_FLOAT (d = erfc (d), "erfc", arg); | ||
| 429 | return make_float (d); | ||
| 430 | } | ||
| 431 | |||
| 432 | DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0, | ||
| 433 | doc: /* Return the log gamma of ARG. */) | ||
| 434 | (register Lisp_Object arg) | ||
| 435 | { | ||
| 436 | double d = extract_float (arg); | ||
| 437 | IN_FLOAT (d = lgamma (d), "log-gamma", arg); | ||
| 438 | return make_float (d); | ||
| 439 | } | ||
| 440 | |||
| 441 | DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0, | ||
| 442 | doc: /* Return the cube root of ARG. */) | ||
| 443 | (register Lisp_Object arg) | ||
| 444 | { | ||
| 445 | double d = extract_float (arg); | ||
| 446 | #ifdef HAVE_CBRT | ||
| 447 | IN_FLOAT (d = cbrt (d), "cube-root", arg); | ||
| 448 | #else | ||
| 449 | if (d >= 0.0) | ||
| 450 | IN_FLOAT (d = pow (d, 1.0/3.0), "cube-root", arg); | ||
| 451 | else | ||
| 452 | IN_FLOAT (d = -pow (-d, 1.0/3.0), "cube-root", arg); | ||
| 453 | #endif | ||
| 454 | return make_float (d); | ||
| 455 | } | ||
| 456 | |||
| 457 | #endif | ||
| 458 | 196 | ||
| 459 | DEFUN ("exp", Fexp, Sexp, 1, 1, 0, | 197 | DEFUN ("exp", Fexp, Sexp, 1, 1, 0, |
| 460 | doc: /* Return the exponential base e of ARG. */) | 198 | doc: /* Return the exponential base e of ARG. */) |
| 461 | (register Lisp_Object arg) | 199 | (Lisp_Object arg) |
| 462 | { | 200 | { |
| 463 | double d = extract_float (arg); | 201 | double d = extract_float (arg); |
| 464 | #ifdef FLOAT_CHECK_DOMAIN | 202 | d = exp (d); |
| 465 | if (d > 709.7827) /* Assume IEEE doubles here */ | ||
| 466 | range_error ("exp", arg); | ||
| 467 | else if (d < -709.0) | ||
| 468 | return make_float (0.0); | ||
| 469 | else | ||
| 470 | #endif | ||
| 471 | IN_FLOAT (d = exp (d), "exp", arg); | ||
| 472 | return make_float (d); | 203 | return make_float (d); |
| 473 | } | 204 | } |
| 474 | 205 | ||
| 475 | DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, | 206 | DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, |
| 476 | doc: /* Return the exponential ARG1 ** ARG2. */) | 207 | doc: /* Return the exponential ARG1 ** ARG2. */) |
| 477 | (register Lisp_Object arg1, Lisp_Object arg2) | 208 | (Lisp_Object arg1, Lisp_Object arg2) |
| 478 | { | 209 | { |
| 479 | double f1, f2, f3; | 210 | double f1, f2, f3; |
| 480 | 211 | ||
| @@ -482,7 +213,7 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, | |||
| 482 | CHECK_NUMBER_OR_FLOAT (arg2); | 213 | CHECK_NUMBER_OR_FLOAT (arg2); |
| 483 | if (INTEGERP (arg1) /* common lisp spec */ | 214 | if (INTEGERP (arg1) /* common lisp spec */ |
| 484 | && INTEGERP (arg2) /* don't promote, if both are ints, and */ | 215 | && INTEGERP (arg2) /* don't promote, if both are ints, and */ |
| 485 | && 0 <= XINT (arg2)) /* we are sure the result is not fractional */ | 216 | && XINT (arg2) >= 0) /* we are sure the result is not fractional */ |
| 486 | { /* this can be improved by pre-calculating */ | 217 | { /* this can be improved by pre-calculating */ |
| 487 | EMACS_INT y; /* some binary powers of x then accumulating */ | 218 | EMACS_INT y; /* some binary powers of x then accumulating */ |
| 488 | EMACS_UINT acc, x; /* Unsigned so that overflow is well defined. */ | 219 | EMACS_UINT acc, x; /* Unsigned so that overflow is well defined. */ |
| @@ -503,159 +234,43 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, | |||
| 503 | } | 234 | } |
| 504 | f1 = FLOATP (arg1) ? XFLOAT_DATA (arg1) : XINT (arg1); | 235 | f1 = FLOATP (arg1) ? XFLOAT_DATA (arg1) : XINT (arg1); |
| 505 | f2 = FLOATP (arg2) ? XFLOAT_DATA (arg2) : XINT (arg2); | 236 | f2 = FLOATP (arg2) ? XFLOAT_DATA (arg2) : XINT (arg2); |
| 506 | /* Really should check for overflow, too */ | 237 | f3 = pow (f1, f2); |
| 507 | if (f1 == 0.0 && f2 == 0.0) | ||
| 508 | f1 = 1.0; | ||
| 509 | #ifdef FLOAT_CHECK_DOMAIN | ||
| 510 | else if ((f1 == 0.0 && f2 < 0.0) || (f1 < 0 && f2 != floor (f2))) | ||
| 511 | domain_error2 ("expt", arg1, arg2); | ||
| 512 | #endif | ||
| 513 | IN_FLOAT2 (f3 = pow (f1, f2), "expt", arg1, arg2); | ||
| 514 | /* Check for overflow in the result. */ | ||
| 515 | if (f1 != 0.0 && f3 == 0.0) | ||
| 516 | range_error ("expt", arg1); | ||
| 517 | return make_float (f3); | 238 | return make_float (f3); |
| 518 | } | 239 | } |
| 519 | 240 | ||
| 520 | DEFUN ("log", Flog, Slog, 1, 2, 0, | 241 | DEFUN ("log", Flog, Slog, 1, 2, 0, |
| 521 | doc: /* Return the natural logarithm of ARG. | 242 | doc: /* Return the natural logarithm of ARG. |
| 522 | If the optional argument BASE is given, return log ARG using that base. */) | 243 | If the optional argument BASE is given, return log ARG using that base. */) |
| 523 | (register Lisp_Object arg, Lisp_Object base) | 244 | (Lisp_Object arg, Lisp_Object base) |
| 524 | { | 245 | { |
| 525 | double d = extract_float (arg); | 246 | double d = extract_float (arg); |
| 526 | 247 | ||
| 527 | #ifdef FLOAT_CHECK_DOMAIN | ||
| 528 | if (d <= 0.0) | ||
| 529 | domain_error2 ("log", arg, base); | ||
| 530 | #endif | ||
| 531 | if (NILP (base)) | 248 | if (NILP (base)) |
| 532 | IN_FLOAT (d = log (d), "log", arg); | 249 | d = log (d); |
| 533 | else | 250 | else |
| 534 | { | 251 | { |
| 535 | double b = extract_float (base); | 252 | double b = extract_float (base); |
| 536 | 253 | ||
| 537 | #ifdef FLOAT_CHECK_DOMAIN | ||
| 538 | if (b <= 0.0 || b == 1.0) | ||
| 539 | domain_error2 ("log", arg, base); | ||
| 540 | #endif | ||
| 541 | if (b == 10.0) | 254 | if (b == 10.0) |
| 542 | IN_FLOAT2 (d = log10 (d), "log", arg, base); | 255 | d = log10 (d); |
| 256 | #if HAVE_LOG2 | ||
| 257 | else if (b == 2.0) | ||
| 258 | d = log2 (d); | ||
| 259 | #endif | ||
| 543 | else | 260 | else |
| 544 | IN_FLOAT2 (d = log (d) / log (b), "log", arg, base); | 261 | d = log (d) / log (b); |
| 545 | } | 262 | } |
| 546 | return make_float (d); | 263 | return make_float (d); |
| 547 | } | 264 | } |
| 548 | 265 | ||
| 549 | DEFUN ("log10", Flog10, Slog10, 1, 1, 0, | ||
| 550 | doc: /* Return the logarithm base 10 of ARG. */) | ||
| 551 | (register Lisp_Object arg) | ||
| 552 | { | ||
| 553 | double d = extract_float (arg); | ||
| 554 | #ifdef FLOAT_CHECK_DOMAIN | ||
| 555 | if (d <= 0.0) | ||
| 556 | domain_error ("log10", arg); | ||
| 557 | #endif | ||
| 558 | IN_FLOAT (d = log10 (d), "log10", arg); | ||
| 559 | return make_float (d); | ||
| 560 | } | ||
| 561 | |||
| 562 | DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0, | 266 | DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0, |
| 563 | doc: /* Return the square root of ARG. */) | 267 | doc: /* Return the square root of ARG. */) |
| 564 | (register Lisp_Object arg) | 268 | (Lisp_Object arg) |
| 565 | { | ||
| 566 | double d = extract_float (arg); | ||
| 567 | #ifdef FLOAT_CHECK_DOMAIN | ||
| 568 | if (d < 0.0) | ||
| 569 | domain_error ("sqrt", arg); | ||
| 570 | #endif | ||
| 571 | IN_FLOAT (d = sqrt (d), "sqrt", arg); | ||
| 572 | return make_float (d); | ||
| 573 | } | ||
| 574 | |||
| 575 | #if 0 /* Not clearly worth adding. */ | ||
| 576 | |||
| 577 | DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0, | ||
| 578 | doc: /* Return the inverse hyperbolic cosine of ARG. */) | ||
| 579 | (register Lisp_Object arg) | ||
| 580 | { | ||
| 581 | double d = extract_float (arg); | ||
| 582 | #ifdef FLOAT_CHECK_DOMAIN | ||
| 583 | if (d < 1.0) | ||
| 584 | domain_error ("acosh", arg); | ||
| 585 | #endif | ||
| 586 | #ifdef HAVE_INVERSE_HYPERBOLIC | ||
| 587 | IN_FLOAT (d = acosh (d), "acosh", arg); | ||
| 588 | #else | ||
| 589 | IN_FLOAT (d = log (d + sqrt (d*d - 1.0)), "acosh", arg); | ||
| 590 | #endif | ||
| 591 | return make_float (d); | ||
| 592 | } | ||
| 593 | |||
| 594 | DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0, | ||
| 595 | doc: /* Return the inverse hyperbolic sine of ARG. */) | ||
| 596 | (register Lisp_Object arg) | ||
| 597 | { | ||
| 598 | double d = extract_float (arg); | ||
| 599 | #ifdef HAVE_INVERSE_HYPERBOLIC | ||
| 600 | IN_FLOAT (d = asinh (d), "asinh", arg); | ||
| 601 | #else | ||
| 602 | IN_FLOAT (d = log (d + sqrt (d*d + 1.0)), "asinh", arg); | ||
| 603 | #endif | ||
| 604 | return make_float (d); | ||
| 605 | } | ||
| 606 | |||
| 607 | DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0, | ||
| 608 | doc: /* Return the inverse hyperbolic tangent of ARG. */) | ||
| 609 | (register Lisp_Object arg) | ||
| 610 | { | ||
| 611 | double d = extract_float (arg); | ||
| 612 | #ifdef FLOAT_CHECK_DOMAIN | ||
| 613 | if (d >= 1.0 || d <= -1.0) | ||
| 614 | domain_error ("atanh", arg); | ||
| 615 | #endif | ||
| 616 | #ifdef HAVE_INVERSE_HYPERBOLIC | ||
| 617 | IN_FLOAT (d = atanh (d), "atanh", arg); | ||
| 618 | #else | ||
| 619 | IN_FLOAT (d = 0.5 * log ((1.0 + d) / (1.0 - d)), "atanh", arg); | ||
| 620 | #endif | ||
| 621 | return make_float (d); | ||
| 622 | } | ||
| 623 | |||
| 624 | DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0, | ||
| 625 | doc: /* Return the hyperbolic cosine of ARG. */) | ||
| 626 | (register Lisp_Object arg) | ||
| 627 | { | ||
| 628 | double d = extract_float (arg); | ||
| 629 | #ifdef FLOAT_CHECK_DOMAIN | ||
| 630 | if (d > 710.0 || d < -710.0) | ||
| 631 | range_error ("cosh", arg); | ||
| 632 | #endif | ||
| 633 | IN_FLOAT (d = cosh (d), "cosh", arg); | ||
| 634 | return make_float (d); | ||
| 635 | } | ||
| 636 | |||
| 637 | DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0, | ||
| 638 | doc: /* Return the hyperbolic sine of ARG. */) | ||
| 639 | (register Lisp_Object arg) | ||
| 640 | { | ||
| 641 | double d = extract_float (arg); | ||
| 642 | #ifdef FLOAT_CHECK_DOMAIN | ||
| 643 | if (d > 710.0 || d < -710.0) | ||
| 644 | range_error ("sinh", arg); | ||
| 645 | #endif | ||
| 646 | IN_FLOAT (d = sinh (d), "sinh", arg); | ||
| 647 | return make_float (d); | ||
| 648 | } | ||
| 649 | |||
| 650 | DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0, | ||
| 651 | doc: /* Return the hyperbolic tangent of ARG. */) | ||
| 652 | (register Lisp_Object arg) | ||
| 653 | { | 269 | { |
| 654 | double d = extract_float (arg); | 270 | double d = extract_float (arg); |
| 655 | IN_FLOAT (d = tanh (d), "tanh", arg); | 271 | d = sqrt (d); |
| 656 | return make_float (d); | 272 | return make_float (d); |
| 657 | } | 273 | } |
| 658 | #endif | ||
| 659 | 274 | ||
| 660 | DEFUN ("abs", Fabs, Sabs, 1, 1, 0, | 275 | DEFUN ("abs", Fabs, Sabs, 1, 1, 0, |
| 661 | doc: /* Return the absolute value of ARG. */) | 276 | doc: /* Return the absolute value of ARG. */) |
| @@ -664,7 +279,7 @@ DEFUN ("abs", Fabs, Sabs, 1, 1, 0, | |||
| 664 | CHECK_NUMBER_OR_FLOAT (arg); | 279 | CHECK_NUMBER_OR_FLOAT (arg); |
| 665 | 280 | ||
| 666 | if (FLOATP (arg)) | 281 | if (FLOATP (arg)) |
| 667 | IN_FLOAT (arg = make_float (fabs (XFLOAT_DATA (arg))), "abs", arg); | 282 | arg = make_float (fabs (XFLOAT_DATA (arg))); |
| 668 | else if (XINT (arg) < 0) | 283 | else if (XINT (arg) < 0) |
| 669 | XSETINT (arg, - XINT (arg)); | 284 | XSETINT (arg, - XINT (arg)); |
| 670 | 285 | ||
| @@ -694,38 +309,15 @@ This is the same as the exponent of a float. */) | |||
| 694 | 309 | ||
| 695 | if (f == 0.0) | 310 | if (f == 0.0) |
| 696 | value = MOST_NEGATIVE_FIXNUM; | 311 | value = MOST_NEGATIVE_FIXNUM; |
| 697 | else | 312 | else if (isfinite (f)) |
| 698 | { | 313 | { |
| 699 | #ifdef HAVE_LOGB | ||
| 700 | IN_FLOAT (value = logb (f), "logb", arg); | ||
| 701 | #else | ||
| 702 | #ifdef HAVE_FREXP | ||
| 703 | int ivalue; | 314 | int ivalue; |
| 704 | IN_FLOAT (frexp (f, &ivalue), "logb", arg); | 315 | frexp (f, &ivalue); |
| 705 | value = ivalue - 1; | 316 | value = ivalue - 1; |
| 706 | #else | ||
| 707 | int i; | ||
| 708 | double d; | ||
| 709 | if (f < 0.0) | ||
| 710 | f = -f; | ||
| 711 | value = -1; | ||
| 712 | while (f < 0.5) | ||
| 713 | { | ||
| 714 | for (i = 1, d = 0.5; d * d >= f; i += i) | ||
| 715 | d *= d; | ||
| 716 | f /= d; | ||
| 717 | value -= i; | ||
| 718 | } | ||
| 719 | while (f >= 1.0) | ||
| 720 | { | ||
| 721 | for (i = 1, d = 2.0; d * d <= f; i += i) | ||
| 722 | d *= d; | ||
| 723 | f /= d; | ||
| 724 | value += i; | ||
| 725 | } | ||
| 726 | #endif | ||
| 727 | #endif | ||
| 728 | } | 317 | } |
| 318 | else | ||
| 319 | value = MOST_POSITIVE_FIXNUM; | ||
| 320 | |||
| 729 | XSETINT (val, value); | 321 | XSETINT (val, value); |
| 730 | return val; | 322 | return val; |
| 731 | } | 323 | } |
| @@ -756,8 +348,10 @@ rounding_driver (Lisp_Object arg, Lisp_Object divisor, | |||
| 756 | if (! IEEE_FLOATING_POINT && f2 == 0) | 348 | if (! IEEE_FLOATING_POINT && f2 == 0) |
| 757 | xsignal0 (Qarith_error); | 349 | xsignal0 (Qarith_error); |
| 758 | 350 | ||
| 759 | IN_FLOAT2 (f1 = (*double_round) (f1 / f2), name, arg, divisor); | 351 | f1 = (*double_round) (f1 / f2); |
| 760 | FLOAT_TO_INT2 (f1, arg, name, arg, divisor); | 352 | if (FIXNUM_OVERFLOW_P (f1)) |
| 353 | xsignal3 (Qrange_error, build_string (name), arg, divisor); | ||
| 354 | arg = make_number (f1); | ||
| 761 | return arg; | 355 | return arg; |
| 762 | } | 356 | } |
| 763 | 357 | ||
| @@ -773,10 +367,10 @@ rounding_driver (Lisp_Object arg, Lisp_Object divisor, | |||
| 773 | 367 | ||
| 774 | if (FLOATP (arg)) | 368 | if (FLOATP (arg)) |
| 775 | { | 369 | { |
| 776 | double d; | 370 | double d = (*double_round) (XFLOAT_DATA (arg)); |
| 777 | 371 | if (FIXNUM_OVERFLOW_P (d)) | |
| 778 | IN_FLOAT (d = (*double_round) (XFLOAT_DATA (arg)), name, arg); | 372 | xsignal2 (Qrange_error, build_string (name), arg); |
| 779 | FLOAT_TO_INT (d, arg, name, arg); | 373 | arg = make_number (d); |
| 780 | } | 374 | } |
| 781 | 375 | ||
| 782 | return arg; | 376 | return arg; |
| @@ -820,8 +414,8 @@ round2 (EMACS_INT i1, EMACS_INT i2) | |||
| 820 | odd. */ | 414 | odd. */ |
| 821 | EMACS_INT q = i1 / i2; | 415 | EMACS_INT q = i1 / i2; |
| 822 | EMACS_INT r = i1 % i2; | 416 | EMACS_INT r = i1 % i2; |
| 823 | EMACS_INT abs_r = r < 0 ? -r : r; | 417 | EMACS_INT abs_r = eabs (r); |
| 824 | EMACS_INT abs_r1 = (i2 < 0 ? -i2 : i2) - abs_r; | 418 | EMACS_INT abs_r1 = eabs (i2) - abs_r; |
| 825 | return q + (abs_r + (q & 1) <= abs_r1 ? 0 : (i2 ^ r) < 0 ? -1 : 1); | 419 | return q + (abs_r + (q & 1) <= abs_r1 ? 0 : (i2 ^ r) < 0 ? -1 : 1); |
| 826 | } | 420 | } |
| 827 | 421 | ||
| @@ -893,125 +487,57 @@ fmod_float (Lisp_Object x, Lisp_Object y) | |||
| 893 | f1 = FLOATP (x) ? XFLOAT_DATA (x) : XINT (x); | 487 | f1 = FLOATP (x) ? XFLOAT_DATA (x) : XINT (x); |
| 894 | f2 = FLOATP (y) ? XFLOAT_DATA (y) : XINT (y); | 488 | f2 = FLOATP (y) ? XFLOAT_DATA (y) : XINT (y); |
| 895 | 489 | ||
| 896 | if (! IEEE_FLOATING_POINT && f2 == 0) | 490 | f1 = fmod (f1, f2); |
| 897 | xsignal0 (Qarith_error); | ||
| 898 | 491 | ||
| 899 | /* If the "remainder" comes out with the wrong sign, fix it. */ | 492 | /* If the "remainder" comes out with the wrong sign, fix it. */ |
| 900 | IN_FLOAT2 ((f1 = fmod (f1, f2), | 493 | if (f2 < 0 ? f1 > 0 : f1 < 0) |
| 901 | f1 = (f2 < 0 ? f1 > 0 : f1 < 0) ? f1 + f2 : f1), | 494 | f1 += f2; |
| 902 | "mod", x, y); | 495 | |
| 903 | return make_float (f1); | 496 | return make_float (f1); |
| 904 | } | 497 | } |
| 905 | 498 | ||
| 906 | /* It's not clear these are worth adding. */ | ||
| 907 | |||
| 908 | DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0, | 499 | DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0, |
| 909 | doc: /* Return the smallest integer no less than ARG, as a float. | 500 | doc: /* Return the smallest integer no less than ARG, as a float. |
| 910 | \(Round toward +inf.\) */) | 501 | \(Round toward +inf.\) */) |
| 911 | (register Lisp_Object arg) | 502 | (Lisp_Object arg) |
| 912 | { | 503 | { |
| 913 | double d = extract_float (arg); | 504 | double d = extract_float (arg); |
| 914 | IN_FLOAT (d = ceil (d), "fceiling", arg); | 505 | d = ceil (d); |
| 915 | return make_float (d); | 506 | return make_float (d); |
| 916 | } | 507 | } |
| 917 | 508 | ||
| 918 | DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0, | 509 | DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0, |
| 919 | doc: /* Return the largest integer no greater than ARG, as a float. | 510 | doc: /* Return the largest integer no greater than ARG, as a float. |
| 920 | \(Round towards -inf.\) */) | 511 | \(Round towards -inf.\) */) |
| 921 | (register Lisp_Object arg) | 512 | (Lisp_Object arg) |
| 922 | { | 513 | { |
| 923 | double d = extract_float (arg); | 514 | double d = extract_float (arg); |
| 924 | IN_FLOAT (d = floor (d), "ffloor", arg); | 515 | d = floor (d); |
| 925 | return make_float (d); | 516 | return make_float (d); |
| 926 | } | 517 | } |
| 927 | 518 | ||
| 928 | DEFUN ("fround", Ffround, Sfround, 1, 1, 0, | 519 | DEFUN ("fround", Ffround, Sfround, 1, 1, 0, |
| 929 | doc: /* Return the nearest integer to ARG, as a float. */) | 520 | doc: /* Return the nearest integer to ARG, as a float. */) |
| 930 | (register Lisp_Object arg) | 521 | (Lisp_Object arg) |
| 931 | { | 522 | { |
| 932 | double d = extract_float (arg); | 523 | double d = extract_float (arg); |
| 933 | IN_FLOAT (d = emacs_rint (d), "fround", arg); | 524 | d = emacs_rint (d); |
| 934 | return make_float (d); | 525 | return make_float (d); |
| 935 | } | 526 | } |
| 936 | 527 | ||
| 937 | DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0, | 528 | DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0, |
| 938 | doc: /* Truncate a floating point number to an integral float value. | 529 | doc: /* Truncate a floating point number to an integral float value. |
| 939 | Rounds the value toward zero. */) | 530 | Rounds the value toward zero. */) |
| 940 | (register Lisp_Object arg) | 531 | (Lisp_Object arg) |
| 941 | { | 532 | { |
| 942 | double d = extract_float (arg); | 533 | double d = extract_float (arg); |
| 943 | if (d >= 0.0) | 534 | if (d >= 0.0) |
| 944 | IN_FLOAT (d = floor (d), "ftruncate", arg); | 535 | d = floor (d); |
| 945 | else | 536 | else |
| 946 | IN_FLOAT (d = ceil (d), "ftruncate", arg); | 537 | d = ceil (d); |
| 947 | return make_float (d); | 538 | return make_float (d); |
| 948 | } | 539 | } |
| 949 | 540 | ||
| 950 | #ifdef FLOAT_CATCH_SIGILL | ||
| 951 | static void | ||
| 952 | float_error (int signo) | ||
| 953 | { | ||
| 954 | if (! in_float) | ||
| 955 | fatal_error_signal (signo); | ||
| 956 | |||
| 957 | #ifdef BSD_SYSTEM | ||
| 958 | sigsetmask (SIGEMPTYMASK); | ||
| 959 | #else | ||
| 960 | /* Must reestablish handler each time it is called. */ | ||
| 961 | signal (SIGILL, float_error); | ||
| 962 | #endif /* BSD_SYSTEM */ | ||
| 963 | |||
| 964 | SIGNAL_THREAD_CHECK (signo); | ||
| 965 | in_float = 0; | ||
| 966 | |||
| 967 | xsignal1 (Qarith_error, float_error_arg); | ||
| 968 | } | ||
| 969 | |||
| 970 | /* Another idea was to replace the library function `infnan' | ||
| 971 | where SIGILL is signaled. */ | ||
| 972 | |||
| 973 | #endif /* FLOAT_CATCH_SIGILL */ | ||
| 974 | |||
| 975 | #ifdef HAVE_MATHERR | ||
| 976 | int | ||
| 977 | matherr (struct exception *x) | ||
| 978 | { | ||
| 979 | Lisp_Object args; | ||
| 980 | const char *name = x->name; | ||
| 981 | |||
| 982 | if (! in_float) | ||
| 983 | /* Not called from emacs-lisp float routines; do the default thing. */ | ||
| 984 | return 0; | ||
| 985 | if (!strcmp (x->name, "pow")) | ||
| 986 | name = "expt"; | ||
| 987 | |||
| 988 | args | ||
| 989 | = Fcons (build_string (name), | ||
| 990 | Fcons (make_float (x->arg1), | ||
| 991 | ((!strcmp (name, "log") || !strcmp (name, "pow")) | ||
| 992 | ? Fcons (make_float (x->arg2), Qnil) | ||
| 993 | : Qnil))); | ||
| 994 | switch (x->type) | ||
| 995 | { | ||
| 996 | case DOMAIN: xsignal (Qdomain_error, args); break; | ||
| 997 | case SING: xsignal (Qsingularity_error, args); break; | ||
| 998 | case OVERFLOW: xsignal (Qoverflow_error, args); break; | ||
| 999 | case UNDERFLOW: xsignal (Qunderflow_error, args); break; | ||
| 1000 | default: xsignal (Qarith_error, args); break; | ||
| 1001 | } | ||
| 1002 | return (1); /* don't set errno or print a message */ | ||
| 1003 | } | ||
| 1004 | #endif /* HAVE_MATHERR */ | ||
| 1005 | |||
| 1006 | void | ||
| 1007 | init_floatfns (void) | ||
| 1008 | { | ||
| 1009 | #ifdef FLOAT_CATCH_SIGILL | ||
| 1010 | signal (SIGILL, float_error); | ||
| 1011 | #endif | ||
| 1012 | in_float = 0; | ||
| 1013 | } | ||
| 1014 | |||
| 1015 | void | 541 | void |
| 1016 | syms_of_floatfns (void) | 542 | syms_of_floatfns (void) |
| 1017 | { | 543 | { |
| @@ -1024,27 +550,9 @@ syms_of_floatfns (void) | |||
| 1024 | defsubr (&Sisnan); | 550 | defsubr (&Sisnan); |
| 1025 | #ifdef HAVE_COPYSIGN | 551 | #ifdef HAVE_COPYSIGN |
| 1026 | defsubr (&Scopysign); | 552 | defsubr (&Scopysign); |
| 553 | #endif | ||
| 1027 | defsubr (&Sfrexp); | 554 | defsubr (&Sfrexp); |
| 1028 | defsubr (&Sldexp); | 555 | defsubr (&Sldexp); |
| 1029 | #endif | ||
| 1030 | #if 0 | ||
| 1031 | defsubr (&Sacosh); | ||
| 1032 | defsubr (&Sasinh); | ||
| 1033 | defsubr (&Satanh); | ||
| 1034 | defsubr (&Scosh); | ||
| 1035 | defsubr (&Ssinh); | ||
| 1036 | defsubr (&Stanh); | ||
| 1037 | defsubr (&Sbessel_y0); | ||
| 1038 | defsubr (&Sbessel_y1); | ||
| 1039 | defsubr (&Sbessel_yn); | ||
| 1040 | defsubr (&Sbessel_j0); | ||
| 1041 | defsubr (&Sbessel_j1); | ||
| 1042 | defsubr (&Sbessel_jn); | ||
| 1043 | defsubr (&Serf); | ||
| 1044 | defsubr (&Serfc); | ||
| 1045 | defsubr (&Slog_gamma); | ||
| 1046 | defsubr (&Scube_root); | ||
| 1047 | #endif | ||
| 1048 | defsubr (&Sfceiling); | 556 | defsubr (&Sfceiling); |
| 1049 | defsubr (&Sffloor); | 557 | defsubr (&Sffloor); |
| 1050 | defsubr (&Sfround); | 558 | defsubr (&Sfround); |
| @@ -1052,7 +560,6 @@ syms_of_floatfns (void) | |||
| 1052 | defsubr (&Sexp); | 560 | defsubr (&Sexp); |
| 1053 | defsubr (&Sexpt); | 561 | defsubr (&Sexpt); |
| 1054 | defsubr (&Slog); | 562 | defsubr (&Slog); |
| 1055 | defsubr (&Slog10); | ||
| 1056 | defsubr (&Ssqrt); | 563 | defsubr (&Ssqrt); |
| 1057 | 564 | ||
| 1058 | defsubr (&Sabs); | 565 | defsubr (&Sabs); |