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