aboutsummaryrefslogtreecommitdiffstats
path: root/src/floatfns.c
diff options
context:
space:
mode:
authorPaul Eggert2012-09-09 09:06:33 -0700
committerPaul Eggert2012-09-09 09:06:33 -0700
commitf6196b87e1ceee0d56f2fe6f3aa2b9d1d82c44b0 (patch)
tree3400f2f4898ce1fc39ad437faa5e55714129d30b /src/floatfns.c
parent8ed43f154827121c624a5a93808340618bd8f03f (diff)
downloademacs-f6196b87e1ceee0d56f2fe6f3aa2b9d1d82c44b0.tar.gz
emacs-f6196b87e1ceee0d56f2fe6f3aa2b9d1d82c44b0.zip
Assume C89 or later for math functions.
This simplifies the code, and makes it a bit smaller and faster, and (most important) makes it easier to clean up signal handling since we can stop worring about floating-point exceptions in library code. That was a problem before C89, but the problem went away many years ago on all practical Emacs targets. * configure.ac (frexp, fmod): Remove checks for these functions, as we now assume them. (FLOAT_CHECK_DOMAIN, HAVE_INVERSE_HYPERBOLIC, NO_MATHERR) (HAVE_EXCEPTION): Remove; no longer needed. * admin/CPP-DEFINES (HAVE_FMOD, HAVE_FREXP, FLOAT_CHECK_DOMAIN) (HAVE_INVERSE_HYPERBOLIC, NO_MATHERR): Remove. * src/data.c, src/image.c, src/lread.c, src/print.c: Don't include <math.h>; no longer needed. * src/data.c, src/floatfns.c (IEEE_FLOATING_POINT): Don't worry that it might be autoconfigured, as that never happens. * src/data.c (fmod): * src/doprnt.c (DBL_MAX_10_EXP): * src/print.c (DBL_DIG): Remove. C89 or later always defines these. * src/floatfns.c (HAVE_MATHERR, FLOAT_CHECK_ERRNO, FLOAT_CHECK_DOMAIN) (in_float, float_error_arg, float_error_arg2, float_error_fn_name) (arith_error, domain_error, domain_error2): Remove all this pre-C89 cruft. Do not include <errno.h> as that's no longer needed -- we simply return what C returns. All uses removed. (IN_FLOAT, IN_FLOAT2): Remove. All uses replaced with the wrapped code. (FLOAT_TO_INT, FLOAT_TO_INT2, range_error, range_error2): Remove. All uses expanded, as these macros are no longer used more than once and are now more trouble than they're worth. (Ftan): Use tan, not sin / cos. (Flogb): Assume C89 frexp. (fmod_float): Assume C89 fmod. (matherr) [HAVE_MATHERR]: Remove; no longer needed. (init_floatfns): Remove. All uses removed.
Diffstat (limited to 'src/floatfns.c')
-rw-r--r--src/floatfns.c435
1 files changed, 83 insertions, 352 deletions
diff --git a/src/floatfns.c b/src/floatfns.c
index dfe063b152f..8a9a9fd0886 100644
--- a/src/floatfns.c
+++ b/src/floatfns.c
@@ -22,26 +22,9 @@ 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_CHECK_DOMAIN if the float library doesn't handle errors by
41 either setting errno, or signaling SIGFPE. Otherwise, domain and
42 range checking will happen before calling the float routines. This has
43 no effect if HAVE_MATHERR is defined (since matherr will be called when
44 a domain error occurs.)
45 */ 28 */
46 29
47#include <config.h> 30#include <config.h>
@@ -50,15 +33,12 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
50#include "syssignal.h" 33#include "syssignal.h"
51 34
52#include <float.h> 35#include <float.h>
53/* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
54#ifndef IEEE_FLOATING_POINT
55#if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \ 36#if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
56 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128) 37 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
57#define IEEE_FLOATING_POINT 1 38#define IEEE_FLOATING_POINT 1
58#else 39#else
59#define IEEE_FLOATING_POINT 0 40#define IEEE_FLOATING_POINT 0
60#endif 41#endif
61#endif
62 42
63#include <math.h> 43#include <math.h>
64 44
@@ -67,120 +47,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
67extern double logb (double); 47extern double logb (double);
68#endif /* not HPUX and HAVE_LOGB and no logb macro */ 48#endif /* not HPUX and HAVE_LOGB and no logb macro */
69 49
70#if defined (DOMAIN) && defined (SING) && defined (OVERFLOW)
71 /* If those are defined, then this is probably a `matherr' machine. */
72# ifndef HAVE_MATHERR
73# define HAVE_MATHERR
74# endif
75#endif
76
77#ifdef NO_MATHERR
78#undef HAVE_MATHERR
79#endif
80
81#ifdef HAVE_MATHERR
82# ifdef FLOAT_CHECK_ERRNO
83# undef FLOAT_CHECK_ERRNO
84# endif
85# ifdef FLOAT_CHECK_DOMAIN
86# undef FLOAT_CHECK_DOMAIN
87# endif
88#endif
89
90#ifndef NO_FLOAT_CHECK_ERRNO
91#define FLOAT_CHECK_ERRNO
92#endif
93
94#ifdef FLOAT_CHECK_ERRNO
95# include <errno.h>
96#endif
97
98/* True while executing in floating point.
99 This tells float_error what to do. */
100
101static bool in_float;
102
103/* If an argument is out of range for a mathematical function,
104 here is the actual argument value to use in the error message.
105 These variables are used only across the floating point library call
106 so there is no need to staticpro them. */
107
108static Lisp_Object float_error_arg, float_error_arg2;
109
110static const char *float_error_fn_name;
111
112/* Evaluate the floating point expression D, recording NUM
113 as the original argument for error messages.
114 D is normally an assignment expression.
115 Handle errors which may result in signals or may set errno.
116
117 Note that float_error may be declared to return void, so you can't
118 just cast the zero after the colon to (void) to make the types
119 check properly. */
120
121#ifdef FLOAT_CHECK_ERRNO
122#define IN_FLOAT(d, name, num) \
123 do { \
124 float_error_arg = num; \
125 float_error_fn_name = name; \
126 in_float = 1; errno = 0; (d); in_float = 0; \
127 switch (errno) { \
128 case 0: break; \
129 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
130 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
131 default: arith_error (float_error_fn_name, float_error_arg); \
132 } \
133 } while (0)
134#define IN_FLOAT2(d, name, num, num2) \
135 do { \
136 float_error_arg = num; \
137 float_error_arg2 = num2; \
138 float_error_fn_name = name; \
139 in_float = 1; errno = 0; (d); in_float = 0; \
140 switch (errno) { \
141 case 0: break; \
142 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
143 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
144 default: arith_error (float_error_fn_name, float_error_arg); \
145 } \
146 } while (0)
147#else
148#define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0)
149#define IN_FLOAT2(d, name, num, num2) (in_float = 1, (d), in_float = 0)
150#endif
151
152/* Convert float to Lisp_Int if it fits, else signal a range error
153 using the given arguments. */
154#define FLOAT_TO_INT(x, i, name, num) \
155 do \
156 { \
157 if (FIXNUM_OVERFLOW_P (x)) \
158 range_error (name, num); \
159 XSETINT (i, (EMACS_INT)(x)); \
160 } \
161 while (0)
162#define FLOAT_TO_INT2(x, i, name, num1, num2) \
163 do \
164 { \
165 if (FIXNUM_OVERFLOW_P (x)) \
166 range_error2 (name, num1, num2); \
167 XSETINT (i, (EMACS_INT)(x)); \
168 } \
169 while (0)
170
171#define arith_error(op,arg) \
172 xsignal2 (Qarith_error, build_string ((op)), (arg))
173#define range_error(op,arg) \
174 xsignal2 (Qrange_error, build_string ((op)), (arg))
175#define range_error2(op,a1,a2) \
176 xsignal3 (Qrange_error, build_string ((op)), (a1), (a2))
177#define domain_error(op,arg) \
178 xsignal2 (Qdomain_error, build_string ((op)), (arg))
179#ifdef FLOAT_CHECK_DOMAIN
180#define domain_error2(op,a1,a2) \
181 xsignal3 (Qdomain_error, build_string ((op)), (a1), (a2))
182#endif
183
184/* Extract a Lisp number as a `double', or signal an error. */ 50/* Extract a Lisp number as a `double', or signal an error. */
185 51
186double 52double
@@ -197,27 +63,19 @@ extract_float (Lisp_Object num)
197 63
198DEFUN ("acos", Facos, Sacos, 1, 1, 0, 64DEFUN ("acos", Facos, Sacos, 1, 1, 0,
199 doc: /* Return the inverse cosine of ARG. */) 65 doc: /* Return the inverse cosine of ARG. */)
200 (register Lisp_Object arg) 66 (Lisp_Object arg)
201{ 67{
202 double d = extract_float (arg); 68 double d = extract_float (arg);
203#ifdef FLOAT_CHECK_DOMAIN 69 d = acos (d);
204 if (d > 1.0 || d < -1.0)
205 domain_error ("acos", arg);
206#endif
207 IN_FLOAT (d = acos (d), "acos", arg);
208 return make_float (d); 70 return make_float (d);
209} 71}
210 72
211DEFUN ("asin", Fasin, Sasin, 1, 1, 0, 73DEFUN ("asin", Fasin, Sasin, 1, 1, 0,
212 doc: /* Return the inverse sine of ARG. */) 74 doc: /* Return the inverse sine of ARG. */)
213 (register Lisp_Object arg) 75 (Lisp_Object arg)
214{ 76{
215 double d = extract_float (arg); 77 double d = extract_float (arg);
216#ifdef FLOAT_CHECK_DOMAIN 78 d = asin (d);
217 if (d > 1.0 || d < -1.0)
218 domain_error ("asin", arg);
219#endif
220 IN_FLOAT (d = asin (d), "asin", arg);
221 return make_float (d); 79 return make_float (d);
222} 80}
223 81
@@ -227,50 +85,44 @@ If only one argument Y is given, return the inverse tangent of Y.
227If 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
228divided 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)
229and the x-axis. */) 87and the x-axis. */)
230 (register Lisp_Object y, Lisp_Object x) 88 (Lisp_Object y, Lisp_Object x)
231{ 89{
232 double d = extract_float (y); 90 double d = extract_float (y);
233 91
234 if (NILP (x)) 92 if (NILP (x))
235 IN_FLOAT (d = atan (d), "atan", y); 93 d = atan (d);
236 else 94 else
237 { 95 {
238 double d2 = extract_float (x); 96 double d2 = extract_float (x);
239 97 d = atan2 (d, d2);
240 IN_FLOAT2 (d = atan2 (d, d2), "atan", y, x);
241 } 98 }
242 return make_float (d); 99 return make_float (d);
243} 100}
244 101
245DEFUN ("cos", Fcos, Scos, 1, 1, 0, 102DEFUN ("cos", Fcos, Scos, 1, 1, 0,
246 doc: /* Return the cosine of ARG. */) 103 doc: /* Return the cosine of ARG. */)
247 (register Lisp_Object arg) 104 (Lisp_Object arg)
248{ 105{
249 double d = extract_float (arg); 106 double d = extract_float (arg);
250 IN_FLOAT (d = cos (d), "cos", arg); 107 d = cos (d);
251 return make_float (d); 108 return make_float (d);
252} 109}
253 110
254DEFUN ("sin", Fsin, Ssin, 1, 1, 0, 111DEFUN ("sin", Fsin, Ssin, 1, 1, 0,
255 doc: /* Return the sine of ARG. */) 112 doc: /* Return the sine of ARG. */)
256 (register Lisp_Object arg) 113 (Lisp_Object arg)
257{ 114{
258 double d = extract_float (arg); 115 double d = extract_float (arg);
259 IN_FLOAT (d = sin (d), "sin", arg); 116 d = sin (d);
260 return make_float (d); 117 return make_float (d);
261} 118}
262 119
263DEFUN ("tan", Ftan, Stan, 1, 1, 0, 120DEFUN ("tan", Ftan, Stan, 1, 1, 0,
264 doc: /* Return the tangent of ARG. */) 121 doc: /* Return the tangent of ARG. */)
265 (register Lisp_Object arg) 122 (Lisp_Object arg)
266{ 123{
267 double d = extract_float (arg); 124 double d = extract_float (arg);
268#ifdef FLOAT_CHECK_DOMAIN 125 d = tan (d);
269 double c = cos (d);
270 if (c == 0.0)
271 domain_error ("tan", arg);
272#endif
273 IN_FLOAT (d = tan (d), "tan", arg);
274 return make_float (d); 126 return make_float (d);
275} 127}
276 128
@@ -341,61 +193,61 @@ Returns the floating point value resulting from multiplying SGNFCAND
341 193
342DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0, 194DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0,
343 doc: /* Return the bessel function j0 of ARG. */) 195 doc: /* Return the bessel function j0 of ARG. */)
344 (register Lisp_Object arg) 196 (Lisp_Object arg)
345{ 197{
346 double d = extract_float (arg); 198 double d = extract_float (arg);
347 IN_FLOAT (d = j0 (d), "bessel-j0", arg); 199 d = j0 (d);
348 return make_float (d); 200 return make_float (d);
349} 201}
350 202
351DEFUN ("bessel-j1", Fbessel_j1, Sbessel_j1, 1, 1, 0, 203DEFUN ("bessel-j1", Fbessel_j1, Sbessel_j1, 1, 1, 0,
352 doc: /* Return the bessel function j1 of ARG. */) 204 doc: /* Return the bessel function j1 of ARG. */)
353 (register Lisp_Object arg) 205 (Lisp_Object arg)
354{ 206{
355 double d = extract_float (arg); 207 double d = extract_float (arg);
356 IN_FLOAT (d = j1 (d), "bessel-j1", arg); 208 d = j1 (d);
357 return make_float (d); 209 return make_float (d);
358} 210}
359 211
360DEFUN ("bessel-jn", Fbessel_jn, Sbessel_jn, 2, 2, 0, 212DEFUN ("bessel-jn", Fbessel_jn, Sbessel_jn, 2, 2, 0,
361 doc: /* Return the order N bessel function output jn of ARG. 213 doc: /* Return the order N bessel function output jn of ARG.
362The first arg (the order) is truncated to an integer. */) 214The first arg (the order) is truncated to an integer. */)
363 (register Lisp_Object n, Lisp_Object arg) 215 (Lisp_Object n, Lisp_Object arg)
364{ 216{
365 int i1 = extract_float (n); 217 int i1 = extract_float (n);
366 double f2 = extract_float (arg); 218 double f2 = extract_float (arg);
367 219
368 IN_FLOAT (f2 = jn (i1, f2), "bessel-jn", n); 220 f2 = jn (i1, f2);
369 return make_float (f2); 221 return make_float (f2);
370} 222}
371 223
372DEFUN ("bessel-y0", Fbessel_y0, Sbessel_y0, 1, 1, 0, 224DEFUN ("bessel-y0", Fbessel_y0, Sbessel_y0, 1, 1, 0,
373 doc: /* Return the bessel function y0 of ARG. */) 225 doc: /* Return the bessel function y0 of ARG. */)
374 (register Lisp_Object arg) 226 (Lisp_Object arg)
375{ 227{
376 double d = extract_float (arg); 228 double d = extract_float (arg);
377 IN_FLOAT (d = y0 (d), "bessel-y0", arg); 229 d = y0 (d);
378 return make_float (d); 230 return make_float (d);
379} 231}
380 232
381DEFUN ("bessel-y1", Fbessel_y1, Sbessel_y1, 1, 1, 0, 233DEFUN ("bessel-y1", Fbessel_y1, Sbessel_y1, 1, 1, 0,
382 doc: /* Return the bessel function y1 of ARG. */) 234 doc: /* Return the bessel function y1 of ARG. */)
383 (register Lisp_Object arg) 235 (Lisp_Object arg)
384{ 236{
385 double d = extract_float (arg); 237 double d = extract_float (arg);
386 IN_FLOAT (d = y1 (d), "bessel-y0", arg); 238 d = y1 (d);
387 return make_float (d); 239 return make_float (d);
388} 240}
389 241
390DEFUN ("bessel-yn", Fbessel_yn, Sbessel_yn, 2, 2, 0, 242DEFUN ("bessel-yn", Fbessel_yn, Sbessel_yn, 2, 2, 0,
391 doc: /* Return the order N bessel function output yn of ARG. 243 doc: /* Return the order N bessel function output yn of ARG.
392The first arg (the order) is truncated to an integer. */) 244The first arg (the order) is truncated to an integer. */)
393 (register Lisp_Object n, Lisp_Object arg) 245 (Lisp_Object n, Lisp_Object arg)
394{ 246{
395 int i1 = extract_float (n); 247 int i1 = extract_float (n);
396 double f2 = extract_float (arg); 248 double f2 = extract_float (arg);
397 249
398 IN_FLOAT (f2 = yn (i1, f2), "bessel-yn", n); 250 f2 = yn (i1, f2);
399 return make_float (f2); 251 return make_float (f2);
400} 252}
401 253
@@ -405,43 +257,43 @@ The first arg (the order) is truncated to an integer. */)
405 257
406DEFUN ("erf", Ferf, Serf, 1, 1, 0, 258DEFUN ("erf", Ferf, Serf, 1, 1, 0,
407 doc: /* Return the mathematical error function of ARG. */) 259 doc: /* Return the mathematical error function of ARG. */)
408 (register Lisp_Object arg) 260 (Lisp_Object arg)
409{ 261{
410 double d = extract_float (arg); 262 double d = extract_float (arg);
411 IN_FLOAT (d = erf (d), "erf", arg); 263 d = erf (d);
412 return make_float (d); 264 return make_float (d);
413} 265}
414 266
415DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0, 267DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0,
416 doc: /* Return the complementary error function of ARG. */) 268 doc: /* Return the complementary error function of ARG. */)
417 (register Lisp_Object arg) 269 (Lisp_Object arg)
418{ 270{
419 double d = extract_float (arg); 271 double d = extract_float (arg);
420 IN_FLOAT (d = erfc (d), "erfc", arg); 272 d = erfc (d);
421 return make_float (d); 273 return make_float (d);
422} 274}
423 275
424DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0, 276DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0,
425 doc: /* Return the log gamma of ARG. */) 277 doc: /* Return the log gamma of ARG. */)
426 (register Lisp_Object arg) 278 (Lisp_Object arg)
427{ 279{
428 double d = extract_float (arg); 280 double d = extract_float (arg);
429 IN_FLOAT (d = lgamma (d), "log-gamma", arg); 281 d = lgamma (d);
430 return make_float (d); 282 return make_float (d);
431} 283}
432 284
433DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0, 285DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0,
434 doc: /* Return the cube root of ARG. */) 286 doc: /* Return the cube root of ARG. */)
435 (register Lisp_Object arg) 287 (Lisp_Object arg)
436{ 288{
437 double d = extract_float (arg); 289 double d = extract_float (arg);
438#ifdef HAVE_CBRT 290#ifdef HAVE_CBRT
439 IN_FLOAT (d = cbrt (d), "cube-root", arg); 291 d = cbrt (d);
440#else 292#else
441 if (d >= 0.0) 293 if (d >= 0.0)
442 IN_FLOAT (d = pow (d, 1.0/3.0), "cube-root", arg); 294 d = pow (d, 1.0/3.0);
443 else 295 else
444 IN_FLOAT (d = -pow (-d, 1.0/3.0), "cube-root", arg); 296 d = -pow (-d, 1.0/3.0);
445#endif 297#endif
446 return make_float (d); 298 return make_float (d);
447} 299}
@@ -450,23 +302,16 @@ DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0,
450 302
451DEFUN ("exp", Fexp, Sexp, 1, 1, 0, 303DEFUN ("exp", Fexp, Sexp, 1, 1, 0,
452 doc: /* Return the exponential base e of ARG. */) 304 doc: /* Return the exponential base e of ARG. */)
453 (register Lisp_Object arg) 305 (Lisp_Object arg)
454{ 306{
455 double d = extract_float (arg); 307 double d = extract_float (arg);
456#ifdef FLOAT_CHECK_DOMAIN 308 d = exp (d);
457 if (d > 709.7827) /* Assume IEEE doubles here */
458 range_error ("exp", arg);
459 else if (d < -709.0)
460 return make_float (0.0);
461 else
462#endif
463 IN_FLOAT (d = exp (d), "exp", arg);
464 return make_float (d); 309 return make_float (d);
465} 310}
466 311
467DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, 312DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
468 doc: /* Return the exponential ARG1 ** ARG2. */) 313 doc: /* Return the exponential ARG1 ** ARG2. */)
469 (register Lisp_Object arg1, Lisp_Object arg2) 314 (Lisp_Object arg1, Lisp_Object arg2)
470{ 315{
471 double f1, f2, f3; 316 double f1, f2, f3;
472 317
@@ -495,72 +340,46 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
495 } 340 }
496 f1 = FLOATP (arg1) ? XFLOAT_DATA (arg1) : XINT (arg1); 341 f1 = FLOATP (arg1) ? XFLOAT_DATA (arg1) : XINT (arg1);
497 f2 = FLOATP (arg2) ? XFLOAT_DATA (arg2) : XINT (arg2); 342 f2 = FLOATP (arg2) ? XFLOAT_DATA (arg2) : XINT (arg2);
498 /* Really should check for overflow, too */ 343 f3 = pow (f1, f2);
499 if (f1 == 0.0 && f2 == 0.0)
500 f1 = 1.0;
501#ifdef FLOAT_CHECK_DOMAIN
502 else if ((f1 == 0.0 && f2 < 0.0) || (f1 < 0 && f2 != floor (f2)))
503 domain_error2 ("expt", arg1, arg2);
504#endif
505 IN_FLOAT2 (f3 = pow (f1, f2), "expt", arg1, arg2);
506 /* Check for overflow in the result. */
507 if (f1 != 0.0 && f3 == 0.0)
508 range_error ("expt", arg1);
509 return make_float (f3); 344 return make_float (f3);
510} 345}
511 346
512DEFUN ("log", Flog, Slog, 1, 2, 0, 347DEFUN ("log", Flog, Slog, 1, 2, 0,
513 doc: /* Return the natural logarithm of ARG. 348 doc: /* Return the natural logarithm of ARG.
514If 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. */)
515 (register Lisp_Object arg, Lisp_Object base) 350 (Lisp_Object arg, Lisp_Object base)
516{ 351{
517 double d = extract_float (arg); 352 double d = extract_float (arg);
518 353
519#ifdef FLOAT_CHECK_DOMAIN
520 if (d <= 0.0)
521 domain_error2 ("log", arg, base);
522#endif
523 if (NILP (base)) 354 if (NILP (base))
524 IN_FLOAT (d = log (d), "log", arg); 355 d = log (d);
525 else 356 else
526 { 357 {
527 double b = extract_float (base); 358 double b = extract_float (base);
528 359
529#ifdef FLOAT_CHECK_DOMAIN
530 if (b <= 0.0 || b == 1.0)
531 domain_error2 ("log", arg, base);
532#endif
533 if (b == 10.0) 360 if (b == 10.0)
534 IN_FLOAT2 (d = log10 (d), "log", arg, base); 361 d = log10 (d);
535 else 362 else
536 IN_FLOAT2 (d = log (d) / log (b), "log", arg, base); 363 d = log (d) / log (b);
537 } 364 }
538 return make_float (d); 365 return make_float (d);
539} 366}
540 367
541DEFUN ("log10", Flog10, Slog10, 1, 1, 0, 368DEFUN ("log10", Flog10, Slog10, 1, 1, 0,
542 doc: /* Return the logarithm base 10 of ARG. */) 369 doc: /* Return the logarithm base 10 of ARG. */)
543 (register Lisp_Object arg) 370 (Lisp_Object arg)
544{ 371{
545 double d = extract_float (arg); 372 double d = extract_float (arg);
546#ifdef FLOAT_CHECK_DOMAIN 373 d = log10 (d);
547 if (d <= 0.0)
548 domain_error ("log10", arg);
549#endif
550 IN_FLOAT (d = log10 (d), "log10", arg);
551 return make_float (d); 374 return make_float (d);
552} 375}
553 376
554DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0, 377DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
555 doc: /* Return the square root of ARG. */) 378 doc: /* Return the square root of ARG. */)
556 (register Lisp_Object arg) 379 (Lisp_Object arg)
557{ 380{
558 double d = extract_float (arg); 381 double d = extract_float (arg);
559#ifdef FLOAT_CHECK_DOMAIN 382 d = sqrt (d);
560 if (d < 0.0)
561 domain_error ("sqrt", arg);
562#endif
563 IN_FLOAT (d = sqrt (d), "sqrt", arg);
564 return make_float (d); 383 return make_float (d);
565} 384}
566 385
@@ -568,83 +387,55 @@ DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
568 387
569DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0, 388DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0,
570 doc: /* Return the inverse hyperbolic cosine of ARG. */) 389 doc: /* Return the inverse hyperbolic cosine of ARG. */)
571 (register Lisp_Object arg) 390 (Lisp_Object arg)
572{ 391{
573 double d = extract_float (arg); 392 double d = extract_float (arg);
574#ifdef FLOAT_CHECK_DOMAIN 393 d = acosh (d);
575 if (d < 1.0)
576 domain_error ("acosh", arg);
577#endif
578#ifdef HAVE_INVERSE_HYPERBOLIC
579 IN_FLOAT (d = acosh (d), "acosh", arg);
580#else
581 IN_FLOAT (d = log (d + sqrt (d*d - 1.0)), "acosh", arg);
582#endif
583 return make_float (d); 394 return make_float (d);
584} 395}
585 396
586DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0, 397DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0,
587 doc: /* Return the inverse hyperbolic sine of ARG. */) 398 doc: /* Return the inverse hyperbolic sine of ARG. */)
588 (register Lisp_Object arg) 399 (Lisp_Object arg)
589{ 400{
590 double d = extract_float (arg); 401 double d = extract_float (arg);
591#ifdef HAVE_INVERSE_HYPERBOLIC 402 d = asinh (d);
592 IN_FLOAT (d = asinh (d), "asinh", arg);
593#else
594 IN_FLOAT (d = log (d + sqrt (d*d + 1.0)), "asinh", arg);
595#endif
596 return make_float (d); 403 return make_float (d);
597} 404}
598 405
599DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0, 406DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0,
600 doc: /* Return the inverse hyperbolic tangent of ARG. */) 407 doc: /* Return the inverse hyperbolic tangent of ARG. */)
601 (register Lisp_Object arg) 408 (Lisp_Object arg)
602{ 409{
603 double d = extract_float (arg); 410 double d = extract_float (arg);
604#ifdef FLOAT_CHECK_DOMAIN 411 d = atanh (d);
605 if (d >= 1.0 || d <= -1.0)
606 domain_error ("atanh", arg);
607#endif
608#ifdef HAVE_INVERSE_HYPERBOLIC
609 IN_FLOAT (d = atanh (d), "atanh", arg);
610#else
611 IN_FLOAT (d = 0.5 * log ((1.0 + d) / (1.0 - d)), "atanh", arg);
612#endif
613 return make_float (d); 412 return make_float (d);
614} 413}
615 414
616DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0, 415DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0,
617 doc: /* Return the hyperbolic cosine of ARG. */) 416 doc: /* Return the hyperbolic cosine of ARG. */)
618 (register Lisp_Object arg) 417 (Lisp_Object arg)
619{ 418{
620 double d = extract_float (arg); 419 double d = extract_float (arg);
621#ifdef FLOAT_CHECK_DOMAIN 420 d = cosh (d);
622 if (d > 710.0 || d < -710.0)
623 range_error ("cosh", arg);
624#endif
625 IN_FLOAT (d = cosh (d), "cosh", arg);
626 return make_float (d); 421 return make_float (d);
627} 422}
628 423
629DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0, 424DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0,
630 doc: /* Return the hyperbolic sine of ARG. */) 425 doc: /* Return the hyperbolic sine of ARG. */)
631 (register Lisp_Object arg) 426 (Lisp_Object arg)
632{ 427{
633 double d = extract_float (arg); 428 double d = extract_float (arg);
634#ifdef FLOAT_CHECK_DOMAIN 429 d = sinh (d);
635 if (d > 710.0 || d < -710.0)
636 range_error ("sinh", arg);
637#endif
638 IN_FLOAT (d = sinh (d), "sinh", arg);
639 return make_float (d); 430 return make_float (d);
640} 431}
641 432
642DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0, 433DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0,
643 doc: /* Return the hyperbolic tangent of ARG. */) 434 doc: /* Return the hyperbolic tangent of ARG. */)
644 (register Lisp_Object arg) 435 (Lisp_Object arg)
645{ 436{
646 double d = extract_float (arg); 437 double d = extract_float (arg);
647 IN_FLOAT (d = tanh (d), "tanh", arg); 438 d = tanh (d);
648 return make_float (d); 439 return make_float (d);
649} 440}
650#endif 441#endif
@@ -689,33 +480,11 @@ This is the same as the exponent of a float. */)
689 else 480 else
690 { 481 {
691#ifdef HAVE_LOGB 482#ifdef HAVE_LOGB
692 IN_FLOAT (value = logb (f), "logb", arg); 483 value = logb (f);
693#else 484#else
694#ifdef HAVE_FREXP
695 int ivalue; 485 int ivalue;
696 IN_FLOAT (frexp (f, &ivalue), "logb", arg); 486 frexp (f, &ivalue);
697 value = ivalue - 1; 487 value = ivalue - 1;
698#else
699 int i;
700 double d;
701 if (f < 0.0)
702 f = -f;
703 value = -1;
704 while (f < 0.5)
705 {
706 for (i = 1, d = 0.5; d * d >= f; i += i)
707 d *= d;
708 f /= d;
709 value -= i;
710 }
711 while (f >= 1.0)
712 {
713 for (i = 1, d = 2.0; d * d <= f; i += i)
714 d *= d;
715 f /= d;
716 value += i;
717 }
718#endif
719#endif 488#endif
720 } 489 }
721 XSETINT (val, value); 490 XSETINT (val, value);
@@ -748,8 +517,10 @@ rounding_driver (Lisp_Object arg, Lisp_Object divisor,
748 if (! IEEE_FLOATING_POINT && f2 == 0) 517 if (! IEEE_FLOATING_POINT && f2 == 0)
749 xsignal0 (Qarith_error); 518 xsignal0 (Qarith_error);
750 519
751 IN_FLOAT2 (f1 = (*double_round) (f1 / f2), name, arg, divisor); 520 f1 = (*double_round) (f1 / f2);
752 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);
753 return arg; 524 return arg;
754 } 525 }
755 526
@@ -765,10 +536,10 @@ rounding_driver (Lisp_Object arg, Lisp_Object divisor,
765 536
766 if (FLOATP (arg)) 537 if (FLOATP (arg))
767 { 538 {
768 double d; 539 double d = (*double_round) (XFLOAT_DATA (arg));
769 540 if (FIXNUM_OVERFLOW_P (d))
770 IN_FLOAT (d = (*double_round) (XFLOAT_DATA (arg)), name, arg); 541 xsignal2 (Qrange_error, build_string (name), arg);
771 FLOAT_TO_INT (d, arg, name, arg); 542 arg = make_number (d);
772 } 543 }
773 544
774 return arg; 545 return arg;
@@ -885,97 +656,57 @@ fmod_float (Lisp_Object x, Lisp_Object y)
885 f1 = FLOATP (x) ? XFLOAT_DATA (x) : XINT (x); 656 f1 = FLOATP (x) ? XFLOAT_DATA (x) : XINT (x);
886 f2 = FLOATP (y) ? XFLOAT_DATA (y) : XINT (y); 657 f2 = FLOATP (y) ? XFLOAT_DATA (y) : XINT (y);
887 658
888 if (! IEEE_FLOATING_POINT && f2 == 0) 659 f1 = fmod (f1, f2);
889 xsignal0 (Qarith_error);
890 660
891 /* If the "remainder" comes out with the wrong sign, fix it. */ 661 /* If the "remainder" comes out with the wrong sign, fix it. */
892 IN_FLOAT2 ((f1 = fmod (f1, f2), 662 if (f2 < 0 ? 0 < f1 : f1 < 0)
893 f1 = (f2 < 0 ? f1 > 0 : f1 < 0) ? f1 + f2 : f1), 663 f1 += f2;
894 "mod", x, y); 664
895 return make_float (f1); 665 return make_float (f1);
896} 666}
897 667
898/* It's not clear these are worth adding. */
899
900DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0, 668DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0,
901 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.
902\(Round toward +inf.\) */) 670\(Round toward +inf.\) */)
903 (register Lisp_Object arg) 671 (Lisp_Object arg)
904{ 672{
905 double d = extract_float (arg); 673 double d = extract_float (arg);
906 IN_FLOAT (d = ceil (d), "fceiling", arg); 674 d = ceil (d);
907 return make_float (d); 675 return make_float (d);
908} 676}
909 677
910DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0, 678DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0,
911 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.
912\(Round towards -inf.\) */) 680\(Round towards -inf.\) */)
913 (register Lisp_Object arg) 681 (Lisp_Object arg)
914{ 682{
915 double d = extract_float (arg); 683 double d = extract_float (arg);
916 IN_FLOAT (d = floor (d), "ffloor", arg); 684 d = floor (d);
917 return make_float (d); 685 return make_float (d);
918} 686}
919 687
920DEFUN ("fround", Ffround, Sfround, 1, 1, 0, 688DEFUN ("fround", Ffround, Sfround, 1, 1, 0,
921 doc: /* Return the nearest integer to ARG, as a float. */) 689 doc: /* Return the nearest integer to ARG, as a float. */)
922 (register Lisp_Object arg) 690 (Lisp_Object arg)
923{ 691{
924 double d = extract_float (arg); 692 double d = extract_float (arg);
925 IN_FLOAT (d = emacs_rint (d), "fround", arg); 693 d = emacs_rint (d);
926 return make_float (d); 694 return make_float (d);
927} 695}
928 696
929DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0, 697DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0,
930 doc: /* Truncate a floating point number to an integral float value. 698 doc: /* Truncate a floating point number to an integral float value.
931Rounds the value toward zero. */) 699Rounds the value toward zero. */)
932 (register Lisp_Object arg) 700 (Lisp_Object arg)
933{ 701{
934 double d = extract_float (arg); 702 double d = extract_float (arg);
935 if (d >= 0.0) 703 if (d >= 0.0)
936 IN_FLOAT (d = floor (d), "ftruncate", arg); 704 d = floor (d);
937 else 705 else
938 IN_FLOAT (d = ceil (d), "ftruncate", arg); 706 d = ceil (d);
939 return make_float (d); 707 return make_float (d);
940} 708}
941 709
942#ifdef HAVE_MATHERR
943int
944matherr (struct exception *x)
945{
946 Lisp_Object args;
947 const char *name = x->name;
948
949 if (! in_float)
950 /* Not called from emacs-lisp float routines; do the default thing. */
951 return 0;
952 if (!strcmp (x->name, "pow"))
953 name = "expt";
954
955 args
956 = Fcons (build_string (name),
957 Fcons (make_float (x->arg1),
958 ((!strcmp (name, "log") || !strcmp (name, "pow"))
959 ? Fcons (make_float (x->arg2), Qnil)
960 : Qnil)));
961 switch (x->type)
962 {
963 case DOMAIN: xsignal (Qdomain_error, args); break;
964 case SING: xsignal (Qsingularity_error, args); break;
965 case OVERFLOW: xsignal (Qoverflow_error, args); break;
966 case UNDERFLOW: xsignal (Qunderflow_error, args); break;
967 default: xsignal (Qarith_error, args); break;
968 }
969 return (1); /* don't set errno or print a message */
970}
971#endif /* HAVE_MATHERR */
972
973void
974init_floatfns (void)
975{
976 in_float = 0;
977}
978
979void 710void
980syms_of_floatfns (void) 711syms_of_floatfns (void)
981{ 712{