aboutsummaryrefslogtreecommitdiffstats
path: root/src/floatfns.c
diff options
context:
space:
mode:
authorDaniel Colascione2012-09-17 04:07:36 -0800
committerDaniel Colascione2012-09-17 04:07:36 -0800
commit2ab329f3b5d52a39f0a45c3d9c129f1c19560142 (patch)
tree6dd6784d63e54cb18071df8e28fbdbc27d418728 /src/floatfns.c
parentf701ab72dd55460d23c8b029550aa4d7ecef3cfa (diff)
parentbb7dce392f6d9d5fc4b9d7de09ff920a52f07669 (diff)
downloademacs-2ab329f3b5d52a39f0a45c3d9c129f1c19560142.tar.gz
emacs-2ab329f3b5d52a39f0a45c3d9c129f1c19560142.zip
Merge from trunk
Diffstat (limited to 'src/floatfns.c')
-rw-r--r--src/floatfns.c628
1 files changed, 65 insertions, 563 deletions
diff --git a/src/floatfns.c b/src/floatfns.c
index cad071f1e15..4fe209fcb61 100644
--- a/src/floatfns.c
+++ b/src/floatfns.c
@@ -22,171 +22,32 @@ 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" 34#include "syssignal.h"
55 35
56#include <float.h> 36#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 \ 37#if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
60 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128) 38 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
61#define IEEE_FLOATING_POINT 1 39#define IEEE_FLOATING_POINT 1
62#else 40#else
63#define IEEE_FLOATING_POINT 0 41#define IEEE_FLOATING_POINT 0
64#endif 42#endif
65#endif
66 43
67#include <math.h> 44#include <math.h>
68 45
69/* This declaration is omitted on some systems, like Ultrix. */ 46#ifndef isfinite
70#if !defined (HPUX) && defined (HAVE_LOGB) && !defined (logb) 47# 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 48#endif
84 49#ifndef isnan
85#ifdef HAVE_MATHERR 50# define isnan(x) ((x) != (x))
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
93
94#ifndef NO_FLOAT_CHECK_ERRNO
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 51#endif
191 52
192/* Extract a Lisp number as a `double', or signal an error. */ 53/* Extract a Lisp number as a `double', or signal an error. */
@@ -205,27 +66,19 @@ extract_float (Lisp_Object num)
205 66
206DEFUN ("acos", Facos, Sacos, 1, 1, 0, 67DEFUN ("acos", Facos, Sacos, 1, 1, 0,
207 doc: /* Return the inverse cosine of ARG. */) 68 doc: /* Return the inverse cosine of ARG. */)
208 (register Lisp_Object arg) 69 (Lisp_Object arg)
209{ 70{
210 double d = extract_float (arg); 71 double d = extract_float (arg);
211#ifdef FLOAT_CHECK_DOMAIN 72 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); 73 return make_float (d);
217} 74}
218 75
219DEFUN ("asin", Fasin, Sasin, 1, 1, 0, 76DEFUN ("asin", Fasin, Sasin, 1, 1, 0,
220 doc: /* Return the inverse sine of ARG. */) 77 doc: /* Return the inverse sine of ARG. */)
221 (register Lisp_Object arg) 78 (Lisp_Object arg)
222{ 79{
223 double d = extract_float (arg); 80 double d = extract_float (arg);
224#ifdef FLOAT_CHECK_DOMAIN 81 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); 82 return make_float (d);
230} 83}
231 84
@@ -235,56 +88,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 88If 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) 89divided by X, i.e. the angle in radians between the vector (X, Y)
237and the x-axis. */) 90and the x-axis. */)
238 (register Lisp_Object y, Lisp_Object x) 91 (Lisp_Object y, Lisp_Object x)
239{ 92{
240 double d = extract_float (y); 93 double d = extract_float (y);
241 94
242 if (NILP (x)) 95 if (NILP (x))
243 IN_FLOAT (d = atan (d), "atan", y); 96 d = atan (d);
244 else 97 else
245 { 98 {
246 double d2 = extract_float (x); 99 double d2 = extract_float (x);
247 100 d = atan2 (d, d2);
248 IN_FLOAT2 (d = atan2 (d, d2), "atan", y, x);
249 } 101 }
250 return make_float (d); 102 return make_float (d);
251} 103}
252 104
253DEFUN ("cos", Fcos, Scos, 1, 1, 0, 105DEFUN ("cos", Fcos, Scos, 1, 1, 0,
254 doc: /* Return the cosine of ARG. */) 106 doc: /* Return the cosine of ARG. */)
255 (register Lisp_Object arg) 107 (Lisp_Object arg)
256{ 108{
257 double d = extract_float (arg); 109 double d = extract_float (arg);
258 IN_FLOAT (d = cos (d), "cos", arg); 110 d = cos (d);
259 return make_float (d); 111 return make_float (d);
260} 112}
261 113
262DEFUN ("sin", Fsin, Ssin, 1, 1, 0, 114DEFUN ("sin", Fsin, Ssin, 1, 1, 0,
263 doc: /* Return the sine of ARG. */) 115 doc: /* Return the sine of ARG. */)
264 (register Lisp_Object arg) 116 (Lisp_Object arg)
265{ 117{
266 double d = extract_float (arg); 118 double d = extract_float (arg);
267 IN_FLOAT (d = sin (d), "sin", arg); 119 d = sin (d);
268 return make_float (d); 120 return make_float (d);
269} 121}
270 122
271DEFUN ("tan", Ftan, Stan, 1, 1, 0, 123DEFUN ("tan", Ftan, Stan, 1, 1, 0,
272 doc: /* Return the tangent of ARG. */) 124 doc: /* Return the tangent of ARG. */)
273 (register Lisp_Object arg) 125 (Lisp_Object arg)
274{ 126{
275 double d = extract_float (arg); 127 double d = extract_float (arg);
276 double c = cos (d); 128 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); 129 return make_float (d);
283} 130}
284 131
285#undef isnan
286#define isnan(x) ((x) != (x))
287
288DEFUN ("isnan", Fisnan, Sisnan, 1, 1, 0, 132DEFUN ("isnan", Fisnan, Sisnan, 1, 1, 0,
289 doc: /* Return non nil iff argument X is a NaN. */) 133 doc: /* Return non nil iff argument X is a NaN. */)
290 (Lisp_Object x) 134 (Lisp_Object x)
@@ -309,6 +153,7 @@ Cause an error if X1 or X2 is not a float. */)
309 153
310 return make_float (copysign (f1, f2)); 154 return make_float (copysign (f1, f2));
311} 155}
156#endif
312 157
313DEFUN ("frexp", Ffrexp, Sfrexp, 1, 1, 0, 158DEFUN ("frexp", Ffrexp, Sfrexp, 1, 1, 0,
314 doc: /* Get significand and exponent of a floating point number. 159 doc: /* Get significand and exponent of a floating point number.
@@ -323,15 +168,9 @@ If X is zero, both parts (SGNFCAND and EXP) are zero. */)
323 (Lisp_Object x) 168 (Lisp_Object x)
324{ 169{
325 double f = XFLOATINT (x); 170 double f = XFLOATINT (x);
326 171 int exponent;
327 if (f == 0.0) 172 double sgnfcand = frexp (f, &exponent);
328 return Fcons (make_float (0.0), make_number (0)); 173 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} 174}
336 175
337DEFUN ("ldexp", Fldexp, Sldexp, 1, 2, 0, 176DEFUN ("ldexp", Fldexp, Sldexp, 1, 2, 0,
@@ -343,138 +182,19 @@ Returns the floating point value resulting from multiplying SGNFCAND
343 CHECK_NUMBER (exponent); 182 CHECK_NUMBER (exponent);
344 return make_float (ldexp (XFLOATINT (sgnfcand), XINT (exponent))); 183 return make_float (ldexp (XFLOATINT (sgnfcand), XINT (exponent)));
345} 184}
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 185
459DEFUN ("exp", Fexp, Sexp, 1, 1, 0, 186DEFUN ("exp", Fexp, Sexp, 1, 1, 0,
460 doc: /* Return the exponential base e of ARG. */) 187 doc: /* Return the exponential base e of ARG. */)
461 (register Lisp_Object arg) 188 (Lisp_Object arg)
462{ 189{
463 double d = extract_float (arg); 190 double d = extract_float (arg);
464#ifdef FLOAT_CHECK_DOMAIN 191 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); 192 return make_float (d);
473} 193}
474 194
475DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, 195DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
476 doc: /* Return the exponential ARG1 ** ARG2. */) 196 doc: /* Return the exponential ARG1 ** ARG2. */)
477 (register Lisp_Object arg1, Lisp_Object arg2) 197 (Lisp_Object arg1, Lisp_Object arg2)
478{ 198{
479 double f1, f2, f3; 199 double f1, f2, f3;
480 200
@@ -503,159 +223,48 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
503 } 223 }
504 f1 = FLOATP (arg1) ? XFLOAT_DATA (arg1) : XINT (arg1); 224 f1 = FLOATP (arg1) ? XFLOAT_DATA (arg1) : XINT (arg1);
505 f2 = FLOATP (arg2) ? XFLOAT_DATA (arg2) : XINT (arg2); 225 f2 = FLOATP (arg2) ? XFLOAT_DATA (arg2) : XINT (arg2);
506 /* Really should check for overflow, too */ 226 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); 227 return make_float (f3);
518} 228}
519 229
520DEFUN ("log", Flog, Slog, 1, 2, 0, 230DEFUN ("log", Flog, Slog, 1, 2, 0,
521 doc: /* Return the natural logarithm of ARG. 231 doc: /* Return the natural logarithm of ARG.
522If the optional argument BASE is given, return log ARG using that base. */) 232If the optional argument BASE is given, return log ARG using that base. */)
523 (register Lisp_Object arg, Lisp_Object base) 233 (Lisp_Object arg, Lisp_Object base)
524{ 234{
525 double d = extract_float (arg); 235 double d = extract_float (arg);
526 236
527#ifdef FLOAT_CHECK_DOMAIN
528 if (d <= 0.0)
529 domain_error2 ("log", arg, base);
530#endif
531 if (NILP (base)) 237 if (NILP (base))
532 IN_FLOAT (d = log (d), "log", arg); 238 d = log (d);
533 else 239 else
534 { 240 {
535 double b = extract_float (base); 241 double b = extract_float (base);
536 242
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) 243 if (b == 10.0)
542 IN_FLOAT2 (d = log10 (d), "log", arg, base); 244 d = log10 (d);
543 else 245 else
544 IN_FLOAT2 (d = log (d) / log (b), "log", arg, base); 246 d = log (d) / log (b);
545 } 247 }
546 return make_float (d); 248 return make_float (d);
547} 249}
548 250
549DEFUN ("log10", Flog10, Slog10, 1, 1, 0, 251DEFUN ("log10", Flog10, Slog10, 1, 1, 0,
550 doc: /* Return the logarithm base 10 of ARG. */) 252 doc: /* Return the logarithm base 10 of ARG. */)
551 (register Lisp_Object arg) 253 (Lisp_Object arg)
552{ 254{
553 double d = extract_float (arg); 255 double d = extract_float (arg);
554#ifdef FLOAT_CHECK_DOMAIN 256 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); 257 return make_float (d);
560} 258}
561 259
562DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0, 260DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
563 doc: /* Return the square root of ARG. */) 261 doc: /* Return the square root of ARG. */)
564 (register Lisp_Object arg) 262 (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{ 263{
654 double d = extract_float (arg); 264 double d = extract_float (arg);
655 IN_FLOAT (d = tanh (d), "tanh", arg); 265 d = sqrt (d);
656 return make_float (d); 266 return make_float (d);
657} 267}
658#endif
659 268
660DEFUN ("abs", Fabs, Sabs, 1, 1, 0, 269DEFUN ("abs", Fabs, Sabs, 1, 1, 0,
661 doc: /* Return the absolute value of ARG. */) 270 doc: /* Return the absolute value of ARG. */)
@@ -694,38 +303,15 @@ This is the same as the exponent of a float. */)
694 303
695 if (f == 0.0) 304 if (f == 0.0)
696 value = MOST_NEGATIVE_FIXNUM; 305 value = MOST_NEGATIVE_FIXNUM;
697 else 306 else if (isfinite (f))
698 { 307 {
699#ifdef HAVE_LOGB
700 IN_FLOAT (value = logb (f), "logb", arg);
701#else
702#ifdef HAVE_FREXP
703 int ivalue; 308 int ivalue;
704 IN_FLOAT (frexp (f, &ivalue), "logb", arg); 309 frexp (f, &ivalue);
705 value = ivalue - 1; 310 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 } 311 }
312 else
313 value = MOST_POSITIVE_FIXNUM;
314
729 XSETINT (val, value); 315 XSETINT (val, value);
730 return val; 316 return val;
731} 317}
@@ -756,8 +342,10 @@ rounding_driver (Lisp_Object arg, Lisp_Object divisor,
756 if (! IEEE_FLOATING_POINT && f2 == 0) 342 if (! IEEE_FLOATING_POINT && f2 == 0)
757 xsignal0 (Qarith_error); 343 xsignal0 (Qarith_error);
758 344
759 IN_FLOAT2 (f1 = (*double_round) (f1 / f2), name, arg, divisor); 345 f1 = (*double_round) (f1 / f2);
760 FLOAT_TO_INT2 (f1, arg, name, arg, divisor); 346 if (FIXNUM_OVERFLOW_P (f1))
347 xsignal3 (Qrange_error, build_string (name), arg, divisor);
348 arg = make_number (f1);
761 return arg; 349 return arg;
762 } 350 }
763 351
@@ -773,10 +361,10 @@ rounding_driver (Lisp_Object arg, Lisp_Object divisor,
773 361
774 if (FLOATP (arg)) 362 if (FLOATP (arg))
775 { 363 {
776 double d; 364 double d = (*double_round) (XFLOAT_DATA (arg));
777 365 if (FIXNUM_OVERFLOW_P (d))
778 IN_FLOAT (d = (*double_round) (XFLOAT_DATA (arg)), name, arg); 366 xsignal2 (Qrange_error, build_string (name), arg);
779 FLOAT_TO_INT (d, arg, name, arg); 367 arg = make_number (d);
780 } 368 }
781 369
782 return arg; 370 return arg;
@@ -893,125 +481,57 @@ fmod_float (Lisp_Object x, Lisp_Object y)
893 f1 = FLOATP (x) ? XFLOAT_DATA (x) : XINT (x); 481 f1 = FLOATP (x) ? XFLOAT_DATA (x) : XINT (x);
894 f2 = FLOATP (y) ? XFLOAT_DATA (y) : XINT (y); 482 f2 = FLOATP (y) ? XFLOAT_DATA (y) : XINT (y);
895 483
896 if (! IEEE_FLOATING_POINT && f2 == 0) 484 f1 = fmod (f1, f2);
897 xsignal0 (Qarith_error);
898 485
899 /* If the "remainder" comes out with the wrong sign, fix it. */ 486 /* If the "remainder" comes out with the wrong sign, fix it. */
900 IN_FLOAT2 ((f1 = fmod (f1, f2), 487 if (f2 < 0 ? 0 < f1 : f1 < 0)
901 f1 = (f2 < 0 ? f1 > 0 : f1 < 0) ? f1 + f2 : f1), 488 f1 += f2;
902 "mod", x, y); 489
903 return make_float (f1); 490 return make_float (f1);
904} 491}
905 492
906/* It's not clear these are worth adding. */
907
908DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0, 493DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0,
909 doc: /* Return the smallest integer no less than ARG, as a float. 494 doc: /* Return the smallest integer no less than ARG, as a float.
910\(Round toward +inf.\) */) 495\(Round toward +inf.\) */)
911 (register Lisp_Object arg) 496 (Lisp_Object arg)
912{ 497{
913 double d = extract_float (arg); 498 double d = extract_float (arg);
914 IN_FLOAT (d = ceil (d), "fceiling", arg); 499 d = ceil (d);
915 return make_float (d); 500 return make_float (d);
916} 501}
917 502
918DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0, 503DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0,
919 doc: /* Return the largest integer no greater than ARG, as a float. 504 doc: /* Return the largest integer no greater than ARG, as a float.
920\(Round towards -inf.\) */) 505\(Round towards -inf.\) */)
921 (register Lisp_Object arg) 506 (Lisp_Object arg)
922{ 507{
923 double d = extract_float (arg); 508 double d = extract_float (arg);
924 IN_FLOAT (d = floor (d), "ffloor", arg); 509 d = floor (d);
925 return make_float (d); 510 return make_float (d);
926} 511}
927 512
928DEFUN ("fround", Ffround, Sfround, 1, 1, 0, 513DEFUN ("fround", Ffround, Sfround, 1, 1, 0,
929 doc: /* Return the nearest integer to ARG, as a float. */) 514 doc: /* Return the nearest integer to ARG, as a float. */)
930 (register Lisp_Object arg) 515 (Lisp_Object arg)
931{ 516{
932 double d = extract_float (arg); 517 double d = extract_float (arg);
933 IN_FLOAT (d = emacs_rint (d), "fround", arg); 518 d = emacs_rint (d);
934 return make_float (d); 519 return make_float (d);
935} 520}
936 521
937DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0, 522DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0,
938 doc: /* Truncate a floating point number to an integral float value. 523 doc: /* Truncate a floating point number to an integral float value.
939Rounds the value toward zero. */) 524Rounds the value toward zero. */)
940 (register Lisp_Object arg) 525 (Lisp_Object arg)
941{ 526{
942 double d = extract_float (arg); 527 double d = extract_float (arg);
943 if (d >= 0.0) 528 if (d >= 0.0)
944 IN_FLOAT (d = floor (d), "ftruncate", arg); 529 d = floor (d);
945 else 530 else
946 IN_FLOAT (d = ceil (d), "ftruncate", arg); 531 d = ceil (d);
947 return make_float (d); 532 return make_float (d);
948} 533}
949 534
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 535void
1016syms_of_floatfns (void) 536syms_of_floatfns (void)
1017{ 537{
@@ -1024,27 +544,9 @@ syms_of_floatfns (void)
1024 defsubr (&Sisnan); 544 defsubr (&Sisnan);
1025#ifdef HAVE_COPYSIGN 545#ifdef HAVE_COPYSIGN
1026 defsubr (&Scopysign); 546 defsubr (&Scopysign);
547#endif
1027 defsubr (&Sfrexp); 548 defsubr (&Sfrexp);
1028 defsubr (&Sldexp); 549 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); 550 defsubr (&Sfceiling);
1049 defsubr (&Sffloor); 551 defsubr (&Sffloor);
1050 defsubr (&Sfround); 552 defsubr (&Sfround);