aboutsummaryrefslogtreecommitdiffstats
path: root/src/floatfns.c
diff options
context:
space:
mode:
authorTom Tromey2012-12-17 07:56:22 -0700
committerTom Tromey2012-12-17 07:56:22 -0700
commit3d6eced1ae51ffd0a782130e7c334052277e2724 (patch)
tree5d1d2ad7cd3374f922886c4a72062511a035c168 /src/floatfns.c
parentbf69f522a9e135f9aa483cedd53e71e915f2bf75 (diff)
parent7c3d167f48d6262ee4e5512aa50a07ee96bc1509 (diff)
downloademacs-3d6eced1ae51ffd0a782130e7c334052277e2724.tar.gz
emacs-3d6eced1ae51ffd0a782130e7c334052277e2724.zip
merge from trunk
Diffstat (limited to 'src/floatfns.c')
-rw-r--r--src/floatfns.c637
1 files changed, 65 insertions, 572 deletions
diff --git a/src/floatfns.c b/src/floatfns.c
index cad071f1e15..645a5957609 100644
--- a/src/floatfns.c
+++ b/src/floatfns.c
@@ -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)
@@ -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
@@ -503,159 +214,48 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
503 } 214 }
504 f1 = FLOATP (arg1) ? XFLOAT_DATA (arg1) : XINT (arg1); 215 f1 = FLOATP (arg1) ? XFLOAT_DATA (arg1) : XINT (arg1);
505 f2 = FLOATP (arg2) ? XFLOAT_DATA (arg2) : XINT (arg2); 216 f2 = FLOATP (arg2) ? XFLOAT_DATA (arg2) : XINT (arg2);
506 /* Really should check for overflow, too */ 217 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); 218 return make_float (f3);
518} 219}
519 220
520DEFUN ("log", Flog, Slog, 1, 2, 0, 221DEFUN ("log", Flog, Slog, 1, 2, 0,
521 doc: /* Return the natural logarithm of ARG. 222 doc: /* Return the natural logarithm of ARG.
522If 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. */)
523 (register Lisp_Object arg, Lisp_Object base) 224 (Lisp_Object arg, Lisp_Object base)
524{ 225{
525 double d = extract_float (arg); 226 double d = extract_float (arg);
526 227
527#ifdef FLOAT_CHECK_DOMAIN
528 if (d <= 0.0)
529 domain_error2 ("log", arg, base);
530#endif
531 if (NILP (base)) 228 if (NILP (base))
532 IN_FLOAT (d = log (d), "log", arg); 229 d = log (d);
533 else 230 else
534 { 231 {
535 double b = extract_float (base); 232 double b = extract_float (base);
536 233
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) 234 if (b == 10.0)
542 IN_FLOAT2 (d = log10 (d), "log", arg, base); 235 d = log10 (d);
543 else 236 else
544 IN_FLOAT2 (d = log (d) / log (b), "log", arg, base); 237 d = log (d) / log (b);
545 } 238 }
546 return make_float (d); 239 return make_float (d);
547} 240}
548 241
549DEFUN ("log10", Flog10, Slog10, 1, 1, 0, 242DEFUN ("log10", Flog10, Slog10, 1, 1, 0,
550 doc: /* Return the logarithm base 10 of ARG. */) 243 doc: /* Return the logarithm base 10 of ARG. */)
551 (register Lisp_Object arg) 244 (Lisp_Object arg)
552{ 245{
553 double d = extract_float (arg); 246 double d = extract_float (arg);
554#ifdef FLOAT_CHECK_DOMAIN 247 d = log10 (d);
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); 248 return make_float (d);
560} 249}
561 250
562DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0, 251DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
563 doc: /* Return the square root of ARG. */) 252 doc: /* Return the square root of ARG. */)
564 (register Lisp_Object arg) 253 (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{ 254{
654 double d = extract_float (arg); 255 double d = extract_float (arg);
655 IN_FLOAT (d = tanh (d), "tanh", arg); 256 d = sqrt (d);
656 return make_float (d); 257 return make_float (d);
657} 258}
658#endif
659 259
660DEFUN ("abs", Fabs, Sabs, 1, 1, 0, 260DEFUN ("abs", Fabs, Sabs, 1, 1, 0,
661 doc: /* Return the absolute value of ARG. */) 261 doc: /* Return the absolute value of ARG. */)
@@ -694,38 +294,15 @@ This is the same as the exponent of a float. */)
694 294
695 if (f == 0.0) 295 if (f == 0.0)
696 value = MOST_NEGATIVE_FIXNUM; 296 value = MOST_NEGATIVE_FIXNUM;
697 else 297 else if (isfinite (f))
698 { 298 {
699#ifdef HAVE_LOGB
700 IN_FLOAT (value = logb (f), "logb", arg);
701#else
702#ifdef HAVE_FREXP
703 int ivalue; 299 int ivalue;
704 IN_FLOAT (frexp (f, &ivalue), "logb", arg); 300 frexp (f, &ivalue);
705 value = ivalue - 1; 301 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 } 302 }
303 else
304 value = MOST_POSITIVE_FIXNUM;
305
729 XSETINT (val, value); 306 XSETINT (val, value);
730 return val; 307 return val;
731} 308}
@@ -756,8 +333,10 @@ rounding_driver (Lisp_Object arg, Lisp_Object divisor,
756 if (! IEEE_FLOATING_POINT && f2 == 0) 333 if (! IEEE_FLOATING_POINT && f2 == 0)
757 xsignal0 (Qarith_error); 334 xsignal0 (Qarith_error);
758 335
759 IN_FLOAT2 (f1 = (*double_round) (f1 / f2), name, arg, divisor); 336 f1 = (*double_round) (f1 / f2);
760 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);
761 return arg; 340 return arg;
762 } 341 }
763 342
@@ -773,10 +352,10 @@ rounding_driver (Lisp_Object arg, Lisp_Object divisor,
773 352
774 if (FLOATP (arg)) 353 if (FLOATP (arg))
775 { 354 {
776 double d; 355 double d = (*double_round) (XFLOAT_DATA (arg));
777 356 if (FIXNUM_OVERFLOW_P (d))
778 IN_FLOAT (d = (*double_round) (XFLOAT_DATA (arg)), name, arg); 357 xsignal2 (Qrange_error, build_string (name), arg);
779 FLOAT_TO_INT (d, arg, name, arg); 358 arg = make_number (d);
780 } 359 }
781 360
782 return arg; 361 return arg;
@@ -893,125 +472,57 @@ fmod_float (Lisp_Object x, Lisp_Object y)
893 f1 = FLOATP (x) ? XFLOAT_DATA (x) : XINT (x); 472 f1 = FLOATP (x) ? XFLOAT_DATA (x) : XINT (x);
894 f2 = FLOATP (y) ? XFLOAT_DATA (y) : XINT (y); 473 f2 = FLOATP (y) ? XFLOAT_DATA (y) : XINT (y);
895 474
896 if (! IEEE_FLOATING_POINT && f2 == 0) 475 f1 = fmod (f1, f2);
897 xsignal0 (Qarith_error);
898 476
899 /* If the "remainder" comes out with the wrong sign, fix it. */ 477 /* If the "remainder" comes out with the wrong sign, fix it. */
900 IN_FLOAT2 ((f1 = fmod (f1, f2), 478 if (f2 < 0 ? 0 < f1 : f1 < 0)
901 f1 = (f2 < 0 ? f1 > 0 : f1 < 0) ? f1 + f2 : f1), 479 f1 += f2;
902 "mod", x, y); 480
903 return make_float (f1); 481 return make_float (f1);
904} 482}
905 483
906/* It's not clear these are worth adding. */
907
908DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0, 484DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0,
909 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.
910\(Round toward +inf.\) */) 486\(Round toward +inf.\) */)
911 (register Lisp_Object arg) 487 (Lisp_Object arg)
912{ 488{
913 double d = extract_float (arg); 489 double d = extract_float (arg);
914 IN_FLOAT (d = ceil (d), "fceiling", arg); 490 d = ceil (d);
915 return make_float (d); 491 return make_float (d);
916} 492}
917 493
918DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0, 494DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0,
919 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.
920\(Round towards -inf.\) */) 496\(Round towards -inf.\) */)
921 (register Lisp_Object arg) 497 (Lisp_Object arg)
922{ 498{
923 double d = extract_float (arg); 499 double d = extract_float (arg);
924 IN_FLOAT (d = floor (d), "ffloor", arg); 500 d = floor (d);
925 return make_float (d); 501 return make_float (d);
926} 502}
927 503
928DEFUN ("fround", Ffround, Sfround, 1, 1, 0, 504DEFUN ("fround", Ffround, Sfround, 1, 1, 0,
929 doc: /* Return the nearest integer to ARG, as a float. */) 505 doc: /* Return the nearest integer to ARG, as a float. */)
930 (register Lisp_Object arg) 506 (Lisp_Object arg)
931{ 507{
932 double d = extract_float (arg); 508 double d = extract_float (arg);
933 IN_FLOAT (d = emacs_rint (d), "fround", arg); 509 d = emacs_rint (d);
934 return make_float (d); 510 return make_float (d);
935} 511}
936 512
937DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0, 513DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0,
938 doc: /* Truncate a floating point number to an integral float value. 514 doc: /* Truncate a floating point number to an integral float value.
939Rounds the value toward zero. */) 515Rounds the value toward zero. */)
940 (register Lisp_Object arg) 516 (Lisp_Object arg)
941{ 517{
942 double d = extract_float (arg); 518 double d = extract_float (arg);
943 if (d >= 0.0) 519 if (d >= 0.0)
944 IN_FLOAT (d = floor (d), "ftruncate", arg); 520 d = floor (d);
945 else 521 else
946 IN_FLOAT (d = ceil (d), "ftruncate", arg); 522 d = ceil (d);
947 return make_float (d); 523 return make_float (d);
948} 524}
949 525
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 526void
1016syms_of_floatfns (void) 527syms_of_floatfns (void)
1017{ 528{
@@ -1024,27 +535,9 @@ syms_of_floatfns (void)
1024 defsubr (&Sisnan); 535 defsubr (&Sisnan);
1025#ifdef HAVE_COPYSIGN 536#ifdef HAVE_COPYSIGN
1026 defsubr (&Scopysign); 537 defsubr (&Scopysign);
538#endif
1027 defsubr (&Sfrexp); 539 defsubr (&Sfrexp);
1028 defsubr (&Sldexp); 540 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); 541 defsubr (&Sfceiling);
1049 defsubr (&Sffloor); 542 defsubr (&Sffloor);
1050 defsubr (&Sfround); 543 defsubr (&Sfround);