Commit | Line | Data |
---|---|---|
b70021f4 | 1 | /* Primitive operations on floating point for GNU Emacs Lisp interpreter. |
c6c5df7f | 2 | Copyright (C) 1988, 1993 Free Software Foundation, Inc. |
b70021f4 MR |
3 | |
4 | This file is part of GNU Emacs. | |
5 | ||
6 | GNU Emacs is free software; you can redistribute it and/or modify | |
7 | it under the terms of the GNU General Public License as published by | |
4746118a | 8 | the Free Software Foundation; either version 2, or (at your option) |
b70021f4 MR |
9 | any later version. |
10 | ||
11 | GNU Emacs is distributed in the hope that it will be useful, | |
12 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | GNU General Public License for more details. | |
15 | ||
16 | You should have received a copy of the GNU General Public License | |
17 | along with GNU Emacs; see the file COPYING. If not, write to | |
18 | the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ | |
19 | ||
20 | ||
4b6baf5f RS |
21 | /* ANSI C requires only these float functions: |
22 | acos, asin, atan, atan2, ceil, cos, cosh, exp, fabs, floor, fmod, | |
23 | frexp, ldexp, log, log10, modf, pow, sin, sinh, sqrt, tan, tanh. | |
24 | ||
25 | Define HAVE_INVERSE_HYPERBOLIC if you have acosh, asinh, and atanh. | |
26 | Define HAVE_CBRT if you have cbrt. | |
27 | Define HAVE_RINT if you have rint. | |
28 | If you don't define these, then the appropriate routines will be simulated. | |
29 | ||
30 | Define HAVE_MATHERR if on a system supporting the SysV matherr callback. | |
31 | (This should happen automatically.) | |
32 | ||
33 | Define FLOAT_CHECK_ERRNO if the float library routines set errno. | |
34 | This has no effect if HAVE_MATHERR is defined. | |
35 | ||
36 | Define FLOAT_CATCH_SIGILL if the float library routines signal SIGILL. | |
37 | (What systems actually do this? Please let us know.) | |
38 | ||
39 | Define FLOAT_CHECK_DOMAIN if the float library doesn't handle errors by | |
40 | either setting errno, or signalling SIGFPE/SIGILL. Otherwise, domain and | |
41 | range checking will happen before calling the float routines. This has | |
42 | no effect if HAVE_MATHERR is defined (since matherr will be called when | |
43 | a domain error occurs.) | |
44 | */ | |
45 | ||
b70021f4 MR |
46 | #include <signal.h> |
47 | ||
48 | #include "config.h" | |
49 | #include "lisp.h" | |
e065a56e | 50 | #include "syssignal.h" |
b70021f4 MR |
51 | |
52 | Lisp_Object Qarith_error; | |
53 | ||
54 | #ifdef LISP_FLOAT_TYPE | |
265a9e55 | 55 | |
b70021f4 | 56 | #include <math.h> |
4b6baf5f | 57 | |
bbc4efeb | 58 | #ifndef hpux |
c26406fe JB |
59 | /* These declarations are omitted on some systems, like Ultrix. */ |
60 | extern double logb (); | |
bbc4efeb | 61 | #endif |
c26406fe | 62 | |
4b6baf5f RS |
63 | #if defined(DOMAIN) && defined(SING) && defined(OVERFLOW) |
64 | /* If those are defined, then this is probably a `matherr' machine. */ | |
65 | # ifndef HAVE_MATHERR | |
66 | # define HAVE_MATHERR | |
67 | # endif | |
68 | #endif | |
69 | ||
c0f0a4a2 | 70 | #ifdef NO_MATHERR |
f89182a2 RS |
71 | #undef HAVE_MATHERR |
72 | #endif | |
73 | ||
4b6baf5f RS |
74 | #ifdef HAVE_MATHERR |
75 | # ifdef FLOAT_CHECK_ERRNO | |
76 | # undef FLOAT_CHECK_ERRNO | |
77 | # endif | |
78 | # ifdef FLOAT_CHECK_DOMAIN | |
79 | # undef FLOAT_CHECK_DOMAIN | |
80 | # endif | |
81 | #endif | |
82 | ||
83 | #ifndef NO_FLOAT_CHECK_ERRNO | |
84 | #define FLOAT_CHECK_ERRNO | |
85 | #endif | |
86 | ||
87 | #ifdef FLOAT_CHECK_ERRNO | |
88 | # include <errno.h> | |
265a9e55 JB |
89 | |
90 | extern int errno; | |
4b6baf5f | 91 | #endif |
265a9e55 JB |
92 | |
93 | /* Avoid traps on VMS from sinh and cosh. | |
94 | All the other functions set errno instead. */ | |
95 | ||
96 | #ifdef VMS | |
97 | #undef cosh | |
98 | #undef sinh | |
99 | #define cosh(x) ((exp(x)+exp(-x))*0.5) | |
100 | #define sinh(x) ((exp(x)-exp(-x))*0.5) | |
101 | #endif /* VMS */ | |
102 | ||
4b6baf5f RS |
103 | #ifndef HAVE_RINT |
104 | #define rint(x) (floor((x)+0.5)) | |
105 | #endif | |
106 | ||
4746118a | 107 | static SIGTYPE float_error (); |
b70021f4 MR |
108 | |
109 | /* Nonzero while executing in floating point. | |
110 | This tells float_error what to do. */ | |
111 | ||
112 | static int in_float; | |
113 | ||
114 | /* If an argument is out of range for a mathematical function, | |
265a9e55 | 115 | here is the actual argument value to use in the error message. */ |
b70021f4 | 116 | |
4b6baf5f RS |
117 | static Lisp_Object float_error_arg, float_error_arg2; |
118 | ||
119 | static char *float_error_fn_name; | |
b70021f4 | 120 | |
265a9e55 JB |
121 | /* Evaluate the floating point expression D, recording NUM |
122 | as the original argument for error messages. | |
123 | D is normally an assignment expression. | |
f8d83099 JB |
124 | Handle errors which may result in signals or may set errno. |
125 | ||
126 | Note that float_error may be declared to return void, so you can't | |
127 | just cast the zero after the colon to (SIGTYPE) to make the types | |
128 | check properly. */ | |
265a9e55 | 129 | |
4b6baf5f RS |
130 | #ifdef FLOAT_CHECK_ERRNO |
131 | #define IN_FLOAT(d, name, num) \ | |
132 | do { \ | |
133 | float_error_arg = num; \ | |
134 | float_error_fn_name = name; \ | |
135 | in_float = 1; errno = 0; (d); in_float = 0; \ | |
136 | switch (errno) { \ | |
137 | case 0: break; \ | |
138 | case EDOM: domain_error (float_error_fn_name, float_error_arg); \ | |
139 | case ERANGE: range_error (float_error_fn_name, float_error_arg); \ | |
140 | default: arith_error (float_error_fn_name, float_error_arg); \ | |
141 | } \ | |
142 | } while (0) | |
143 | #define IN_FLOAT2(d, name, num, num2) \ | |
144 | do { \ | |
145 | float_error_arg = num; \ | |
146 | float_error_arg2 = num2; \ | |
147 | float_error_fn_name = name; \ | |
148 | in_float = 1; errno = 0; (d); in_float = 0; \ | |
149 | switch (errno) { \ | |
150 | case 0: break; \ | |
151 | case EDOM: domain_error (float_error_fn_name, float_error_arg); \ | |
152 | case ERANGE: range_error (float_error_fn_name, float_error_arg); \ | |
153 | default: arith_error (float_error_fn_name, float_error_arg); \ | |
154 | } \ | |
155 | } while (0) | |
156 | #else | |
f8131ed2 | 157 | #define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0) |
4b6baf5f RS |
158 | #define IN_FLOAT2(d, name, num, num2) (in_float = 1, (d), in_float = 0) |
159 | #endif | |
160 | ||
161 | #define arith_error(op,arg) \ | |
162 | Fsignal (Qarith_error, Fcons (build_string ((op)), Fcons ((arg), Qnil))) | |
163 | #define range_error(op,arg) \ | |
164 | Fsignal (Qrange_error, Fcons (build_string ((op)), Fcons ((arg), Qnil))) | |
165 | #define domain_error(op,arg) \ | |
166 | Fsignal (Qdomain_error, Fcons (build_string ((op)), Fcons ((arg), Qnil))) | |
167 | #define domain_error2(op,a1,a2) \ | |
168 | Fsignal (Qdomain_error, Fcons (build_string ((op)), Fcons ((a1), Fcons ((a2), Qnil)))) | |
b70021f4 MR |
169 | |
170 | /* Extract a Lisp number as a `double', or signal an error. */ | |
171 | ||
172 | double | |
173 | extract_float (num) | |
174 | Lisp_Object num; | |
175 | { | |
176 | CHECK_NUMBER_OR_FLOAT (num, 0); | |
177 | ||
178 | if (XTYPE (num) == Lisp_Float) | |
179 | return XFLOAT (num)->data; | |
180 | return (double) XINT (num); | |
181 | } | |
c2d4ea74 RS |
182 | \f |
183 | /* Trig functions. */ | |
b70021f4 MR |
184 | |
185 | DEFUN ("acos", Facos, Sacos, 1, 1, 0, | |
186 | "Return the inverse cosine of ARG.") | |
4b6baf5f RS |
187 | (arg) |
188 | register Lisp_Object arg; | |
b70021f4 | 189 | { |
4b6baf5f RS |
190 | double d = extract_float (arg); |
191 | #ifdef FLOAT_CHECK_DOMAIN | |
192 | if (d > 1.0 || d < -1.0) | |
193 | domain_error ("acos", arg); | |
194 | #endif | |
195 | IN_FLOAT (d = acos (d), "acos", arg); | |
b70021f4 MR |
196 | return make_float (d); |
197 | } | |
198 | ||
c2d4ea74 RS |
199 | DEFUN ("asin", Fasin, Sasin, 1, 1, 0, |
200 | "Return the inverse sine of ARG.") | |
4b6baf5f RS |
201 | (arg) |
202 | register Lisp_Object arg; | |
b70021f4 | 203 | { |
4b6baf5f RS |
204 | double d = extract_float (arg); |
205 | #ifdef FLOAT_CHECK_DOMAIN | |
206 | if (d > 1.0 || d < -1.0) | |
207 | domain_error ("asin", arg); | |
208 | #endif | |
209 | IN_FLOAT (d = asin (d), "asin", arg); | |
b70021f4 MR |
210 | return make_float (d); |
211 | } | |
212 | ||
c2d4ea74 RS |
213 | DEFUN ("atan", Fatan, Satan, 1, 1, 0, |
214 | "Return the inverse tangent of ARG.") | |
4b6baf5f RS |
215 | (arg) |
216 | register Lisp_Object arg; | |
b70021f4 | 217 | { |
4b6baf5f RS |
218 | double d = extract_float (arg); |
219 | IN_FLOAT (d = atan (d), "atan", arg); | |
b70021f4 MR |
220 | return make_float (d); |
221 | } | |
222 | ||
c2d4ea74 RS |
223 | DEFUN ("cos", Fcos, Scos, 1, 1, 0, |
224 | "Return the cosine of ARG.") | |
4b6baf5f RS |
225 | (arg) |
226 | register Lisp_Object arg; | |
b70021f4 | 227 | { |
4b6baf5f RS |
228 | double d = extract_float (arg); |
229 | IN_FLOAT (d = cos (d), "cos", arg); | |
b70021f4 MR |
230 | return make_float (d); |
231 | } | |
232 | ||
c2d4ea74 RS |
233 | DEFUN ("sin", Fsin, Ssin, 1, 1, 0, |
234 | "Return the sine of ARG.") | |
4b6baf5f RS |
235 | (arg) |
236 | register Lisp_Object arg; | |
b70021f4 | 237 | { |
4b6baf5f RS |
238 | double d = extract_float (arg); |
239 | IN_FLOAT (d = sin (d), "sin", arg); | |
b70021f4 MR |
240 | return make_float (d); |
241 | } | |
242 | ||
c2d4ea74 RS |
243 | DEFUN ("tan", Ftan, Stan, 1, 1, 0, |
244 | "Return the tangent of ARG.") | |
4b6baf5f RS |
245 | (arg) |
246 | register Lisp_Object arg; | |
247 | { | |
248 | double d = extract_float (arg); | |
249 | double c = cos (d); | |
250 | #ifdef FLOAT_CHECK_DOMAIN | |
251 | if (c == 0.0) | |
252 | domain_error ("tan", arg); | |
253 | #endif | |
254 | IN_FLOAT (d = sin (d) / c, "tan", arg); | |
b70021f4 MR |
255 | return make_float (d); |
256 | } | |
257 | \f | |
c2d4ea74 RS |
258 | #if 0 /* Leave these out unless we find there's a reason for them. */ |
259 | ||
b70021f4 MR |
260 | DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0, |
261 | "Return the bessel function j0 of ARG.") | |
4b6baf5f RS |
262 | (arg) |
263 | register Lisp_Object arg; | |
b70021f4 | 264 | { |
4b6baf5f RS |
265 | double d = extract_float (arg); |
266 | IN_FLOAT (d = j0 (d), "bessel-j0", arg); | |
b70021f4 MR |
267 | return make_float (d); |
268 | } | |
269 | ||
270 | DEFUN ("bessel-j1", Fbessel_j1, Sbessel_j1, 1, 1, 0, | |
271 | "Return the bessel function j1 of ARG.") | |
4b6baf5f RS |
272 | (arg) |
273 | register Lisp_Object arg; | |
b70021f4 | 274 | { |
4b6baf5f RS |
275 | double d = extract_float (arg); |
276 | IN_FLOAT (d = j1 (d), "bessel-j1", arg); | |
b70021f4 MR |
277 | return make_float (d); |
278 | } | |
279 | ||
280 | DEFUN ("bessel-jn", Fbessel_jn, Sbessel_jn, 2, 2, 0, | |
281 | "Return the order N bessel function output jn of ARG.\n\ | |
282 | The first arg (the order) is truncated to an integer.") | |
4b6baf5f RS |
283 | (arg1, arg2) |
284 | register Lisp_Object arg1, arg2; | |
b70021f4 | 285 | { |
4b6baf5f RS |
286 | int i1 = extract_float (arg1); |
287 | double f2 = extract_float (arg2); | |
b70021f4 | 288 | |
4b6baf5f | 289 | IN_FLOAT (f2 = jn (i1, f2), "bessel-jn", arg1); |
b70021f4 MR |
290 | return make_float (f2); |
291 | } | |
292 | ||
293 | DEFUN ("bessel-y0", Fbessel_y0, Sbessel_y0, 1, 1, 0, | |
294 | "Return the bessel function y0 of ARG.") | |
4b6baf5f RS |
295 | (arg) |
296 | register Lisp_Object arg; | |
b70021f4 | 297 | { |
4b6baf5f RS |
298 | double d = extract_float (arg); |
299 | IN_FLOAT (d = y0 (d), "bessel-y0", arg); | |
b70021f4 MR |
300 | return make_float (d); |
301 | } | |
302 | ||
303 | DEFUN ("bessel-y1", Fbessel_y1, Sbessel_y1, 1, 1, 0, | |
304 | "Return the bessel function y1 of ARG.") | |
4b6baf5f RS |
305 | (arg) |
306 | register Lisp_Object arg; | |
b70021f4 | 307 | { |
4b6baf5f RS |
308 | double d = extract_float (arg); |
309 | IN_FLOAT (d = y1 (d), "bessel-y0", arg); | |
b70021f4 MR |
310 | return make_float (d); |
311 | } | |
312 | ||
313 | DEFUN ("bessel-yn", Fbessel_yn, Sbessel_yn, 2, 2, 0, | |
314 | "Return the order N bessel function output yn of ARG.\n\ | |
315 | The first arg (the order) is truncated to an integer.") | |
4b6baf5f RS |
316 | (arg1, arg2) |
317 | register Lisp_Object arg1, arg2; | |
b70021f4 | 318 | { |
4b6baf5f RS |
319 | int i1 = extract_float (arg1); |
320 | double f2 = extract_float (arg2); | |
b70021f4 | 321 | |
4b6baf5f | 322 | IN_FLOAT (f2 = yn (i1, f2), "bessel-yn", arg1); |
b70021f4 MR |
323 | return make_float (f2); |
324 | } | |
b70021f4 | 325 | |
c2d4ea74 RS |
326 | #endif |
327 | \f | |
328 | #if 0 /* Leave these out unless we see they are worth having. */ | |
b70021f4 MR |
329 | |
330 | DEFUN ("erf", Ferf, Serf, 1, 1, 0, | |
331 | "Return the mathematical error function of ARG.") | |
4b6baf5f RS |
332 | (arg) |
333 | register Lisp_Object arg; | |
b70021f4 | 334 | { |
4b6baf5f RS |
335 | double d = extract_float (arg); |
336 | IN_FLOAT (d = erf (d), "erf", arg); | |
b70021f4 MR |
337 | return make_float (d); |
338 | } | |
339 | ||
340 | DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0, | |
341 | "Return the complementary error function of ARG.") | |
4b6baf5f RS |
342 | (arg) |
343 | register Lisp_Object arg; | |
b70021f4 | 344 | { |
4b6baf5f RS |
345 | double d = extract_float (arg); |
346 | IN_FLOAT (d = erfc (d), "erfc", arg); | |
b70021f4 MR |
347 | return make_float (d); |
348 | } | |
349 | ||
b70021f4 MR |
350 | DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0, |
351 | "Return the log gamma of ARG.") | |
4b6baf5f RS |
352 | (arg) |
353 | register Lisp_Object arg; | |
b70021f4 | 354 | { |
4b6baf5f RS |
355 | double d = extract_float (arg); |
356 | IN_FLOAT (d = lgamma (d), "log-gamma", arg); | |
b70021f4 MR |
357 | return make_float (d); |
358 | } | |
359 | ||
4b6baf5f | 360 | DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0, |
c2d4ea74 | 361 | "Return the cube root of ARG.") |
4b6baf5f RS |
362 | (arg) |
363 | register Lisp_Object arg; | |
b70021f4 | 364 | { |
4b6baf5f RS |
365 | double d = extract_float (arg); |
366 | #ifdef HAVE_CBRT | |
367 | IN_FLOAT (d = cbrt (d), "cube-root", arg); | |
368 | #else | |
369 | if (d >= 0.0) | |
370 | IN_FLOAT (d = pow (d, 1.0/3.0), "cube-root", arg); | |
371 | else | |
372 | IN_FLOAT (d = -pow (-d, 1.0/3.0), "cube-root", arg); | |
373 | #endif | |
b70021f4 MR |
374 | return make_float (d); |
375 | } | |
376 | ||
706ac90d RS |
377 | #endif |
378 | \f | |
c2d4ea74 RS |
379 | DEFUN ("exp", Fexp, Sexp, 1, 1, 0, |
380 | "Return the exponential base e of ARG.") | |
4b6baf5f RS |
381 | (arg) |
382 | register Lisp_Object arg; | |
383 | { | |
384 | double d = extract_float (arg); | |
385 | #ifdef FLOAT_CHECK_DOMAIN | |
386 | if (d > 709.7827) /* Assume IEEE doubles here */ | |
387 | range_error ("exp", arg); | |
388 | else if (d < -709.0) | |
389 | return make_float (0.0); | |
390 | else | |
391 | #endif | |
392 | IN_FLOAT (d = exp (d), "exp", arg); | |
b70021f4 MR |
393 | return make_float (d); |
394 | } | |
395 | ||
b70021f4 | 396 | DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, |
c2d4ea74 | 397 | "Return the exponential X ** Y.") |
4b6baf5f RS |
398 | (arg1, arg2) |
399 | register Lisp_Object arg1, arg2; | |
b70021f4 MR |
400 | { |
401 | double f1, f2; | |
402 | ||
4b6baf5f RS |
403 | CHECK_NUMBER_OR_FLOAT (arg1, 0); |
404 | CHECK_NUMBER_OR_FLOAT (arg2, 0); | |
405 | if ((XTYPE (arg1) == Lisp_Int) && /* common lisp spec */ | |
406 | (XTYPE (arg2) == Lisp_Int)) /* don't promote, if both are ints */ | |
b70021f4 | 407 | { /* this can be improved by pre-calculating */ |
eb8c3be9 | 408 | int acc, x, y; /* some binary powers of x then accumulating */ |
4be1d460 RS |
409 | Lisp_Object val; |
410 | ||
4b6baf5f RS |
411 | x = XINT (arg1); |
412 | y = XINT (arg2); | |
b70021f4 MR |
413 | acc = 1; |
414 | ||
415 | if (y < 0) | |
416 | { | |
4b6baf5f RS |
417 | if (x == 1) |
418 | acc = 1; | |
419 | else if (x == -1) | |
420 | acc = (y & 1) ? -1 : 1; | |
421 | else | |
422 | acc = 0; | |
b70021f4 MR |
423 | } |
424 | else | |
425 | { | |
426 | for (; y > 0; y--) | |
4b6baf5f RS |
427 | while (y > 0) |
428 | { | |
429 | if (y & 1) | |
430 | acc *= x; | |
431 | x *= x; | |
432 | y = (unsigned)y >> 1; | |
433 | } | |
b70021f4 | 434 | } |
4be1d460 RS |
435 | XSET (val, Lisp_Int, acc); |
436 | return val; | |
b70021f4 | 437 | } |
4b6baf5f RS |
438 | f1 = (XTYPE (arg1) == Lisp_Float) ? XFLOAT (arg1)->data : XINT (arg1); |
439 | f2 = (XTYPE (arg2) == Lisp_Float) ? XFLOAT (arg2)->data : XINT (arg2); | |
440 | /* Really should check for overflow, too */ | |
441 | if (f1 == 0.0 && f2 == 0.0) | |
442 | f1 = 1.0; | |
443 | #ifdef FLOAT_CHECK_DOMAIN | |
444 | else if ((f1 == 0.0 && f2 < 0.0) || (f1 < 0 && f2 != floor(f2))) | |
445 | domain_error2 ("expt", arg1, arg2); | |
446 | #endif | |
447 | IN_FLOAT (f1 = pow (f1, f2), "expt", arg1); | |
b70021f4 MR |
448 | return make_float (f1); |
449 | } | |
c2d4ea74 | 450 | |
56abb480 | 451 | DEFUN ("log", Flog, Slog, 1, 2, 0, |
4b6baf5f RS |
452 | "Return the natural logarithm of ARG.\n\ |
453 | If second optional argument BASE is given, return log ARG using that base.") | |
454 | (arg, base) | |
455 | register Lisp_Object arg, base; | |
b70021f4 | 456 | { |
4b6baf5f | 457 | double d = extract_float (arg); |
56abb480 | 458 | |
4b6baf5f RS |
459 | #ifdef FLOAT_CHECK_DOMAIN |
460 | if (d <= 0.0) | |
461 | domain_error2 ("log", arg, base); | |
462 | #endif | |
56abb480 | 463 | if (NILP (base)) |
4b6baf5f | 464 | IN_FLOAT (d = log (d), "log", arg); |
56abb480 JB |
465 | else |
466 | { | |
467 | double b = extract_float (base); | |
468 | ||
4b6baf5f RS |
469 | #ifdef FLOAT_CHECK_DOMAIN |
470 | if (b <= 0.0 || b == 1.0) | |
471 | domain_error2 ("log", arg, base); | |
472 | #endif | |
473 | if (b == 10.0) | |
474 | IN_FLOAT2 (d = log10 (d), "log", arg, base); | |
475 | else | |
f8131ed2 | 476 | IN_FLOAT2 (d = log (d) / log (b), "log", arg, base); |
56abb480 | 477 | } |
b70021f4 MR |
478 | return make_float (d); |
479 | } | |
480 | ||
c2d4ea74 RS |
481 | DEFUN ("log10", Flog10, Slog10, 1, 1, 0, |
482 | "Return the logarithm base 10 of ARG.") | |
4b6baf5f RS |
483 | (arg) |
484 | register Lisp_Object arg; | |
b70021f4 | 485 | { |
4b6baf5f RS |
486 | double d = extract_float (arg); |
487 | #ifdef FLOAT_CHECK_DOMAIN | |
488 | if (d <= 0.0) | |
489 | domain_error ("log10", arg); | |
490 | #endif | |
491 | IN_FLOAT (d = log10 (d), "log10", arg); | |
c2d4ea74 RS |
492 | return make_float (d); |
493 | } | |
494 | ||
b70021f4 MR |
495 | DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0, |
496 | "Return the square root of ARG.") | |
4b6baf5f RS |
497 | (arg) |
498 | register Lisp_Object arg; | |
b70021f4 | 499 | { |
4b6baf5f RS |
500 | double d = extract_float (arg); |
501 | #ifdef FLOAT_CHECK_DOMAIN | |
502 | if (d < 0.0) | |
503 | domain_error ("sqrt", arg); | |
504 | #endif | |
505 | IN_FLOAT (d = sqrt (d), "sqrt", arg); | |
b70021f4 MR |
506 | return make_float (d); |
507 | } | |
c2d4ea74 | 508 | \f |
706ac90d | 509 | #if 0 /* Not clearly worth adding. */ |
b70021f4 | 510 | |
c2d4ea74 RS |
511 | DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0, |
512 | "Return the inverse hyperbolic cosine of ARG.") | |
4b6baf5f RS |
513 | (arg) |
514 | register Lisp_Object arg; | |
b70021f4 | 515 | { |
4b6baf5f RS |
516 | double d = extract_float (arg); |
517 | #ifdef FLOAT_CHECK_DOMAIN | |
518 | if (d < 1.0) | |
519 | domain_error ("acosh", arg); | |
520 | #endif | |
521 | #ifdef HAVE_INVERSE_HYPERBOLIC | |
522 | IN_FLOAT (d = acosh (d), "acosh", arg); | |
523 | #else | |
524 | IN_FLOAT (d = log (d + sqrt (d*d - 1.0)), "acosh", arg); | |
525 | #endif | |
c2d4ea74 RS |
526 | return make_float (d); |
527 | } | |
528 | ||
529 | DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0, | |
530 | "Return the inverse hyperbolic sine of ARG.") | |
4b6baf5f RS |
531 | (arg) |
532 | register Lisp_Object arg; | |
c2d4ea74 | 533 | { |
4b6baf5f RS |
534 | double d = extract_float (arg); |
535 | #ifdef HAVE_INVERSE_HYPERBOLIC | |
536 | IN_FLOAT (d = asinh (d), "asinh", arg); | |
537 | #else | |
538 | IN_FLOAT (d = log (d + sqrt (d*d + 1.0)), "asinh", arg); | |
539 | #endif | |
c2d4ea74 RS |
540 | return make_float (d); |
541 | } | |
542 | ||
543 | DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0, | |
544 | "Return the inverse hyperbolic tangent of ARG.") | |
4b6baf5f RS |
545 | (arg) |
546 | register Lisp_Object arg; | |
c2d4ea74 | 547 | { |
4b6baf5f RS |
548 | double d = extract_float (arg); |
549 | #ifdef FLOAT_CHECK_DOMAIN | |
550 | if (d >= 1.0 || d <= -1.0) | |
551 | domain_error ("atanh", arg); | |
552 | #endif | |
553 | #ifdef HAVE_INVERSE_HYPERBOLIC | |
554 | IN_FLOAT (d = atanh (d), "atanh", arg); | |
555 | #else | |
556 | IN_FLOAT (d = 0.5 * log ((1.0 + d) / (1.0 - d)), "atanh", arg); | |
557 | #endif | |
c2d4ea74 RS |
558 | return make_float (d); |
559 | } | |
560 | ||
561 | DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0, | |
562 | "Return the hyperbolic cosine of ARG.") | |
4b6baf5f RS |
563 | (arg) |
564 | register Lisp_Object arg; | |
c2d4ea74 | 565 | { |
4b6baf5f RS |
566 | double d = extract_float (arg); |
567 | #ifdef FLOAT_CHECK_DOMAIN | |
568 | if (d > 710.0 || d < -710.0) | |
569 | range_error ("cosh", arg); | |
570 | #endif | |
571 | IN_FLOAT (d = cosh (d), "cosh", arg); | |
c2d4ea74 RS |
572 | return make_float (d); |
573 | } | |
574 | ||
575 | DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0, | |
576 | "Return the hyperbolic sine of ARG.") | |
4b6baf5f RS |
577 | (arg) |
578 | register Lisp_Object arg; | |
c2d4ea74 | 579 | { |
4b6baf5f RS |
580 | double d = extract_float (arg); |
581 | #ifdef FLOAT_CHECK_DOMAIN | |
582 | if (d > 710.0 || d < -710.0) | |
583 | range_error ("sinh", arg); | |
584 | #endif | |
585 | IN_FLOAT (d = sinh (d), "sinh", arg); | |
b70021f4 MR |
586 | return make_float (d); |
587 | } | |
588 | ||
589 | DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0, | |
590 | "Return the hyperbolic tangent of ARG.") | |
4b6baf5f RS |
591 | (arg) |
592 | register Lisp_Object arg; | |
b70021f4 | 593 | { |
4b6baf5f RS |
594 | double d = extract_float (arg); |
595 | IN_FLOAT (d = tanh (d), "tanh", arg); | |
b70021f4 MR |
596 | return make_float (d); |
597 | } | |
c2d4ea74 | 598 | #endif |
b70021f4 MR |
599 | \f |
600 | DEFUN ("abs", Fabs, Sabs, 1, 1, 0, | |
601 | "Return the absolute value of ARG.") | |
4b6baf5f RS |
602 | (arg) |
603 | register Lisp_Object arg; | |
b70021f4 | 604 | { |
4b6baf5f | 605 | CHECK_NUMBER_OR_FLOAT (arg, 0); |
b70021f4 | 606 | |
4b6baf5f RS |
607 | if (XTYPE (arg) == Lisp_Float) |
608 | IN_FLOAT (arg = make_float (fabs (XFLOAT (arg)->data)), "abs", arg); | |
609 | else if (XINT (arg) < 0) | |
610 | XSETINT (arg, - XFASTINT (arg)); | |
b70021f4 | 611 | |
4b6baf5f | 612 | return arg; |
b70021f4 MR |
613 | } |
614 | ||
615 | DEFUN ("float", Ffloat, Sfloat, 1, 1, 0, | |
616 | "Return the floating point number equal to ARG.") | |
4b6baf5f RS |
617 | (arg) |
618 | register Lisp_Object arg; | |
b70021f4 | 619 | { |
4b6baf5f | 620 | CHECK_NUMBER_OR_FLOAT (arg, 0); |
b70021f4 | 621 | |
4b6baf5f RS |
622 | if (XTYPE (arg) == Lisp_Int) |
623 | return make_float ((double) XINT (arg)); | |
b70021f4 | 624 | else /* give 'em the same float back */ |
4b6baf5f | 625 | return arg; |
b70021f4 MR |
626 | } |
627 | ||
628 | DEFUN ("logb", Flogb, Slogb, 1, 1, 0, | |
340176df | 629 | "Returns the integer not greater than the base 2 log of the magnitude of ARG.\n\ |
b70021f4 | 630 | This is the same as the exponent of a float.") |
4b6baf5f RS |
631 | (arg) |
632 | Lisp_Object arg; | |
b70021f4 | 633 | { |
340176df | 634 | Lisp_Object val; |
5bf54166 RS |
635 | int value; |
636 | double f = extract_float (arg); | |
340176df | 637 | |
6d3c6adb JB |
638 | #ifdef HAVE_LOGB |
639 | IN_FLOAT (value = logb (f), "logb", arg); | |
640 | XSET (val, Lisp_Int, value); | |
641 | #else | |
642 | #ifdef HAVE_FREXP | |
c26406fe JB |
643 | { |
644 | int exp; | |
645 | ||
646 | IN_FLOAT (frexp (f, &exp), "logb", arg); | |
647 | XSET (val, Lisp_Int, exp-1); | |
648 | } | |
649 | #else | |
6d3c6adb JB |
650 | Well, what *do* you have? |
651 | #endif | |
340176df | 652 | #endif |
c26406fe JB |
653 | |
654 | return val; | |
b70021f4 MR |
655 | } |
656 | ||
657 | /* the rounding functions */ | |
658 | ||
659 | DEFUN ("ceiling", Fceiling, Sceiling, 1, 1, 0, | |
660 | "Return the smallest integer no less than ARG. (Round toward +inf.)") | |
4b6baf5f RS |
661 | (arg) |
662 | register Lisp_Object arg; | |
b70021f4 | 663 | { |
4b6baf5f | 664 | CHECK_NUMBER_OR_FLOAT (arg, 0); |
b70021f4 | 665 | |
4b6baf5f | 666 | if (XTYPE (arg) == Lisp_Float) |
63a81d88 | 667 | IN_FLOAT (XSET (arg, Lisp_Int, ceil (XFLOAT (arg)->data)), "ceiling", arg); |
b70021f4 | 668 | |
4b6baf5f | 669 | return arg; |
b70021f4 MR |
670 | } |
671 | ||
672 | DEFUN ("floor", Ffloor, Sfloor, 1, 1, 0, | |
673 | "Return the largest integer no greater than ARG. (Round towards -inf.)") | |
4b6baf5f RS |
674 | (arg) |
675 | register Lisp_Object arg; | |
b70021f4 | 676 | { |
4b6baf5f | 677 | CHECK_NUMBER_OR_FLOAT (arg, 0); |
b70021f4 | 678 | |
4b6baf5f RS |
679 | if (XTYPE (arg) == Lisp_Float) |
680 | IN_FLOAT (XSET (arg, Lisp_Int, floor (XFLOAT (arg)->data)), "floor", arg); | |
b70021f4 | 681 | |
4b6baf5f | 682 | return arg; |
b70021f4 MR |
683 | } |
684 | ||
685 | DEFUN ("round", Fround, Sround, 1, 1, 0, | |
686 | "Return the nearest integer to ARG.") | |
4b6baf5f RS |
687 | (arg) |
688 | register Lisp_Object arg; | |
b70021f4 | 689 | { |
4b6baf5f | 690 | CHECK_NUMBER_OR_FLOAT (arg, 0); |
b70021f4 | 691 | |
4b6baf5f RS |
692 | if (XTYPE (arg) == Lisp_Float) |
693 | /* Screw the prevailing rounding mode. */ | |
694 | IN_FLOAT (XSET (arg, Lisp_Int, rint (XFLOAT (arg)->data)), "round", arg); | |
b70021f4 | 695 | |
4b6baf5f | 696 | return arg; |
b70021f4 MR |
697 | } |
698 | ||
699 | DEFUN ("truncate", Ftruncate, Struncate, 1, 1, 0, | |
700 | "Truncate a floating point number to an int.\n\ | |
701 | Rounds the value toward zero.") | |
4b6baf5f RS |
702 | (arg) |
703 | register Lisp_Object arg; | |
b70021f4 | 704 | { |
4b6baf5f | 705 | CHECK_NUMBER_OR_FLOAT (arg, 0); |
b70021f4 | 706 | |
4b6baf5f RS |
707 | if (XTYPE (arg) == Lisp_Float) |
708 | XSET (arg, Lisp_Int, (int) XFLOAT (arg)->data); | |
709 | ||
710 | return arg; | |
711 | } | |
712 | \f | |
713 | #if 0 | |
714 | /* It's not clear these are worth adding. */ | |
715 | ||
716 | DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0, | |
717 | "Return the smallest integer no less than ARG, as a float.\n\ | |
718 | \(Round toward +inf.\)") | |
719 | (arg) | |
720 | register Lisp_Object arg; | |
721 | { | |
722 | double d = extract_float (arg); | |
723 | IN_FLOAT (d = ceil (d), "fceiling", arg); | |
724 | return make_float (d); | |
725 | } | |
726 | ||
727 | DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0, | |
728 | "Return the largest integer no greater than ARG, as a float.\n\ | |
729 | \(Round towards -inf.\)") | |
730 | (arg) | |
731 | register Lisp_Object arg; | |
732 | { | |
733 | double d = extract_float (arg); | |
734 | IN_FLOAT (d = floor (d), "ffloor", arg); | |
735 | return make_float (d); | |
736 | } | |
b70021f4 | 737 | |
4b6baf5f RS |
738 | DEFUN ("fround", Ffround, Sfround, 1, 1, 0, |
739 | "Return the nearest integer to ARG, as a float.") | |
740 | (arg) | |
741 | register Lisp_Object arg; | |
742 | { | |
743 | double d = extract_float (arg); | |
744 | IN_FLOAT (d = rint (XFLOAT (arg)->data), "fround", arg); | |
745 | return make_float (d); | |
746 | } | |
747 | ||
748 | DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0, | |
749 | "Truncate a floating point number to an integral float value.\n\ | |
750 | Rounds the value toward zero.") | |
751 | (arg) | |
752 | register Lisp_Object arg; | |
753 | { | |
754 | double d = extract_float (arg); | |
755 | if (d >= 0.0) | |
756 | IN_FLOAT (d = floor (d), "ftruncate", arg); | |
757 | else | |
758 | IN_FLOAT (d = ceil (d), arg); | |
759 | return make_float (d); | |
b70021f4 | 760 | } |
4b6baf5f | 761 | #endif |
b70021f4 | 762 | \f |
4b6baf5f | 763 | #ifdef FLOAT_CATCH_SIGILL |
4746118a | 764 | static SIGTYPE |
b70021f4 MR |
765 | float_error (signo) |
766 | int signo; | |
767 | { | |
768 | if (! in_float) | |
769 | fatal_error_signal (signo); | |
770 | ||
265a9e55 | 771 | #ifdef BSD |
b70021f4 MR |
772 | #ifdef BSD4_1 |
773 | sigrelse (SIGILL); | |
774 | #else /* not BSD4_1 */ | |
e065a56e | 775 | sigsetmask (SIGEMPTYMASK); |
b70021f4 | 776 | #endif /* not BSD4_1 */ |
265a9e55 JB |
777 | #else |
778 | /* Must reestablish handler each time it is called. */ | |
779 | signal (SIGILL, float_error); | |
780 | #endif /* BSD */ | |
b70021f4 MR |
781 | |
782 | in_float = 0; | |
783 | ||
784 | Fsignal (Qarith_error, Fcons (float_error_arg, Qnil)); | |
785 | } | |
786 | ||
4b6baf5f RS |
787 | /* Another idea was to replace the library function `infnan' |
788 | where SIGILL is signaled. */ | |
789 | ||
790 | #endif /* FLOAT_CATCH_SIGILL */ | |
791 | ||
792 | #ifdef HAVE_MATHERR | |
793 | int | |
794 | matherr (x) | |
795 | struct exception *x; | |
796 | { | |
797 | Lisp_Object args; | |
798 | if (! in_float) | |
799 | /* Not called from emacs-lisp float routines; do the default thing. */ | |
800 | return 0; | |
801 | if (!strcmp (x->name, "pow")) | |
802 | x->name = "expt"; | |
803 | ||
804 | args | |
805 | = Fcons (build_string (x->name), | |
806 | Fcons (make_float (x->arg1), | |
807 | ((!strcmp (x->name, "log") || !strcmp (x->name, "pow")) | |
808 | ? Fcons (make_float (x->arg2), Qnil) | |
809 | : Qnil))); | |
810 | switch (x->type) | |
811 | { | |
812 | case DOMAIN: Fsignal (Qdomain_error, args); break; | |
813 | case SING: Fsignal (Qsingularity_error, args); break; | |
814 | case OVERFLOW: Fsignal (Qoverflow_error, args); break; | |
815 | case UNDERFLOW: Fsignal (Qunderflow_error, args); break; | |
816 | default: Fsignal (Qarith_error, args); break; | |
817 | } | |
818 | return (1); /* don't set errno or print a message */ | |
819 | } | |
820 | #endif /* HAVE_MATHERR */ | |
821 | ||
b70021f4 MR |
822 | init_floatfns () |
823 | { | |
4b6baf5f | 824 | #ifdef FLOAT_CATCH_SIGILL |
b70021f4 | 825 | signal (SIGILL, float_error); |
4b6baf5f | 826 | #endif |
b70021f4 MR |
827 | in_float = 0; |
828 | } | |
829 | ||
830 | syms_of_floatfns () | |
831 | { | |
832 | defsubr (&Sacos); | |
b70021f4 | 833 | defsubr (&Sasin); |
b70021f4 | 834 | defsubr (&Satan); |
c2d4ea74 RS |
835 | defsubr (&Scos); |
836 | defsubr (&Ssin); | |
837 | defsubr (&Stan); | |
838 | #if 0 | |
839 | defsubr (&Sacosh); | |
840 | defsubr (&Sasinh); | |
b70021f4 | 841 | defsubr (&Satanh); |
c2d4ea74 RS |
842 | defsubr (&Scosh); |
843 | defsubr (&Ssinh); | |
844 | defsubr (&Stanh); | |
b70021f4 MR |
845 | defsubr (&Sbessel_y0); |
846 | defsubr (&Sbessel_y1); | |
847 | defsubr (&Sbessel_yn); | |
848 | defsubr (&Sbessel_j0); | |
849 | defsubr (&Sbessel_j1); | |
850 | defsubr (&Sbessel_jn); | |
b70021f4 MR |
851 | defsubr (&Serf); |
852 | defsubr (&Serfc); | |
c2d4ea74 | 853 | defsubr (&Slog_gamma); |
4b6baf5f RS |
854 | defsubr (&Scube_root); |
855 | defsubr (&Sfceiling); | |
856 | defsubr (&Sffloor); | |
857 | defsubr (&Sfround); | |
858 | defsubr (&Sftruncate); | |
c2d4ea74 | 859 | #endif |
b70021f4 | 860 | defsubr (&Sexp); |
c2d4ea74 | 861 | defsubr (&Sexpt); |
b70021f4 MR |
862 | defsubr (&Slog); |
863 | defsubr (&Slog10); | |
b70021f4 | 864 | defsubr (&Ssqrt); |
b70021f4 MR |
865 | |
866 | defsubr (&Sabs); | |
867 | defsubr (&Sfloat); | |
868 | defsubr (&Slogb); | |
869 | defsubr (&Sceiling); | |
870 | defsubr (&Sfloor); | |
871 | defsubr (&Sround); | |
872 | defsubr (&Struncate); | |
873 | } | |
874 | ||
875 | #else /* not LISP_FLOAT_TYPE */ | |
876 | ||
877 | init_floatfns () | |
878 | {} | |
879 | ||
880 | syms_of_floatfns () | |
881 | {} | |
882 | ||
883 | #endif /* not LISP_FLOAT_TYPE */ |