Mercurial > emacs
comparison src/floatfns.c @ 102:0d3a6b3b64a4
Initial revision
author | Mike Rowan <mtr@gnu.org> |
---|---|
date | Thu, 27 Sep 1990 21:17:59 +0000 |
parents | |
children | 8c615e453683 |
comparison
equal
deleted
inserted
replaced
101:e5355ef53e1c | 102:0d3a6b3b64a4 |
---|---|
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 | |
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 | |
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 | |
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 | |
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 | |
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 | |
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 */ |