aboutsummaryrefslogtreecommitdiffstats
path: root/src/floatfns.c
diff options
context:
space:
mode:
authorBill Wohler2012-11-24 19:43:02 -0800
committerBill Wohler2012-11-24 19:43:02 -0800
commit5244bc019bf7376caff3bb198ff674e0ad9fb0e6 (patch)
tree02ee1615e904771f692ec2957c79a08ae029a13d /src/floatfns.c
parent9f7e719509474e92f85955e22e57ffeebd4e96f3 (diff)
parentc07a6ded1df2f4156badc9add2953579622c3722 (diff)
downloademacs-5244bc019bf7376caff3bb198ff674e0ad9fb0e6.tar.gz
emacs-5244bc019bf7376caff3bb198ff674e0ad9fb0e6.zip
Merge from trunk.
Diffstat (limited to 'src/floatfns.c')
-rw-r--r--src/floatfns.c669
1 files changed, 75 insertions, 594 deletions
diff --git a/src/floatfns.c b/src/floatfns.c
index 2011b4d942d..645a5957609 100644
--- a/src/floatfns.c
+++ b/src/floatfns.c
@@ -1,6 +1,6 @@
1/* Primitive operations on floating point for GNU Emacs Lisp interpreter. 1/* Primitive operations on floating point for GNU Emacs Lisp interpreter.
2 2
3Copyright (C) 1988, 1993-1994, 1999, 2001-2011 3Copyright (C) 1988, 1993-1994, 1999, 2001-2012
4 Free Software Foundation, Inc. 4 Free Software Foundation, Inc.
5 5
6Author: Wolfgang Rupprecht 6Author: Wolfgang Rupprecht
@@ -22,171 +22,23 @@ You should have received a copy of the GNU General Public License
22along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ 22along 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, *modf, pow, sin, *sinh, sqrt, tan, *tanh.
29 Define HAVE_INVERSE_HYPERBOLIC if you have acosh, asinh, and atanh.
30 Define HAVE_CBRT if you have cbrt.
31 Define HAVE_RINT if you have a working rint.
32 If you don't define these, then the appropriate routines will be simulated.
33
34 Define HAVE_MATHERR if on a system supporting the SysV matherr callback.
35 (This should happen automatically.)
36
37 Define FLOAT_CHECK_ERRNO if the float library routines set errno.
38 This has no effect if HAVE_MATHERR is defined.
39
40 Define FLOAT_CATCH_SIGILL if the float library routines signal SIGILL.
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 */ 29 */
49 30
50#include <config.h> 31#include <config.h>
51#include <signal.h> 32
52#include <setjmp.h>
53#include "lisp.h" 33#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 34
67#include <math.h> 35#include <math.h>
68 36
69/* This declaration is omitted on some systems, like Ultrix. */ 37#ifndef isfinite
70#if !defined (HPUX) && defined (HAVE_LOGB) && !defined (logb) 38# define isfinite(x) ((x) - (x) == 0)
71extern 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 39#endif
93 40#ifndef isnan
94#ifndef NO_FLOAT_CHECK_ERRNO 41# define isnan(x) ((x) != (x))
95#define FLOAT_CHECK_ERRNO
96#endif
97
98#ifdef FLOAT_CHECK_ERRNO
99# include <errno.h>
100#endif
101
102#ifdef FLOAT_CATCH_SIGILL
103static void float_error ();
104#endif
105
106/* Nonzero while executing in floating point.
107 This tells float_error what to do. */
108
109static 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
116static Lisp_Object float_error_arg, float_error_arg2;
117
118static 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
160/* Convert float to Lisp_Int if it fits, else signal a range error
161 using the given arguments. */
162#define FLOAT_TO_INT(x, i, name, num) \
163 do \
164 { \
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 42#endif
191 43
192/* Extract a Lisp number as a `double', or signal an error. */ 44/* Extract a Lisp number as a `double', or signal an error. */
@@ -205,27 +57,19 @@ extract_float (Lisp_Object num)
205 57
206DEFUN ("acos", Facos, Sacos, 1, 1, 0, 58DEFUN ("acos", Facos, Sacos, 1, 1, 0,
207 doc: /* Return the inverse cosine of ARG. */) 59 doc: /* Return the inverse cosine of ARG. */)
208 (register Lisp_Object arg) 60 (Lisp_Object arg)
209{ 61{
210 double d = extract_float (arg); 62 double d = extract_float (arg);
211#ifdef FLOAT_CHECK_DOMAIN 63 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); 64 return make_float (d);
217} 65}
218 66
219DEFUN ("asin", Fasin, Sasin, 1, 1, 0, 67DEFUN ("asin", Fasin, Sasin, 1, 1, 0,
220 doc: /* Return the inverse sine of ARG. */) 68 doc: /* Return the inverse sine of ARG. */)
221 (register Lisp_Object arg) 69 (Lisp_Object arg)
222{ 70{
223 double d = extract_float (arg); 71 double d = extract_float (arg);
224#ifdef FLOAT_CHECK_DOMAIN 72 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); 73 return make_float (d);
230} 74}
231 75
@@ -235,56 +79,47 @@ If only one argument Y is given, return the inverse tangent of Y.
235If two arguments Y and X are given, return the inverse tangent of Y 79If two arguments Y and X are given, return the inverse tangent of Y
236divided by X, i.e. the angle in radians between the vector (X, Y) 80divided by X, i.e. the angle in radians between the vector (X, Y)
237and the x-axis. */) 81and the x-axis. */)
238 (register Lisp_Object y, Lisp_Object x) 82 (Lisp_Object y, Lisp_Object x)
239{ 83{
240 double d = extract_float (y); 84 double d = extract_float (y);
241 85
242 if (NILP (x)) 86 if (NILP (x))
243 IN_FLOAT (d = atan (d), "atan", y); 87 d = atan (d);
244 else 88 else
245 { 89 {
246 double d2 = extract_float (x); 90 double d2 = extract_float (x);
247 91 d = atan2 (d, d2);
248 IN_FLOAT2 (d = atan2 (d, d2), "atan", y, x);
249 } 92 }
250 return make_float (d); 93 return make_float (d);
251} 94}
252 95
253DEFUN ("cos", Fcos, Scos, 1, 1, 0, 96DEFUN ("cos", Fcos, Scos, 1, 1, 0,
254 doc: /* Return the cosine of ARG. */) 97 doc: /* Return the cosine of ARG. */)
255 (register Lisp_Object arg) 98 (Lisp_Object arg)
256{ 99{
257 double d = extract_float (arg); 100 double d = extract_float (arg);
258 IN_FLOAT (d = cos (d), "cos", arg); 101 d = cos (d);
259 return make_float (d); 102 return make_float (d);
260} 103}
261 104
262DEFUN ("sin", Fsin, Ssin, 1, 1, 0, 105DEFUN ("sin", Fsin, Ssin, 1, 1, 0,
263 doc: /* Return the sine of ARG. */) 106 doc: /* Return the sine of ARG. */)
264 (register Lisp_Object arg) 107 (Lisp_Object arg)
265{ 108{
266 double d = extract_float (arg); 109 double d = extract_float (arg);
267 IN_FLOAT (d = sin (d), "sin", arg); 110 d = sin (d);
268 return make_float (d); 111 return make_float (d);
269} 112}
270 113
271DEFUN ("tan", Ftan, Stan, 1, 1, 0, 114DEFUN ("tan", Ftan, Stan, 1, 1, 0,
272 doc: /* Return the tangent of ARG. */) 115 doc: /* Return the tangent of ARG. */)
273 (register Lisp_Object arg) 116 (Lisp_Object arg)
274{ 117{
275 double d = extract_float (arg); 118 double d = extract_float (arg);
276 double c = cos (d); 119 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); 120 return make_float (d);
283} 121}
284 122
285#undef isnan
286#define isnan(x) ((x) != (x))
287
288DEFUN ("isnan", Fisnan, Sisnan, 1, 1, 0, 123DEFUN ("isnan", Fisnan, Sisnan, 1, 1, 0,
289 doc: /* Return non nil iff argument X is a NaN. */) 124 doc: /* Return non nil iff argument X is a NaN. */)
290 (Lisp_Object x) 125 (Lisp_Object x)
@@ -294,7 +129,7 @@ DEFUN ("isnan", Fisnan, Sisnan, 1, 1, 0,
294} 129}
295 130
296#ifdef HAVE_COPYSIGN 131#ifdef HAVE_COPYSIGN
297DEFUN ("copysign", Fcopysign, Scopysign, 1, 2, 0, 132DEFUN ("copysign", Fcopysign, Scopysign, 2, 2, 0,
298 doc: /* Copy sign of X2 to value of X1, and return the result. 133 doc: /* Copy sign of X2 to value of X1, and return the result.
299Cause an error if X1 or X2 is not a float. */) 134Cause an error if X1 or X2 is not a float. */)
300 (Lisp_Object x1, Lisp_Object x2) 135 (Lisp_Object x1, Lisp_Object x2)
@@ -309,6 +144,7 @@ Cause an error if X1 or X2 is not a float. */)
309 144
310 return make_float (copysign (f1, f2)); 145 return make_float (copysign (f1, f2));
311} 146}
147#endif
312 148
313DEFUN ("frexp", Ffrexp, Sfrexp, 1, 1, 0, 149DEFUN ("frexp", Ffrexp, Sfrexp, 1, 1, 0,
314 doc: /* Get significand and exponent of a floating point number. 150 doc: /* Get significand and exponent of a floating point number.
@@ -323,15 +159,9 @@ If X is zero, both parts (SGNFCAND and EXP) are zero. */)
323 (Lisp_Object x) 159 (Lisp_Object x)
324{ 160{
325 double f = XFLOATINT (x); 161 double f = XFLOATINT (x);
326 162 int exponent;
327 if (f == 0.0) 163 double sgnfcand = frexp (f, &exponent);
328 return Fcons (make_float (0.0), make_number (0)); 164 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} 165}
336 166
337DEFUN ("ldexp", Fldexp, Sldexp, 1, 2, 0, 167DEFUN ("ldexp", Fldexp, Sldexp, 1, 2, 0,
@@ -343,138 +173,19 @@ Returns the floating point value resulting from multiplying SGNFCAND
343 CHECK_NUMBER (exponent); 173 CHECK_NUMBER (exponent);
344 return make_float (ldexp (XFLOATINT (sgnfcand), XINT (exponent))); 174 return make_float (ldexp (XFLOATINT (sgnfcand), XINT (exponent)));
345} 175}
346#endif
347
348#if 0 /* Leave these out unless we find there's a reason for them. */
349
350DEFUN ("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
359DEFUN ("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
368DEFUN ("bessel-jn", Fbessel_jn, Sbessel_jn, 2, 2, 0,
369 doc: /* Return the order N bessel function output jn of ARG.
370The 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
380DEFUN ("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
389DEFUN ("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
398DEFUN ("bessel-yn", Fbessel_yn, Sbessel_yn, 2, 2, 0,
399 doc: /* Return the order N bessel function output yn of ARG.
400The 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
414DEFUN ("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
423DEFUN ("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
432DEFUN ("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
441DEFUN ("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 176
459DEFUN ("exp", Fexp, Sexp, 1, 1, 0, 177DEFUN ("exp", Fexp, Sexp, 1, 1, 0,
460 doc: /* Return the exponential base e of ARG. */) 178 doc: /* Return the exponential base e of ARG. */)
461 (register Lisp_Object arg) 179 (Lisp_Object arg)
462{ 180{
463 double d = extract_float (arg); 181 double d = extract_float (arg);
464#ifdef FLOAT_CHECK_DOMAIN 182 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); 183 return make_float (d);
473} 184}
474 185
475DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, 186DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
476 doc: /* Return the exponential ARG1 ** ARG2. */) 187 doc: /* Return the exponential ARG1 ** ARG2. */)
477 (register Lisp_Object arg1, Lisp_Object arg2) 188 (Lisp_Object arg1, Lisp_Object arg2)
478{ 189{
479 double f1, f2, f3; 190 double f1, f2, f3;
480 191
@@ -484,190 +195,67 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
484 && INTEGERP (arg2) /* don't promote, if both are ints, and */ 195 && INTEGERP (arg2) /* don't promote, if both are ints, and */
485 && 0 <= XINT (arg2)) /* we are sure the result is not fractional */ 196 && 0 <= XINT (arg2)) /* we are sure the result is not fractional */
486 { /* this can be improved by pre-calculating */ 197 { /* this can be improved by pre-calculating */
487 EMACS_INT acc, x, y; /* some binary powers of x then accumulating */ 198 EMACS_INT y; /* some binary powers of x then accumulating */
199 EMACS_UINT acc, x; /* Unsigned so that overflow is well defined. */
488 Lisp_Object val; 200 Lisp_Object val;
489 201
490 x = XINT (arg1); 202 x = XINT (arg1);
491 y = XINT (arg2); 203 y = XINT (arg2);
492 acc = 1; 204 acc = (y & 1 ? x : 1);
493 205
494 if (y < 0) 206 while ((y >>= 1) != 0)
495 {
496 if (x == 1)
497 acc = 1;
498 else if (x == -1)
499 acc = (y & 1) ? -1 : 1;
500 else
501 acc = 0;
502 }
503 else
504 { 207 {
505 while (y > 0) 208 x *= x;
506 { 209 if (y & 1)
507 if (y & 1) 210 acc *= x;
508 acc *= x;
509 x *= x;
510 y >>= 1;
511 }
512 } 211 }
513 XSETINT (val, acc); 212 XSETINT (val, acc);
514 return val; 213 return val;
515 } 214 }
516 f1 = FLOATP (arg1) ? XFLOAT_DATA (arg1) : XINT (arg1); 215 f1 = FLOATP (arg1) ? XFLOAT_DATA (arg1) : XINT (arg1);
517 f2 = FLOATP (arg2) ? XFLOAT_DATA (arg2) : XINT (arg2); 216 f2 = FLOATP (arg2) ? XFLOAT_DATA (arg2) : XINT (arg2);
518 /* Really should check for overflow, too */ 217 f3 = pow (f1, f2);
519 if (f1 == 0.0 && f2 == 0.0)
520 f1 = 1.0;
521#ifdef FLOAT_CHECK_DOMAIN
522 else if ((f1 == 0.0 && f2 < 0.0) || (f1 < 0 && f2 != floor (f2)))
523 domain_error2 ("expt", arg1, arg2);
524#endif
525 IN_FLOAT2 (f3 = pow (f1, f2), "expt", arg1, arg2);
526 /* Check for overflow in the result. */
527 if (f1 != 0.0 && f3 == 0.0)
528 range_error ("expt", arg1);
529 return make_float (f3); 218 return make_float (f3);
530} 219}
531 220
532DEFUN ("log", Flog, Slog, 1, 2, 0, 221DEFUN ("log", Flog, Slog, 1, 2, 0,
533 doc: /* Return the natural logarithm of ARG. 222 doc: /* Return the natural logarithm of ARG.
534If the optional argument BASE is given, return log ARG using that base. */) 223If the optional argument BASE is given, return log ARG using that base. */)
535 (register Lisp_Object arg, Lisp_Object base) 224 (Lisp_Object arg, Lisp_Object base)
536{ 225{
537 double d = extract_float (arg); 226 double d = extract_float (arg);
538 227
539#ifdef FLOAT_CHECK_DOMAIN
540 if (d <= 0.0)
541 domain_error2 ("log", arg, base);
542#endif
543 if (NILP (base)) 228 if (NILP (base))
544 IN_FLOAT (d = log (d), "log", arg); 229 d = log (d);
545 else 230 else
546 { 231 {
547 double b = extract_float (base); 232 double b = extract_float (base);
548 233
549#ifdef FLOAT_CHECK_DOMAIN
550 if (b <= 0.0 || b == 1.0)
551 domain_error2 ("log", arg, base);
552#endif
553 if (b == 10.0) 234 if (b == 10.0)
554 IN_FLOAT2 (d = log10 (d), "log", arg, base); 235 d = log10 (d);
555 else 236 else
556 IN_FLOAT2 (d = log (d) / log (b), "log", arg, base); 237 d = log (d) / log (b);
557 } 238 }
558 return make_float (d); 239 return make_float (d);
559} 240}
560 241
561DEFUN ("log10", Flog10, Slog10, 1, 1, 0, 242DEFUN ("log10", Flog10, Slog10, 1, 1, 0,
562 doc: /* Return the logarithm base 10 of ARG. */) 243 doc: /* Return the logarithm base 10 of ARG. */)
563 (register Lisp_Object arg) 244 (Lisp_Object arg)
564{ 245{
565 double d = extract_float (arg); 246 double d = extract_float (arg);
566#ifdef FLOAT_CHECK_DOMAIN 247 d = log10 (d);
567 if (d <= 0.0)
568 domain_error ("log10", arg);
569#endif
570 IN_FLOAT (d = log10 (d), "log10", arg);
571 return make_float (d); 248 return make_float (d);
572} 249}
573 250
574DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0, 251DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
575 doc: /* Return the square root of ARG. */) 252 doc: /* Return the square root of ARG. */)
576 (register Lisp_Object arg) 253 (Lisp_Object arg)
577{
578 double d = extract_float (arg);
579#ifdef FLOAT_CHECK_DOMAIN
580 if (d < 0.0)
581 domain_error ("sqrt", arg);
582#endif
583 IN_FLOAT (d = sqrt (d), "sqrt", arg);
584 return make_float (d);
585}
586
587#if 0 /* Not clearly worth adding. */
588
589DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0,
590 doc: /* Return the inverse hyperbolic cosine of ARG. */)
591 (register Lisp_Object arg)
592{
593 double d = extract_float (arg);
594#ifdef FLOAT_CHECK_DOMAIN
595 if (d < 1.0)
596 domain_error ("acosh", arg);
597#endif
598#ifdef HAVE_INVERSE_HYPERBOLIC
599 IN_FLOAT (d = acosh (d), "acosh", arg);
600#else
601 IN_FLOAT (d = log (d + sqrt (d*d - 1.0)), "acosh", arg);
602#endif
603 return make_float (d);
604}
605
606DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0,
607 doc: /* Return the inverse hyperbolic sine of ARG. */)
608 (register Lisp_Object arg)
609{
610 double d = extract_float (arg);
611#ifdef HAVE_INVERSE_HYPERBOLIC
612 IN_FLOAT (d = asinh (d), "asinh", arg);
613#else
614 IN_FLOAT (d = log (d + sqrt (d*d + 1.0)), "asinh", arg);
615#endif
616 return make_float (d);
617}
618
619DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0,
620 doc: /* Return the inverse hyperbolic tangent of ARG. */)
621 (register Lisp_Object arg)
622{
623 double d = extract_float (arg);
624#ifdef FLOAT_CHECK_DOMAIN
625 if (d >= 1.0 || d <= -1.0)
626 domain_error ("atanh", arg);
627#endif
628#ifdef HAVE_INVERSE_HYPERBOLIC
629 IN_FLOAT (d = atanh (d), "atanh", arg);
630#else
631 IN_FLOAT (d = 0.5 * log ((1.0 + d) / (1.0 - d)), "atanh", arg);
632#endif
633 return make_float (d);
634}
635
636DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0,
637 doc: /* Return the hyperbolic cosine of ARG. */)
638 (register Lisp_Object arg)
639{
640 double d = extract_float (arg);
641#ifdef FLOAT_CHECK_DOMAIN
642 if (d > 710.0 || d < -710.0)
643 range_error ("cosh", arg);
644#endif
645 IN_FLOAT (d = cosh (d), "cosh", arg);
646 return make_float (d);
647}
648
649DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0,
650 doc: /* Return the hyperbolic sine of ARG. */)
651 (register Lisp_Object arg)
652{
653 double d = extract_float (arg);
654#ifdef FLOAT_CHECK_DOMAIN
655 if (d > 710.0 || d < -710.0)
656 range_error ("sinh", arg);
657#endif
658 IN_FLOAT (d = sinh (d), "sinh", arg);
659 return make_float (d);
660}
661
662DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0,
663 doc: /* Return the hyperbolic tangent of ARG. */)
664 (register Lisp_Object arg)
665{ 254{
666 double d = extract_float (arg); 255 double d = extract_float (arg);
667 IN_FLOAT (d = tanh (d), "tanh", arg); 256 d = sqrt (d);
668 return make_float (d); 257 return make_float (d);
669} 258}
670#endif
671 259
672DEFUN ("abs", Fabs, Sabs, 1, 1, 0, 260DEFUN ("abs", Fabs, Sabs, 1, 1, 0,
673 doc: /* Return the absolute value of ARG. */) 261 doc: /* Return the absolute value of ARG. */)
@@ -676,7 +264,7 @@ DEFUN ("abs", Fabs, Sabs, 1, 1, 0,
676 CHECK_NUMBER_OR_FLOAT (arg); 264 CHECK_NUMBER_OR_FLOAT (arg);
677 265
678 if (FLOATP (arg)) 266 if (FLOATP (arg))
679 IN_FLOAT (arg = make_float (fabs (XFLOAT_DATA (arg))), "abs", arg); 267 arg = make_float (fabs (XFLOAT_DATA (arg)));
680 else if (XINT (arg) < 0) 268 else if (XINT (arg) < 0)
681 XSETINT (arg, - XINT (arg)); 269 XSETINT (arg, - XINT (arg));
682 270
@@ -706,38 +294,15 @@ This is the same as the exponent of a float. */)
706 294
707 if (f == 0.0) 295 if (f == 0.0)
708 value = MOST_NEGATIVE_FIXNUM; 296 value = MOST_NEGATIVE_FIXNUM;
709 else 297 else if (isfinite (f))
710 { 298 {
711#ifdef HAVE_LOGB
712 IN_FLOAT (value = logb (f), "logb", arg);
713#else
714#ifdef HAVE_FREXP
715 int ivalue; 299 int ivalue;
716 IN_FLOAT (frexp (f, &ivalue), "logb", arg); 300 frexp (f, &ivalue);
717 value = ivalue - 1; 301 value = ivalue - 1;
718#else
719 int i;
720 double d;
721 if (f < 0.0)
722 f = -f;
723 value = -1;
724 while (f < 0.5)
725 {
726 for (i = 1, d = 0.5; d * d >= f; i += i)
727 d *= d;
728 f /= d;
729 value -= i;
730 }
731 while (f >= 1.0)
732 {
733 for (i = 1, d = 2.0; d * d <= f; i += i)
734 d *= d;
735 f /= d;
736 value += i;
737 }
738#endif
739#endif
740 } 302 }
303 else
304 value = MOST_POSITIVE_FIXNUM;
305
741 XSETINT (val, value); 306 XSETINT (val, value);
742 return val; 307 return val;
743} 308}
@@ -768,8 +333,10 @@ rounding_driver (Lisp_Object arg, Lisp_Object divisor,
768 if (! IEEE_FLOATING_POINT && f2 == 0) 333 if (! IEEE_FLOATING_POINT && f2 == 0)
769 xsignal0 (Qarith_error); 334 xsignal0 (Qarith_error);
770 335
771 IN_FLOAT2 (f1 = (*double_round) (f1 / f2), name, arg, divisor); 336 f1 = (*double_round) (f1 / f2);
772 FLOAT_TO_INT2 (f1, arg, name, arg, divisor); 337 if (FIXNUM_OVERFLOW_P (f1))
338 xsignal3 (Qrange_error, build_string (name), arg, divisor);
339 arg = make_number (f1);
773 return arg; 340 return arg;
774 } 341 }
775 342
@@ -785,10 +352,10 @@ rounding_driver (Lisp_Object arg, Lisp_Object divisor,
785 352
786 if (FLOATP (arg)) 353 if (FLOATP (arg))
787 { 354 {
788 double d; 355 double d = (*double_round) (XFLOAT_DATA (arg));
789 356 if (FIXNUM_OVERFLOW_P (d))
790 IN_FLOAT (d = (*double_round) (XFLOAT_DATA (arg)), name, arg); 357 xsignal2 (Qrange_error, build_string (name), arg);
791 FLOAT_TO_INT (d, arg, name, arg); 358 arg = make_number (d);
792 } 359 }
793 360
794 return arg; 361 return arg;
@@ -905,125 +472,57 @@ fmod_float (Lisp_Object x, Lisp_Object y)
905 f1 = FLOATP (x) ? XFLOAT_DATA (x) : XINT (x); 472 f1 = FLOATP (x) ? XFLOAT_DATA (x) : XINT (x);
906 f2 = FLOATP (y) ? XFLOAT_DATA (y) : XINT (y); 473 f2 = FLOATP (y) ? XFLOAT_DATA (y) : XINT (y);
907 474
908 if (! IEEE_FLOATING_POINT && f2 == 0) 475 f1 = fmod (f1, f2);
909 xsignal0 (Qarith_error);
910 476
911 /* If the "remainder" comes out with the wrong sign, fix it. */ 477 /* If the "remainder" comes out with the wrong sign, fix it. */
912 IN_FLOAT2 ((f1 = fmod (f1, f2), 478 if (f2 < 0 ? 0 < f1 : f1 < 0)
913 f1 = (f2 < 0 ? f1 > 0 : f1 < 0) ? f1 + f2 : f1), 479 f1 += f2;
914 "mod", x, y); 480
915 return make_float (f1); 481 return make_float (f1);
916} 482}
917 483
918/* It's not clear these are worth adding. */
919
920DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0, 484DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0,
921 doc: /* Return the smallest integer no less than ARG, as a float. 485 doc: /* Return the smallest integer no less than ARG, as a float.
922\(Round toward +inf.\) */) 486\(Round toward +inf.\) */)
923 (register Lisp_Object arg) 487 (Lisp_Object arg)
924{ 488{
925 double d = extract_float (arg); 489 double d = extract_float (arg);
926 IN_FLOAT (d = ceil (d), "fceiling", arg); 490 d = ceil (d);
927 return make_float (d); 491 return make_float (d);
928} 492}
929 493
930DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0, 494DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0,
931 doc: /* Return the largest integer no greater than ARG, as a float. 495 doc: /* Return the largest integer no greater than ARG, as a float.
932\(Round towards -inf.\) */) 496\(Round towards -inf.\) */)
933 (register Lisp_Object arg) 497 (Lisp_Object arg)
934{ 498{
935 double d = extract_float (arg); 499 double d = extract_float (arg);
936 IN_FLOAT (d = floor (d), "ffloor", arg); 500 d = floor (d);
937 return make_float (d); 501 return make_float (d);
938} 502}
939 503
940DEFUN ("fround", Ffround, Sfround, 1, 1, 0, 504DEFUN ("fround", Ffround, Sfround, 1, 1, 0,
941 doc: /* Return the nearest integer to ARG, as a float. */) 505 doc: /* Return the nearest integer to ARG, as a float. */)
942 (register Lisp_Object arg) 506 (Lisp_Object arg)
943{ 507{
944 double d = extract_float (arg); 508 double d = extract_float (arg);
945 IN_FLOAT (d = emacs_rint (d), "fround", arg); 509 d = emacs_rint (d);
946 return make_float (d); 510 return make_float (d);
947} 511}
948 512
949DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0, 513DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0,
950 doc: /* Truncate a floating point number to an integral float value. 514 doc: /* Truncate a floating point number to an integral float value.
951Rounds the value toward zero. */) 515Rounds the value toward zero. */)
952 (register Lisp_Object arg) 516 (Lisp_Object arg)
953{ 517{
954 double d = extract_float (arg); 518 double d = extract_float (arg);
955 if (d >= 0.0) 519 if (d >= 0.0)
956 IN_FLOAT (d = floor (d), "ftruncate", arg); 520 d = floor (d);
957 else 521 else
958 IN_FLOAT (d = ceil (d), "ftruncate", arg); 522 d = ceil (d);
959 return make_float (d); 523 return make_float (d);
960} 524}
961 525
962#ifdef FLOAT_CATCH_SIGILL
963static void
964float_error (int signo)
965{
966 if (! in_float)
967 fatal_error_signal (signo);
968
969#ifdef BSD_SYSTEM
970 sigsetmask (SIGEMPTYMASK);
971#else
972 /* Must reestablish handler each time it is called. */
973 signal (SIGILL, float_error);
974#endif /* BSD_SYSTEM */
975
976 SIGNAL_THREAD_CHECK (signo);
977 in_float = 0;
978
979 xsignal1 (Qarith_error, float_error_arg);
980}
981
982/* Another idea was to replace the library function `infnan'
983 where SIGILL is signaled. */
984
985#endif /* FLOAT_CATCH_SIGILL */
986
987#ifdef HAVE_MATHERR
988int
989matherr (struct exception *x)
990{
991 Lisp_Object args;
992 const char *name = x->name;
993
994 if (! in_float)
995 /* Not called from emacs-lisp float routines; do the default thing. */
996 return 0;
997 if (!strcmp (x->name, "pow"))
998 name = "expt";
999
1000 args
1001 = Fcons (build_string (name),
1002 Fcons (make_float (x->arg1),
1003 ((!strcmp (name, "log") || !strcmp (name, "pow"))
1004 ? Fcons (make_float (x->arg2), Qnil)
1005 : Qnil)));
1006 switch (x->type)
1007 {
1008 case DOMAIN: xsignal (Qdomain_error, args); break;
1009 case SING: xsignal (Qsingularity_error, args); break;
1010 case OVERFLOW: xsignal (Qoverflow_error, args); break;
1011 case UNDERFLOW: xsignal (Qunderflow_error, args); break;
1012 default: xsignal (Qarith_error, args); break;
1013 }
1014 return (1); /* don't set errno or print a message */
1015}
1016#endif /* HAVE_MATHERR */
1017
1018void
1019init_floatfns (void)
1020{
1021#ifdef FLOAT_CATCH_SIGILL
1022 signal (SIGILL, float_error);
1023#endif
1024 in_float = 0;
1025}
1026
1027void 526void
1028syms_of_floatfns (void) 527syms_of_floatfns (void)
1029{ 528{
@@ -1036,27 +535,9 @@ syms_of_floatfns (void)
1036 defsubr (&Sisnan); 535 defsubr (&Sisnan);
1037#ifdef HAVE_COPYSIGN 536#ifdef HAVE_COPYSIGN
1038 defsubr (&Scopysign); 537 defsubr (&Scopysign);
538#endif
1039 defsubr (&Sfrexp); 539 defsubr (&Sfrexp);
1040 defsubr (&Sldexp); 540 defsubr (&Sldexp);
1041#endif
1042#if 0
1043 defsubr (&Sacosh);
1044 defsubr (&Sasinh);
1045 defsubr (&Satanh);
1046 defsubr (&Scosh);
1047 defsubr (&Ssinh);
1048 defsubr (&Stanh);
1049 defsubr (&Sbessel_y0);
1050 defsubr (&Sbessel_y1);
1051 defsubr (&Sbessel_yn);
1052 defsubr (&Sbessel_j0);
1053 defsubr (&Sbessel_j1);
1054 defsubr (&Sbessel_jn);
1055 defsubr (&Serf);
1056 defsubr (&Serfc);
1057 defsubr (&Slog_gamma);
1058 defsubr (&Scube_root);
1059#endif
1060 defsubr (&Sfceiling); 541 defsubr (&Sfceiling);
1061 defsubr (&Sffloor); 542 defsubr (&Sffloor);
1062 defsubr (&Sfround); 543 defsubr (&Sfround);