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