aboutsummaryrefslogtreecommitdiffstats
path: root/src/floatfns.c
diff options
context:
space:
mode:
authorJoakim Verona2012-09-10 16:03:53 +0200
committerJoakim Verona2012-09-10 16:03:53 +0200
commitb035a30e5cd2f34fedc04c253eeb5a11afed8145 (patch)
treeb9350cce389602f4967bdc1beed745929155ad5d /src/floatfns.c
parent4a37733c693d59a9b83a3fb2d0c7f9461d149f60 (diff)
parenta31a4cdacb196cc96dcb9bd229edb1d635e01344 (diff)
downloademacs-b035a30e5cd2f34fedc04c253eeb5a11afed8145.tar.gz
emacs-b035a30e5cd2f34fedc04c253eeb5a11afed8145.zip
upstream
Diffstat (limited to 'src/floatfns.c')
-rw-r--r--src/floatfns.c471
1 files changed, 83 insertions, 388 deletions
diff --git a/src/floatfns.c b/src/floatfns.c
index cad071f1e15..8a9a9fd0886 100644
--- a/src/floatfns.c
+++ b/src/floatfns.c
@@ -22,47 +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 these math.h functions:
26 acos, asin, atan, atan2, ceil, cos, cosh, exp, fabs, floor, fmod, 26 acos, asin, atan, atan2, ceil, cos, cosh, exp, fabs, floor, fmod,
27 frexp, ldexp, log, log10, modf, pow, sin, sinh, sqrt, tan, tanh. 27 frexp, ldexp, log, log10, modf, pow, sin, sinh, sqrt, tan, tanh.
28
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 */ 28 */
49 29
50#include <config.h> 30#include <config.h>
51#include <signal.h>
52#include <setjmp.h> 31#include <setjmp.h>
53#include "lisp.h" 32#include "lisp.h"
54#include "syssignal.h" 33#include "syssignal.h"
55 34
56#include <float.h> 35#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 \ 36#if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
60 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128) 37 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
61#define IEEE_FLOATING_POINT 1 38#define IEEE_FLOATING_POINT 1
62#else 39#else
63#define IEEE_FLOATING_POINT 0 40#define IEEE_FLOATING_POINT 0
64#endif 41#endif
65#endif
66 42
67#include <math.h> 43#include <math.h>
68 44
@@ -71,124 +47,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
71extern double logb (double); 47extern double logb (double);
72#endif /* not HPUX and HAVE_LOGB and no logb macro */ 48#endif /* not HPUX and HAVE_LOGB and no logb macro */
73 49
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
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
191
192/* Extract a Lisp number as a `double', or signal an error. */ 50/* Extract a Lisp number as a `double', or signal an error. */
193 51
194double 52double
@@ -205,27 +63,19 @@ extract_float (Lisp_Object num)
205 63
206DEFUN ("acos", Facos, Sacos, 1, 1, 0, 64DEFUN ("acos", Facos, Sacos, 1, 1, 0,
207 doc: /* Return the inverse cosine of ARG. */) 65 doc: /* Return the inverse cosine of ARG. */)
208 (register Lisp_Object arg) 66 (Lisp_Object arg)
209{ 67{
210 double d = extract_float (arg); 68 double d = extract_float (arg);
211#ifdef FLOAT_CHECK_DOMAIN 69 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); 70 return make_float (d);
217} 71}
218 72
219DEFUN ("asin", Fasin, Sasin, 1, 1, 0, 73DEFUN ("asin", Fasin, Sasin, 1, 1, 0,
220 doc: /* Return the inverse sine of ARG. */) 74 doc: /* Return the inverse sine of ARG. */)
221 (register Lisp_Object arg) 75 (Lisp_Object arg)
222{ 76{
223 double d = extract_float (arg); 77 double d = extract_float (arg);
224#ifdef FLOAT_CHECK_DOMAIN 78 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); 79 return make_float (d);
230} 80}
231 81
@@ -235,50 +85,44 @@ 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 85If 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) 86divided by X, i.e. the angle in radians between the vector (X, Y)
237and the x-axis. */) 87and the x-axis. */)
238 (register Lisp_Object y, Lisp_Object x) 88 (Lisp_Object y, Lisp_Object x)
239{ 89{
240 double d = extract_float (y); 90 double d = extract_float (y);
241 91
242 if (NILP (x)) 92 if (NILP (x))
243 IN_FLOAT (d = atan (d), "atan", y); 93 d = atan (d);
244 else 94 else
245 { 95 {
246 double d2 = extract_float (x); 96 double d2 = extract_float (x);
247 97 d = atan2 (d, d2);
248 IN_FLOAT2 (d = atan2 (d, d2), "atan", y, x);
249 } 98 }
250 return make_float (d); 99 return make_float (d);
251} 100}
252 101
253DEFUN ("cos", Fcos, Scos, 1, 1, 0, 102DEFUN ("cos", Fcos, Scos, 1, 1, 0,
254 doc: /* Return the cosine of ARG. */) 103 doc: /* Return the cosine of ARG. */)
255 (register Lisp_Object arg) 104 (Lisp_Object arg)
256{ 105{
257 double d = extract_float (arg); 106 double d = extract_float (arg);
258 IN_FLOAT (d = cos (d), "cos", arg); 107 d = cos (d);
259 return make_float (d); 108 return make_float (d);
260} 109}
261 110
262DEFUN ("sin", Fsin, Ssin, 1, 1, 0, 111DEFUN ("sin", Fsin, Ssin, 1, 1, 0,
263 doc: /* Return the sine of ARG. */) 112 doc: /* Return the sine of ARG. */)
264 (register Lisp_Object arg) 113 (Lisp_Object arg)
265{ 114{
266 double d = extract_float (arg); 115 double d = extract_float (arg);
267 IN_FLOAT (d = sin (d), "sin", arg); 116 d = sin (d);
268 return make_float (d); 117 return make_float (d);
269} 118}
270 119
271DEFUN ("tan", Ftan, Stan, 1, 1, 0, 120DEFUN ("tan", Ftan, Stan, 1, 1, 0,
272 doc: /* Return the tangent of ARG. */) 121 doc: /* Return the tangent of ARG. */)
273 (register Lisp_Object arg) 122 (Lisp_Object arg)
274{ 123{
275 double d = extract_float (arg); 124 double d = extract_float (arg);
276 double c = cos (d); 125 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); 126 return make_float (d);
283} 127}
284 128
@@ -349,61 +193,61 @@ Returns the floating point value resulting from multiplying SGNFCAND
349 193
350DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0, 194DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0,
351 doc: /* Return the bessel function j0 of ARG. */) 195 doc: /* Return the bessel function j0 of ARG. */)
352 (register Lisp_Object arg) 196 (Lisp_Object arg)
353{ 197{
354 double d = extract_float (arg); 198 double d = extract_float (arg);
355 IN_FLOAT (d = j0 (d), "bessel-j0", arg); 199 d = j0 (d);
356 return make_float (d); 200 return make_float (d);
357} 201}
358 202
359DEFUN ("bessel-j1", Fbessel_j1, Sbessel_j1, 1, 1, 0, 203DEFUN ("bessel-j1", Fbessel_j1, Sbessel_j1, 1, 1, 0,
360 doc: /* Return the bessel function j1 of ARG. */) 204 doc: /* Return the bessel function j1 of ARG. */)
361 (register Lisp_Object arg) 205 (Lisp_Object arg)
362{ 206{
363 double d = extract_float (arg); 207 double d = extract_float (arg);
364 IN_FLOAT (d = j1 (d), "bessel-j1", arg); 208 d = j1 (d);
365 return make_float (d); 209 return make_float (d);
366} 210}
367 211
368DEFUN ("bessel-jn", Fbessel_jn, Sbessel_jn, 2, 2, 0, 212DEFUN ("bessel-jn", Fbessel_jn, Sbessel_jn, 2, 2, 0,
369 doc: /* Return the order N bessel function output jn of ARG. 213 doc: /* Return the order N bessel function output jn of ARG.
370The first arg (the order) is truncated to an integer. */) 214The first arg (the order) is truncated to an integer. */)
371 (register Lisp_Object n, Lisp_Object arg) 215 (Lisp_Object n, Lisp_Object arg)
372{ 216{
373 int i1 = extract_float (n); 217 int i1 = extract_float (n);
374 double f2 = extract_float (arg); 218 double f2 = extract_float (arg);
375 219
376 IN_FLOAT (f2 = jn (i1, f2), "bessel-jn", n); 220 f2 = jn (i1, f2);
377 return make_float (f2); 221 return make_float (f2);
378} 222}
379 223
380DEFUN ("bessel-y0", Fbessel_y0, Sbessel_y0, 1, 1, 0, 224DEFUN ("bessel-y0", Fbessel_y0, Sbessel_y0, 1, 1, 0,
381 doc: /* Return the bessel function y0 of ARG. */) 225 doc: /* Return the bessel function y0 of ARG. */)
382 (register Lisp_Object arg) 226 (Lisp_Object arg)
383{ 227{
384 double d = extract_float (arg); 228 double d = extract_float (arg);
385 IN_FLOAT (d = y0 (d), "bessel-y0", arg); 229 d = y0 (d);
386 return make_float (d); 230 return make_float (d);
387} 231}
388 232
389DEFUN ("bessel-y1", Fbessel_y1, Sbessel_y1, 1, 1, 0, 233DEFUN ("bessel-y1", Fbessel_y1, Sbessel_y1, 1, 1, 0,
390 doc: /* Return the bessel function y1 of ARG. */) 234 doc: /* Return the bessel function y1 of ARG. */)
391 (register Lisp_Object arg) 235 (Lisp_Object arg)
392{ 236{
393 double d = extract_float (arg); 237 double d = extract_float (arg);
394 IN_FLOAT (d = y1 (d), "bessel-y0", arg); 238 d = y1 (d);
395 return make_float (d); 239 return make_float (d);
396} 240}
397 241
398DEFUN ("bessel-yn", Fbessel_yn, Sbessel_yn, 2, 2, 0, 242DEFUN ("bessel-yn", Fbessel_yn, Sbessel_yn, 2, 2, 0,
399 doc: /* Return the order N bessel function output yn of ARG. 243 doc: /* Return the order N bessel function output yn of ARG.
400The first arg (the order) is truncated to an integer. */) 244The first arg (the order) is truncated to an integer. */)
401 (register Lisp_Object n, Lisp_Object arg) 245 (Lisp_Object n, Lisp_Object arg)
402{ 246{
403 int i1 = extract_float (n); 247 int i1 = extract_float (n);
404 double f2 = extract_float (arg); 248 double f2 = extract_float (arg);
405 249
406 IN_FLOAT (f2 = yn (i1, f2), "bessel-yn", n); 250 f2 = yn (i1, f2);
407 return make_float (f2); 251 return make_float (f2);
408} 252}
409 253
@@ -413,43 +257,43 @@ The first arg (the order) is truncated to an integer. */)
413 257
414DEFUN ("erf", Ferf, Serf, 1, 1, 0, 258DEFUN ("erf", Ferf, Serf, 1, 1, 0,
415 doc: /* Return the mathematical error function of ARG. */) 259 doc: /* Return the mathematical error function of ARG. */)
416 (register Lisp_Object arg) 260 (Lisp_Object arg)
417{ 261{
418 double d = extract_float (arg); 262 double d = extract_float (arg);
419 IN_FLOAT (d = erf (d), "erf", arg); 263 d = erf (d);
420 return make_float (d); 264 return make_float (d);
421} 265}
422 266
423DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0, 267DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0,
424 doc: /* Return the complementary error function of ARG. */) 268 doc: /* Return the complementary error function of ARG. */)
425 (register Lisp_Object arg) 269 (Lisp_Object arg)
426{ 270{
427 double d = extract_float (arg); 271 double d = extract_float (arg);
428 IN_FLOAT (d = erfc (d), "erfc", arg); 272 d = erfc (d);
429 return make_float (d); 273 return make_float (d);
430} 274}
431 275
432DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0, 276DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0,
433 doc: /* Return the log gamma of ARG. */) 277 doc: /* Return the log gamma of ARG. */)
434 (register Lisp_Object arg) 278 (Lisp_Object arg)
435{ 279{
436 double d = extract_float (arg); 280 double d = extract_float (arg);
437 IN_FLOAT (d = lgamma (d), "log-gamma", arg); 281 d = lgamma (d);
438 return make_float (d); 282 return make_float (d);
439} 283}
440 284
441DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0, 285DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0,
442 doc: /* Return the cube root of ARG. */) 286 doc: /* Return the cube root of ARG. */)
443 (register Lisp_Object arg) 287 (Lisp_Object arg)
444{ 288{
445 double d = extract_float (arg); 289 double d = extract_float (arg);
446#ifdef HAVE_CBRT 290#ifdef HAVE_CBRT
447 IN_FLOAT (d = cbrt (d), "cube-root", arg); 291 d = cbrt (d);
448#else 292#else
449 if (d >= 0.0) 293 if (d >= 0.0)
450 IN_FLOAT (d = pow (d, 1.0/3.0), "cube-root", arg); 294 d = pow (d, 1.0/3.0);
451 else 295 else
452 IN_FLOAT (d = -pow (-d, 1.0/3.0), "cube-root", arg); 296 d = -pow (-d, 1.0/3.0);
453#endif 297#endif
454 return make_float (d); 298 return make_float (d);
455} 299}
@@ -458,23 +302,16 @@ DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0,
458 302
459DEFUN ("exp", Fexp, Sexp, 1, 1, 0, 303DEFUN ("exp", Fexp, Sexp, 1, 1, 0,
460 doc: /* Return the exponential base e of ARG. */) 304 doc: /* Return the exponential base e of ARG. */)
461 (register Lisp_Object arg) 305 (Lisp_Object arg)
462{ 306{
463 double d = extract_float (arg); 307 double d = extract_float (arg);
464#ifdef FLOAT_CHECK_DOMAIN 308 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); 309 return make_float (d);
473} 310}
474 311
475DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, 312DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
476 doc: /* Return the exponential ARG1 ** ARG2. */) 313 doc: /* Return the exponential ARG1 ** ARG2. */)
477 (register Lisp_Object arg1, Lisp_Object arg2) 314 (Lisp_Object arg1, Lisp_Object arg2)
478{ 315{
479 double f1, f2, f3; 316 double f1, f2, f3;
480 317
@@ -503,72 +340,46 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
503 } 340 }
504 f1 = FLOATP (arg1) ? XFLOAT_DATA (arg1) : XINT (arg1); 341 f1 = FLOATP (arg1) ? XFLOAT_DATA (arg1) : XINT (arg1);
505 f2 = FLOATP (arg2) ? XFLOAT_DATA (arg2) : XINT (arg2); 342 f2 = FLOATP (arg2) ? XFLOAT_DATA (arg2) : XINT (arg2);
506 /* Really should check for overflow, too */ 343 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); 344 return make_float (f3);
518} 345}
519 346
520DEFUN ("log", Flog, Slog, 1, 2, 0, 347DEFUN ("log", Flog, Slog, 1, 2, 0,
521 doc: /* Return the natural logarithm of ARG. 348 doc: /* Return the natural logarithm of ARG.
522If the optional argument BASE is given, return log ARG using that base. */) 349If the optional argument BASE is given, return log ARG using that base. */)
523 (register Lisp_Object arg, Lisp_Object base) 350 (Lisp_Object arg, Lisp_Object base)
524{ 351{
525 double d = extract_float (arg); 352 double d = extract_float (arg);
526 353
527#ifdef FLOAT_CHECK_DOMAIN
528 if (d <= 0.0)
529 domain_error2 ("log", arg, base);
530#endif
531 if (NILP (base)) 354 if (NILP (base))
532 IN_FLOAT (d = log (d), "log", arg); 355 d = log (d);
533 else 356 else
534 { 357 {
535 double b = extract_float (base); 358 double b = extract_float (base);
536 359
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) 360 if (b == 10.0)
542 IN_FLOAT2 (d = log10 (d), "log", arg, base); 361 d = log10 (d);
543 else 362 else
544 IN_FLOAT2 (d = log (d) / log (b), "log", arg, base); 363 d = log (d) / log (b);
545 } 364 }
546 return make_float (d); 365 return make_float (d);
547} 366}
548 367
549DEFUN ("log10", Flog10, Slog10, 1, 1, 0, 368DEFUN ("log10", Flog10, Slog10, 1, 1, 0,
550 doc: /* Return the logarithm base 10 of ARG. */) 369 doc: /* Return the logarithm base 10 of ARG. */)
551 (register Lisp_Object arg) 370 (Lisp_Object arg)
552{ 371{
553 double d = extract_float (arg); 372 double d = extract_float (arg);
554#ifdef FLOAT_CHECK_DOMAIN 373 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); 374 return make_float (d);
560} 375}
561 376
562DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0, 377DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
563 doc: /* Return the square root of ARG. */) 378 doc: /* Return the square root of ARG. */)
564 (register Lisp_Object arg) 379 (Lisp_Object arg)
565{ 380{
566 double d = extract_float (arg); 381 double d = extract_float (arg);
567#ifdef FLOAT_CHECK_DOMAIN 382 d = sqrt (d);
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); 383 return make_float (d);
573} 384}
574 385
@@ -576,83 +387,55 @@ DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
576 387
577DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0, 388DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0,
578 doc: /* Return the inverse hyperbolic cosine of ARG. */) 389 doc: /* Return the inverse hyperbolic cosine of ARG. */)
579 (register Lisp_Object arg) 390 (Lisp_Object arg)
580{ 391{
581 double d = extract_float (arg); 392 double d = extract_float (arg);
582#ifdef FLOAT_CHECK_DOMAIN 393 d = acosh (d);
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); 394 return make_float (d);
592} 395}
593 396
594DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0, 397DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0,
595 doc: /* Return the inverse hyperbolic sine of ARG. */) 398 doc: /* Return the inverse hyperbolic sine of ARG. */)
596 (register Lisp_Object arg) 399 (Lisp_Object arg)
597{ 400{
598 double d = extract_float (arg); 401 double d = extract_float (arg);
599#ifdef HAVE_INVERSE_HYPERBOLIC 402 d = asinh (d);
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); 403 return make_float (d);
605} 404}
606 405
607DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0, 406DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0,
608 doc: /* Return the inverse hyperbolic tangent of ARG. */) 407 doc: /* Return the inverse hyperbolic tangent of ARG. */)
609 (register Lisp_Object arg) 408 (Lisp_Object arg)
610{ 409{
611 double d = extract_float (arg); 410 double d = extract_float (arg);
612#ifdef FLOAT_CHECK_DOMAIN 411 d = atanh (d);
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); 412 return make_float (d);
622} 413}
623 414
624DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0, 415DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0,
625 doc: /* Return the hyperbolic cosine of ARG. */) 416 doc: /* Return the hyperbolic cosine of ARG. */)
626 (register Lisp_Object arg) 417 (Lisp_Object arg)
627{ 418{
628 double d = extract_float (arg); 419 double d = extract_float (arg);
629#ifdef FLOAT_CHECK_DOMAIN 420 d = cosh (d);
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); 421 return make_float (d);
635} 422}
636 423
637DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0, 424DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0,
638 doc: /* Return the hyperbolic sine of ARG. */) 425 doc: /* Return the hyperbolic sine of ARG. */)
639 (register Lisp_Object arg) 426 (Lisp_Object arg)
640{ 427{
641 double d = extract_float (arg); 428 double d = extract_float (arg);
642#ifdef FLOAT_CHECK_DOMAIN 429 d = sinh (d);
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); 430 return make_float (d);
648} 431}
649 432
650DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0, 433DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0,
651 doc: /* Return the hyperbolic tangent of ARG. */) 434 doc: /* Return the hyperbolic tangent of ARG. */)
652 (register Lisp_Object arg) 435 (Lisp_Object arg)
653{ 436{
654 double d = extract_float (arg); 437 double d = extract_float (arg);
655 IN_FLOAT (d = tanh (d), "tanh", arg); 438 d = tanh (d);
656 return make_float (d); 439 return make_float (d);
657} 440}
658#endif 441#endif
@@ -697,33 +480,11 @@ This is the same as the exponent of a float. */)
697 else 480 else
698 { 481 {
699#ifdef HAVE_LOGB 482#ifdef HAVE_LOGB
700 IN_FLOAT (value = logb (f), "logb", arg); 483 value = logb (f);
701#else 484#else
702#ifdef HAVE_FREXP
703 int ivalue; 485 int ivalue;
704 IN_FLOAT (frexp (f, &ivalue), "logb", arg); 486 frexp (f, &ivalue);
705 value = ivalue - 1; 487 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 488#endif
728 } 489 }
729 XSETINT (val, value); 490 XSETINT (val, value);
@@ -756,8 +517,10 @@ rounding_driver (Lisp_Object arg, Lisp_Object divisor,
756 if (! IEEE_FLOATING_POINT && f2 == 0) 517 if (! IEEE_FLOATING_POINT && f2 == 0)
757 xsignal0 (Qarith_error); 518 xsignal0 (Qarith_error);
758 519
759 IN_FLOAT2 (f1 = (*double_round) (f1 / f2), name, arg, divisor); 520 f1 = (*double_round) (f1 / f2);
760 FLOAT_TO_INT2 (f1, arg, name, arg, divisor); 521 if (FIXNUM_OVERFLOW_P (f1))
522 xsignal3 (Qrange_error, build_string (name), arg, divisor);
523 arg = make_number (f1);
761 return arg; 524 return arg;
762 } 525 }
763 526
@@ -773,10 +536,10 @@ rounding_driver (Lisp_Object arg, Lisp_Object divisor,
773 536
774 if (FLOATP (arg)) 537 if (FLOATP (arg))
775 { 538 {
776 double d; 539 double d = (*double_round) (XFLOAT_DATA (arg));
777 540 if (FIXNUM_OVERFLOW_P (d))
778 IN_FLOAT (d = (*double_round) (XFLOAT_DATA (arg)), name, arg); 541 xsignal2 (Qrange_error, build_string (name), arg);
779 FLOAT_TO_INT (d, arg, name, arg); 542 arg = make_number (d);
780 } 543 }
781 544
782 return arg; 545 return arg;
@@ -893,125 +656,57 @@ fmod_float (Lisp_Object x, Lisp_Object y)
893 f1 = FLOATP (x) ? XFLOAT_DATA (x) : XINT (x); 656 f1 = FLOATP (x) ? XFLOAT_DATA (x) : XINT (x);
894 f2 = FLOATP (y) ? XFLOAT_DATA (y) : XINT (y); 657 f2 = FLOATP (y) ? XFLOAT_DATA (y) : XINT (y);
895 658
896 if (! IEEE_FLOATING_POINT && f2 == 0) 659 f1 = fmod (f1, f2);
897 xsignal0 (Qarith_error);
898 660
899 /* If the "remainder" comes out with the wrong sign, fix it. */ 661 /* If the "remainder" comes out with the wrong sign, fix it. */
900 IN_FLOAT2 ((f1 = fmod (f1, f2), 662 if (f2 < 0 ? 0 < f1 : f1 < 0)
901 f1 = (f2 < 0 ? f1 > 0 : f1 < 0) ? f1 + f2 : f1), 663 f1 += f2;
902 "mod", x, y); 664
903 return make_float (f1); 665 return make_float (f1);
904} 666}
905 667
906/* It's not clear these are worth adding. */
907
908DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0, 668DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0,
909 doc: /* Return the smallest integer no less than ARG, as a float. 669 doc: /* Return the smallest integer no less than ARG, as a float.
910\(Round toward +inf.\) */) 670\(Round toward +inf.\) */)
911 (register Lisp_Object arg) 671 (Lisp_Object arg)
912{ 672{
913 double d = extract_float (arg); 673 double d = extract_float (arg);
914 IN_FLOAT (d = ceil (d), "fceiling", arg); 674 d = ceil (d);
915 return make_float (d); 675 return make_float (d);
916} 676}
917 677
918DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0, 678DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0,
919 doc: /* Return the largest integer no greater than ARG, as a float. 679 doc: /* Return the largest integer no greater than ARG, as a float.
920\(Round towards -inf.\) */) 680\(Round towards -inf.\) */)
921 (register Lisp_Object arg) 681 (Lisp_Object arg)
922{ 682{
923 double d = extract_float (arg); 683 double d = extract_float (arg);
924 IN_FLOAT (d = floor (d), "ffloor", arg); 684 d = floor (d);
925 return make_float (d); 685 return make_float (d);
926} 686}
927 687
928DEFUN ("fround", Ffround, Sfround, 1, 1, 0, 688DEFUN ("fround", Ffround, Sfround, 1, 1, 0,
929 doc: /* Return the nearest integer to ARG, as a float. */) 689 doc: /* Return the nearest integer to ARG, as a float. */)
930 (register Lisp_Object arg) 690 (Lisp_Object arg)
931{ 691{
932 double d = extract_float (arg); 692 double d = extract_float (arg);
933 IN_FLOAT (d = emacs_rint (d), "fround", arg); 693 d = emacs_rint (d);
934 return make_float (d); 694 return make_float (d);
935} 695}
936 696
937DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0, 697DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0,
938 doc: /* Truncate a floating point number to an integral float value. 698 doc: /* Truncate a floating point number to an integral float value.
939Rounds the value toward zero. */) 699Rounds the value toward zero. */)
940 (register Lisp_Object arg) 700 (Lisp_Object arg)
941{ 701{
942 double d = extract_float (arg); 702 double d = extract_float (arg);
943 if (d >= 0.0) 703 if (d >= 0.0)
944 IN_FLOAT (d = floor (d), "ftruncate", arg); 704 d = floor (d);
945 else 705 else
946 IN_FLOAT (d = ceil (d), "ftruncate", arg); 706 d = ceil (d);
947 return make_float (d); 707 return make_float (d);
948} 708}
949 709
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 710void
1016syms_of_floatfns (void) 711syms_of_floatfns (void)
1017{ 712{