102
|
1 /* Primitive operations on floating point for GNU Emacs Lisp interpreter.
|
621
|
2 Copyright (C) 1988, 1992 Free Software Foundation, Inc.
|
102
|
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
|
621
|
8 the Free Software Foundation; either version 2, or (at your option)
|
102
|
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"
|
638
|
25 #include "syssignal.h"
|
102
|
26
|
|
27 Lisp_Object Qarith_error;
|
|
28
|
|
29 #ifdef LISP_FLOAT_TYPE
|
485
|
30
|
102
|
31 #include <math.h>
|
485
|
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
|
621
|
46 static SIGTYPE float_error ();
|
102
|
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,
|
485
|
54 here is the actual argument value to use in the error message. */
|
102
|
55
|
|
56 static Lisp_Object float_error_arg;
|
|
57
|
485
|
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) \
|
621
|
64 (in_float = 1, errno = 0, float_error_arg = NUM, (D), \
|
|
65 (errno == ERANGE || errno == EDOM ? float_error () : (SIGTYPE) 0), \
|
485
|
66 in_float = 0)
|
102
|
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
|
|
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
|
|
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
|
|
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
|
|
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
|
|
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
|
621
|
502 static SIGTYPE
|
102
|
503 float_error (signo)
|
|
504 int signo;
|
|
505 {
|
|
506 if (! in_float)
|
|
507 fatal_error_signal (signo);
|
|
508
|
485
|
509 #ifdef BSD
|
102
|
510 #ifdef BSD4_1
|
|
511 sigrelse (SIGILL);
|
|
512 #else /* not BSD4_1 */
|
638
|
513 sigsetmask (SIGEMPTYMASK);
|
102
|
514 #endif /* not BSD4_1 */
|
485
|
515 #else
|
|
516 /* Must reestablish handler each time it is called. */
|
|
517 signal (SIGILL, float_error);
|
|
518 #endif /* BSD */
|
102
|
519
|
|
520 in_float = 0;
|
|
521
|
|
522 Fsignal (Qarith_error, Fcons (float_error_arg, Qnil));
|
|
523 }
|
|
524
|
|
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 */
|