aboutsummaryrefslogtreecommitdiffstats
path: root/src/floatfns.c
diff options
context:
space:
mode:
Diffstat (limited to 'src/floatfns.c')
-rw-r--r--src/floatfns.c675
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
3Copyright (C) 1988, 1993-1994, 1999, 2001-2012 3Copyright (C) 1988, 1993-1994, 1999, 2001-2013 Free Software Foundation,
4 Free Software Foundation, Inc. 4Inc.
5 5
6Author: Wolfgang Rupprecht 6Author: 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
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 [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)
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 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. */
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 57
160/* Convert float to Lisp_Int if it fits, else signal a range error 58static void
161 using the given arguments. */ 59CHECK_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
206DEFUN ("acos", Facos, Sacos, 1, 1, 0, 78DEFUN ("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
219DEFUN ("asin", Fasin, Sasin, 1, 1, 0, 87DEFUN ("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.
235If two arguments Y and X are given, return the inverse tangent of Y 99If 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) 100divided by X, i.e. the angle in radians between the vector (X, Y)
237and the x-axis. */) 101and 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
253DEFUN ("cos", Fcos, Scos, 1, 1, 0, 116DEFUN ("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
262DEFUN ("sin", Fsin, Ssin, 1, 1, 0, 125DEFUN ("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
271DEFUN ("tan", Ftan, Stan, 1, 1, 0, 134DEFUN ("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
288DEFUN ("isnan", Fisnan, Sisnan, 1, 1, 0, 143DEFUN ("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
313DEFUN ("frexp", Ffrexp, Sfrexp, 1, 1, 0, 169DEFUN ("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
337DEFUN ("ldexp", Fldexp, Sldexp, 1, 2, 0, 187DEFUN ("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
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 196
459DEFUN ("exp", Fexp, Sexp, 1, 1, 0, 197DEFUN ("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
475DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, 206DEFUN ("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
520DEFUN ("log", Flog, Slog, 1, 2, 0, 241DEFUN ("log", Flog, Slog, 1, 2, 0,
521 doc: /* Return the natural logarithm of ARG. 242 doc: /* Return the natural logarithm of ARG.
522If the optional argument BASE is given, return log ARG using that base. */) 243If 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
549DEFUN ("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
562DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0, 266DEFUN ("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
577DEFUN ("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
594DEFUN ("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
607DEFUN ("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
624DEFUN ("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
637DEFUN ("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
650DEFUN ("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
660DEFUN ("abs", Fabs, Sabs, 1, 1, 0, 275DEFUN ("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
908DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0, 499DEFUN ("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
918DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0, 509DEFUN ("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
928DEFUN ("fround", Ffround, Sfround, 1, 1, 0, 519DEFUN ("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
937DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0, 528DEFUN ("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.
939Rounds the value toward zero. */) 530Rounds 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
951static void
952float_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
976int
977matherr (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
1006void
1007init_floatfns (void)
1008{
1009#ifdef FLOAT_CATCH_SIGILL
1010 signal (SIGILL, float_error);
1011#endif
1012 in_float = 0;
1013}
1014
1015void 541void
1016syms_of_floatfns (void) 542syms_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);