Commit | Line | Data |
---|---|---|
b70021f4 | 1 | /* Primitive operations on floating point for GNU Emacs Lisp interpreter. |
4746118a | 2 | Copyright (C) 1988, 1992 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 | ||
21 | #include <signal.h> | |
22 | ||
23 | #include "config.h" | |
24 | #include "lisp.h" | |
e065a56e | 25 | #include "syssignal.h" |
b70021f4 MR |
26 | |
27 | Lisp_Object Qarith_error; | |
28 | ||
29 | #ifdef LISP_FLOAT_TYPE | |
265a9e55 | 30 | |
b70021f4 | 31 | #include <math.h> |
265a9e55 JB |
32 | #include <errno.h> |
33 | ||
34 | extern int errno; | |
35 | ||
36 | /* Avoid traps on VMS from sinh and cosh. | |
37 | All the other functions set errno instead. */ | |
38 | ||
39 | #ifdef VMS | |
40 | #undef cosh | |
41 | #undef sinh | |
42 | #define cosh(x) ((exp(x)+exp(-x))*0.5) | |
43 | #define sinh(x) ((exp(x)-exp(-x))*0.5) | |
44 | #endif /* VMS */ | |
45 | ||
4746118a | 46 | static SIGTYPE float_error (); |
b70021f4 MR |
47 | |
48 | /* Nonzero while executing in floating point. | |
49 | This tells float_error what to do. */ | |
50 | ||
51 | static int in_float; | |
52 | ||
53 | /* If an argument is out of range for a mathematical function, | |
265a9e55 | 54 | here is the actual argument value to use in the error message. */ |
b70021f4 MR |
55 | |
56 | static Lisp_Object float_error_arg; | |
57 | ||
265a9e55 JB |
58 | /* Evaluate the floating point expression D, recording NUM |
59 | as the original argument for error messages. | |
60 | D is normally an assignment expression. | |
61 | Handle errors which may result in signals or may set errno. */ | |
62 | ||
63 | #define IN_FLOAT(D, NUM) \ | |
4746118a JB |
64 | (in_float = 1, errno = 0, float_error_arg = NUM, (D), \ |
65 | (errno == ERANGE || errno == EDOM ? float_error () : (SIGTYPE) 0), \ | |
265a9e55 | 66 | in_float = 0) |
b70021f4 MR |
67 | |
68 | /* Extract a Lisp number as a `double', or signal an error. */ | |
69 | ||
70 | double | |
71 | extract_float (num) | |
72 | Lisp_Object num; | |
73 | { | |
74 | CHECK_NUMBER_OR_FLOAT (num, 0); | |
75 | ||
76 | if (XTYPE (num) == Lisp_Float) | |
77 | return XFLOAT (num)->data; | |
78 | return (double) XINT (num); | |
79 | } | |
80 | ||
81 | DEFUN ("acos", Facos, Sacos, 1, 1, 0, | |
82 | "Return the inverse cosine of ARG.") | |
83 | (num) | |
84 | register Lisp_Object num; | |
85 | { | |
86 | double d = extract_float (num); | |
87 | IN_FLOAT (d = acos (d), num); | |
88 | return make_float (d); | |
89 | } | |
90 | ||
91 | DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0, | |
92 | "Return the inverse hyperbolic cosine of ARG.") | |
93 | (num) | |
94 | register Lisp_Object num; | |
95 | { | |
96 | double d = extract_float (num); | |
97 | IN_FLOAT (d = acosh (d), num); | |
98 | return make_float (d); | |
99 | } | |
100 | ||
101 | DEFUN ("asin", Fasin, Sasin, 1, 1, 0, | |
102 | "Return the inverse sine of ARG.") | |
103 | (num) | |
104 | register Lisp_Object num; | |
105 | { | |
106 | double d = extract_float (num); | |
107 | IN_FLOAT (d = asin (d), num); | |
108 | return make_float (d); | |
109 | } | |
110 | ||
111 | DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0, | |
112 | "Return the inverse hyperbolic sine of ARG.") | |
113 | (num) | |
114 | register Lisp_Object num; | |
115 | { | |
116 | double d = extract_float (num); | |
117 | IN_FLOAT (d = asinh (d), num); | |
118 | return make_float (d); | |
119 | } | |
120 | ||
121 | DEFUN ("atan", Fatan, Satan, 1, 1, 0, | |
122 | "Return the inverse tangent of ARG.") | |
123 | (num) | |
124 | register Lisp_Object num; | |
125 | { | |
126 | double d = extract_float (num); | |
127 | IN_FLOAT (d = atan (d), num); | |
128 | return make_float (d); | |
129 | } | |
130 | ||
131 | DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0, | |
132 | "Return the inverse hyperbolic tangent of ARG.") | |
133 | (num) | |
134 | register Lisp_Object num; | |
135 | { | |
136 | double d = extract_float (num); | |
137 | IN_FLOAT (d = atanh (d), num); | |
138 | return make_float (d); | |
139 | } | |
140 | \f | |
141 | DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0, | |
142 | "Return the bessel function j0 of ARG.") | |
143 | (num) | |
144 | register Lisp_Object num; | |
145 | { | |
146 | double d = extract_float (num); | |
147 | IN_FLOAT (d = j0 (d), num); | |
148 | return make_float (d); | |
149 | } | |
150 | ||
151 | DEFUN ("bessel-j1", Fbessel_j1, Sbessel_j1, 1, 1, 0, | |
152 | "Return the bessel function j1 of ARG.") | |
153 | (num) | |
154 | register Lisp_Object num; | |
155 | { | |
156 | double d = extract_float (num); | |
157 | IN_FLOAT (d = j1 (d), num); | |
158 | return make_float (d); | |
159 | } | |
160 | ||
161 | DEFUN ("bessel-jn", Fbessel_jn, Sbessel_jn, 2, 2, 0, | |
162 | "Return the order N bessel function output jn of ARG.\n\ | |
163 | The first arg (the order) is truncated to an integer.") | |
164 | (num1, num2) | |
165 | register Lisp_Object num1, num2; | |
166 | { | |
167 | int i1 = extract_float (num1); | |
168 | double f2 = extract_float (num2); | |
169 | ||
170 | IN_FLOAT (f2 = jn (i1, f2), num1); | |
171 | return make_float (f2); | |
172 | } | |
173 | ||
174 | DEFUN ("bessel-y0", Fbessel_y0, Sbessel_y0, 1, 1, 0, | |
175 | "Return the bessel function y0 of ARG.") | |
176 | (num) | |
177 | register Lisp_Object num; | |
178 | { | |
179 | double d = extract_float (num); | |
180 | IN_FLOAT (d = y0 (d), num); | |
181 | return make_float (d); | |
182 | } | |
183 | ||
184 | DEFUN ("bessel-y1", Fbessel_y1, Sbessel_y1, 1, 1, 0, | |
185 | "Return the bessel function y1 of ARG.") | |
186 | (num) | |
187 | register Lisp_Object num; | |
188 | { | |
189 | double d = extract_float (num); | |
190 | IN_FLOAT (d = y1 (d), num); | |
191 | return make_float (d); | |
192 | } | |
193 | ||
194 | DEFUN ("bessel-yn", Fbessel_yn, Sbessel_yn, 2, 2, 0, | |
195 | "Return the order N bessel function output yn of ARG.\n\ | |
196 | The first arg (the order) is truncated to an integer.") | |
197 | (num1, num2) | |
198 | register Lisp_Object num1, num2; | |
199 | { | |
200 | int i1 = extract_float (num1); | |
201 | double f2 = extract_float (num2); | |
202 | ||
203 | IN_FLOAT (f2 = yn (i1, f2), num1); | |
204 | return make_float (f2); | |
205 | } | |
206 | \f | |
207 | DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0, | |
208 | "Return the cube root of ARG.") | |
209 | (num) | |
210 | register Lisp_Object num; | |
211 | { | |
212 | double d = extract_float (num); | |
213 | IN_FLOAT (d = cbrt (d), num); | |
214 | return make_float (d); | |
215 | } | |
216 | ||
217 | DEFUN ("cos", Fcos, Scos, 1, 1, 0, | |
218 | "Return the cosine of ARG.") | |
219 | (num) | |
220 | register Lisp_Object num; | |
221 | { | |
222 | double d = extract_float (num); | |
223 | IN_FLOAT (d = cos (d), num); | |
224 | return make_float (d); | |
225 | } | |
226 | ||
227 | DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0, | |
228 | "Return the hyperbolic cosine of ARG.") | |
229 | (num) | |
230 | register Lisp_Object num; | |
231 | { | |
232 | double d = extract_float (num); | |
233 | IN_FLOAT (d = cosh (d), num); | |
234 | return make_float (d); | |
235 | } | |
236 | ||
237 | DEFUN ("erf", Ferf, Serf, 1, 1, 0, | |
238 | "Return the mathematical error function of ARG.") | |
239 | (num) | |
240 | register Lisp_Object num; | |
241 | { | |
242 | double d = extract_float (num); | |
243 | IN_FLOAT (d = erf (d), num); | |
244 | return make_float (d); | |
245 | } | |
246 | ||
247 | DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0, | |
248 | "Return the complementary error function of ARG.") | |
249 | (num) | |
250 | register Lisp_Object num; | |
251 | { | |
252 | double d = extract_float (num); | |
253 | IN_FLOAT (d = erfc (d), num); | |
254 | return make_float (d); | |
255 | } | |
256 | ||
257 | DEFUN ("exp", Fexp, Sexp, 1, 1, 0, | |
258 | "Return the exponential base e of ARG.") | |
259 | (num) | |
260 | register Lisp_Object num; | |
261 | { | |
262 | double d = extract_float (num); | |
263 | IN_FLOAT (d = exp (d), num); | |
264 | return make_float (d); | |
265 | } | |
266 | ||
267 | DEFUN ("expm1", Fexpm1, Sexpm1, 1, 1, 0, | |
268 | "Return the exp (x)-1 of ARG.") | |
269 | (num) | |
270 | register Lisp_Object num; | |
271 | { | |
272 | double d = extract_float (num); | |
273 | IN_FLOAT (d = expm1 (d), num); | |
274 | return make_float (d); | |
275 | } | |
276 | \f | |
277 | DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0, | |
278 | "Return the log gamma of ARG.") | |
279 | (num) | |
280 | register Lisp_Object num; | |
281 | { | |
282 | double d = extract_float (num); | |
283 | IN_FLOAT (d = lgamma (d), num); | |
284 | return make_float (d); | |
285 | } | |
286 | ||
287 | DEFUN ("log", Flog, Slog, 1, 1, 0, | |
288 | "Return the natural logarithm of ARG.") | |
289 | (num) | |
290 | register Lisp_Object num; | |
291 | { | |
292 | double d = extract_float (num); | |
293 | IN_FLOAT (d = log (d), num); | |
294 | return make_float (d); | |
295 | } | |
296 | ||
297 | DEFUN ("log10", Flog10, Slog10, 1, 1, 0, | |
298 | "Return the logarithm base 10 of ARG.") | |
299 | (num) | |
300 | register Lisp_Object num; | |
301 | { | |
302 | double d = extract_float (num); | |
303 | IN_FLOAT (d = log10 (d), num); | |
304 | return make_float (d); | |
305 | } | |
306 | ||
307 | DEFUN ("log1p", Flog1p, Slog1p, 1, 1, 0, | |
308 | "Return the log (1+x) of ARG.") | |
309 | (num) | |
310 | register Lisp_Object num; | |
311 | { | |
312 | double d = extract_float (num); | |
313 | IN_FLOAT (d = log1p (d), num); | |
314 | return make_float (d); | |
315 | } | |
316 | ||
317 | DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, | |
318 | "Return the exponential x ** y.") | |
319 | (num1, num2) | |
320 | register Lisp_Object num1, num2; | |
321 | { | |
322 | double f1, f2; | |
323 | ||
324 | CHECK_NUMBER_OR_FLOAT (num1, 0); | |
325 | CHECK_NUMBER_OR_FLOAT (num2, 0); | |
326 | if ((XTYPE (num1) == Lisp_Int) && /* common lisp spec */ | |
327 | (XTYPE (num2) == Lisp_Int)) /* don't promote, if both are ints */ | |
328 | { /* this can be improved by pre-calculating */ | |
329 | int acc, x, y; /* some binary powers of x then acumulating */ | |
330 | /* these, therby saving some time. -wsr */ | |
331 | x = XINT (num1); | |
332 | y = XINT (num2); | |
333 | acc = 1; | |
334 | ||
335 | if (y < 0) | |
336 | { | |
337 | for (; y < 0; y++) | |
338 | acc /= x; | |
339 | } | |
340 | else | |
341 | { | |
342 | for (; y > 0; y--) | |
343 | acc *= x; | |
344 | } | |
345 | return XSET (x, Lisp_Int, acc); | |
346 | } | |
347 | f1 = (XTYPE (num1) == Lisp_Float) ? XFLOAT (num1)->data : XINT (num1); | |
348 | f2 = (XTYPE (num2) == Lisp_Float) ? XFLOAT (num2)->data : XINT (num2); | |
349 | IN_FLOAT (f1 = pow (f1, f2), num1); | |
350 | return make_float (f1); | |
351 | } | |
352 | \f | |
353 | DEFUN ("sin", Fsin, Ssin, 1, 1, 0, | |
354 | "Return the sine of ARG.") | |
355 | (num) | |
356 | register Lisp_Object num; | |
357 | { | |
358 | double d = extract_float (num); | |
359 | IN_FLOAT (d = sin (d), num); | |
360 | return make_float (d); | |
361 | } | |
362 | ||
363 | DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0, | |
364 | "Return the hyperbolic sine of ARG.") | |
365 | (num) | |
366 | register Lisp_Object num; | |
367 | { | |
368 | double d = extract_float (num); | |
369 | IN_FLOAT (d = sinh (d), num); | |
370 | return make_float (d); | |
371 | } | |
372 | ||
373 | DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0, | |
374 | "Return the square root of ARG.") | |
375 | (num) | |
376 | register Lisp_Object num; | |
377 | { | |
378 | double d = extract_float (num); | |
379 | IN_FLOAT (d = sqrt (d), num); | |
380 | return make_float (d); | |
381 | } | |
382 | ||
383 | DEFUN ("tan", Ftan, Stan, 1, 1, 0, | |
384 | "Return the tangent of ARG.") | |
385 | (num) | |
386 | register Lisp_Object num; | |
387 | { | |
388 | double d = extract_float (num); | |
389 | IN_FLOAT (d = tan (d), num); | |
390 | return make_float (d); | |
391 | } | |
392 | ||
393 | DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0, | |
394 | "Return the hyperbolic tangent of ARG.") | |
395 | (num) | |
396 | register Lisp_Object num; | |
397 | { | |
398 | double d = extract_float (num); | |
399 | IN_FLOAT (d = tanh (d), num); | |
400 | return make_float (d); | |
401 | } | |
402 | \f | |
403 | DEFUN ("abs", Fabs, Sabs, 1, 1, 0, | |
404 | "Return the absolute value of ARG.") | |
405 | (num) | |
406 | register Lisp_Object num; | |
407 | { | |
408 | CHECK_NUMBER_OR_FLOAT (num, 0); | |
409 | ||
410 | if (XTYPE (num) == Lisp_Float) | |
411 | IN_FLOAT (num = make_float (fabs (XFLOAT (num)->data)), num); | |
412 | else if (XINT (num) < 0) | |
413 | XSETINT (num, - XFASTINT (num)); | |
414 | ||
415 | return num; | |
416 | } | |
417 | ||
418 | DEFUN ("float", Ffloat, Sfloat, 1, 1, 0, | |
419 | "Return the floating point number equal to ARG.") | |
420 | (num) | |
421 | register Lisp_Object num; | |
422 | { | |
423 | CHECK_NUMBER_OR_FLOAT (num, 0); | |
424 | ||
425 | if (XTYPE (num) == Lisp_Int) | |
426 | return make_float ((double) XINT (num)); | |
427 | else /* give 'em the same float back */ | |
428 | return num; | |
429 | } | |
430 | ||
431 | DEFUN ("logb", Flogb, Slogb, 1, 1, 0, | |
432 | "Returns the integer that is the base 2 log of ARG.\n\ | |
433 | This is the same as the exponent of a float.") | |
434 | (num) | |
435 | Lisp_Object num; | |
436 | { | |
437 | Lisp_Object val; | |
438 | double f; | |
439 | ||
440 | CHECK_NUMBER_OR_FLOAT (num, 0); | |
441 | f = (XTYPE (num) == Lisp_Float) ? XFLOAT (num)->data : XINT (num); | |
442 | IN_FLOAT (val = logb (f), num); | |
443 | XSET (val, Lisp_Int, val); | |
444 | return val; | |
445 | } | |
446 | ||
447 | /* the rounding functions */ | |
448 | ||
449 | DEFUN ("ceiling", Fceiling, Sceiling, 1, 1, 0, | |
450 | "Return the smallest integer no less than ARG. (Round toward +inf.)") | |
451 | (num) | |
452 | register Lisp_Object num; | |
453 | { | |
454 | CHECK_NUMBER_OR_FLOAT (num, 0); | |
455 | ||
456 | if (XTYPE (num) == Lisp_Float) | |
457 | IN_FLOAT (XSET (num, Lisp_Int, ceil (XFLOAT (num)->data)), num); | |
458 | ||
459 | return num; | |
460 | } | |
461 | ||
462 | DEFUN ("floor", Ffloor, Sfloor, 1, 1, 0, | |
463 | "Return the largest integer no greater than ARG. (Round towards -inf.)") | |
464 | (num) | |
465 | register Lisp_Object num; | |
466 | { | |
467 | CHECK_NUMBER_OR_FLOAT (num, 0); | |
468 | ||
469 | if (XTYPE (num) == Lisp_Float) | |
470 | IN_FLOAT (XSET (num, Lisp_Int, floor (XFLOAT (num)->data)), num); | |
471 | ||
472 | return num; | |
473 | } | |
474 | ||
475 | DEFUN ("round", Fround, Sround, 1, 1, 0, | |
476 | "Return the nearest integer to ARG.") | |
477 | (num) | |
478 | register Lisp_Object num; | |
479 | { | |
480 | CHECK_NUMBER_OR_FLOAT (num, 0); | |
481 | ||
482 | if (XTYPE (num) == Lisp_Float) | |
483 | IN_FLOAT (XSET (num, Lisp_Int, rint (XFLOAT (num)->data)), num); | |
484 | ||
485 | return num; | |
486 | } | |
487 | ||
488 | DEFUN ("truncate", Ftruncate, Struncate, 1, 1, 0, | |
489 | "Truncate a floating point number to an int.\n\ | |
490 | Rounds the value toward zero.") | |
491 | (num) | |
492 | register Lisp_Object num; | |
493 | { | |
494 | CHECK_NUMBER_OR_FLOAT (num, 0); | |
495 | ||
496 | if (XTYPE (num) == Lisp_Float) | |
497 | XSET (num, Lisp_Int, (int) XFLOAT (num)->data); | |
498 | ||
499 | return num; | |
500 | } | |
501 | \f | |
4746118a | 502 | static SIGTYPE |
b70021f4 MR |
503 | float_error (signo) |
504 | int signo; | |
505 | { | |
506 | if (! in_float) | |
507 | fatal_error_signal (signo); | |
508 | ||
265a9e55 | 509 | #ifdef BSD |
b70021f4 MR |
510 | #ifdef BSD4_1 |
511 | sigrelse (SIGILL); | |
512 | #else /* not BSD4_1 */ | |
e065a56e | 513 | sigsetmask (SIGEMPTYMASK); |
b70021f4 | 514 | #endif /* not BSD4_1 */ |
265a9e55 JB |
515 | #else |
516 | /* Must reestablish handler each time it is called. */ | |
517 | signal (SIGILL, float_error); | |
518 | #endif /* BSD */ | |
b70021f4 MR |
519 | |
520 | in_float = 0; | |
521 | ||
522 | Fsignal (Qarith_error, Fcons (float_error_arg, Qnil)); | |
523 | } | |
524 | ||
b70021f4 MR |
525 | init_floatfns () |
526 | { | |
527 | signal (SIGILL, float_error); | |
528 | in_float = 0; | |
529 | } | |
530 | ||
531 | syms_of_floatfns () | |
532 | { | |
533 | defsubr (&Sacos); | |
534 | defsubr (&Sacosh); | |
535 | defsubr (&Sasin); | |
536 | defsubr (&Sasinh); | |
537 | defsubr (&Satan); | |
538 | defsubr (&Satanh); | |
539 | defsubr (&Sbessel_y0); | |
540 | defsubr (&Sbessel_y1); | |
541 | defsubr (&Sbessel_yn); | |
542 | defsubr (&Sbessel_j0); | |
543 | defsubr (&Sbessel_j1); | |
544 | defsubr (&Sbessel_jn); | |
545 | defsubr (&Scube_root); | |
546 | defsubr (&Scos); | |
547 | defsubr (&Scosh); | |
548 | defsubr (&Serf); | |
549 | defsubr (&Serfc); | |
550 | defsubr (&Sexp); | |
551 | defsubr (&Sexpm1); | |
552 | defsubr (&Slog_gamma); | |
553 | defsubr (&Slog); | |
554 | defsubr (&Slog10); | |
555 | defsubr (&Slog1p); | |
556 | defsubr (&Sexpt); | |
557 | defsubr (&Ssin); | |
558 | defsubr (&Ssinh); | |
559 | defsubr (&Ssqrt); | |
560 | defsubr (&Stan); | |
561 | defsubr (&Stanh); | |
562 | ||
563 | defsubr (&Sabs); | |
564 | defsubr (&Sfloat); | |
565 | defsubr (&Slogb); | |
566 | defsubr (&Sceiling); | |
567 | defsubr (&Sfloor); | |
568 | defsubr (&Sround); | |
569 | defsubr (&Struncate); | |
570 | } | |
571 | ||
572 | #else /* not LISP_FLOAT_TYPE */ | |
573 | ||
574 | init_floatfns () | |
575 | {} | |
576 | ||
577 | syms_of_floatfns () | |
578 | {} | |
579 | ||
580 | #endif /* not LISP_FLOAT_TYPE */ |