Commit | Line | Data |
---|---|---|
b70021f4 | 1 | /* Primitive operations on floating point for GNU Emacs Lisp interpreter. |
95df8112 | 2 | |
acaf905b | 3 | Copyright (C) 1988, 1993-1994, 1999, 2001-2012 |
95df8112 | 4 | Free Software Foundation, Inc. |
b70021f4 | 5 | |
0a9dd3a7 GM |
6 | Author: Wolfgang Rupprecht |
7 | (according to ack.texi) | |
8 | ||
b70021f4 MR |
9 | This file is part of GNU Emacs. |
10 | ||
9ec0b715 | 11 | GNU Emacs is free software: you can redistribute it and/or modify |
b70021f4 | 12 | it under the terms of the GNU General Public License as published by |
9ec0b715 GM |
13 | the Free Software Foundation, either version 3 of the License, or |
14 | (at your option) any later version. | |
b70021f4 MR |
15 | |
16 | GNU Emacs is distributed in the hope that it will be useful, | |
17 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 | GNU General Public License for more details. | |
20 | ||
21 | You should have received a copy of the GNU General Public License | |
9ec0b715 | 22 | along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ |
b70021f4 MR |
23 | |
24 | ||
4b6baf5f RS |
25 | /* ANSI C requires only these float functions: |
26 | acos, asin, atan, atan2, ceil, cos, cosh, exp, fabs, floor, fmod, | |
27 | frexp, ldexp, log, log10, modf, pow, sin, sinh, sqrt, tan, tanh. | |
28 | ||
29 | Define HAVE_INVERSE_HYPERBOLIC if you have acosh, asinh, and atanh. | |
30 | Define HAVE_CBRT if you have cbrt. | |
dca6c914 | 31 | Define HAVE_RINT if you have a working rint. |
4b6baf5f RS |
32 | If you don't define these, then the appropriate routines will be simulated. |
33 | ||
34 | Define HAVE_MATHERR if on a system supporting the SysV matherr callback. | |
35 | (This should happen automatically.) | |
36 | ||
37 | Define FLOAT_CHECK_ERRNO if the float library routines set errno. | |
38 | This has no effect if HAVE_MATHERR is defined. | |
39 | ||
40 | Define FLOAT_CATCH_SIGILL if the float library routines signal SIGILL. | |
41 | (What systems actually do this? Please let us know.) | |
42 | ||
43 | Define FLOAT_CHECK_DOMAIN if the float library doesn't handle errors by | |
8e6208c5 | 44 | either setting errno, or signaling SIGFPE/SIGILL. Otherwise, domain and |
4b6baf5f RS |
45 | range checking will happen before calling the float routines. This has |
46 | no effect if HAVE_MATHERR is defined (since matherr will be called when | |
47 | a domain error occurs.) | |
48 | */ | |
49 | ||
18160b98 | 50 | #include <config.h> |
68c45bf0 | 51 | #include <signal.h> |
d7306fe6 | 52 | #include <setjmp.h> |
523e9291 RS |
53 | #include "lisp.h" |
54 | #include "syssignal.h" | |
55 | ||
2f261542 | 56 | #include <float.h> |
d137ae2f PE |
57 | /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */ |
58 | #ifndef IEEE_FLOATING_POINT | |
59 | #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \ | |
60 | && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128) | |
61 | #define IEEE_FLOATING_POINT 1 | |
62 | #else | |
63 | #define IEEE_FLOATING_POINT 0 | |
64 | #endif | |
65 | #endif | |
66 | ||
b70021f4 | 67 | #include <math.h> |
4b6baf5f | 68 | |
32085e8e | 69 | /* This declaration is omitted on some systems, like Ultrix. */ |
7a4720e2 | 70 | #if !defined (HPUX) && defined (HAVE_LOGB) && !defined (logb) |
d2aa42f8 | 71 | extern double logb (double); |
7a4720e2 | 72 | #endif /* not HPUX and HAVE_LOGB and no logb macro */ |
c26406fe | 73 | |
5e617bc2 | 74 | #if defined (DOMAIN) && defined (SING) && defined (OVERFLOW) |
4b6baf5f RS |
75 | /* If those are defined, then this is probably a `matherr' machine. */ |
76 | # ifndef HAVE_MATHERR | |
77 | # define HAVE_MATHERR | |
78 | # endif | |
79 | #endif | |
80 | ||
c0f0a4a2 | 81 | #ifdef NO_MATHERR |
f89182a2 RS |
82 | #undef HAVE_MATHERR |
83 | #endif | |
84 | ||
4b6baf5f RS |
85 | #ifdef HAVE_MATHERR |
86 | # ifdef FLOAT_CHECK_ERRNO | |
87 | # undef FLOAT_CHECK_ERRNO | |
88 | # endif | |
89 | # ifdef FLOAT_CHECK_DOMAIN | |
90 | # undef FLOAT_CHECK_DOMAIN | |
91 | # endif | |
92 | #endif | |
93 | ||
94 | #ifndef NO_FLOAT_CHECK_ERRNO | |
95 | #define FLOAT_CHECK_ERRNO | |
96 | #endif | |
97 | ||
98 | #ifdef FLOAT_CHECK_ERRNO | |
99 | # include <errno.h> | |
f12ef5eb | 100 | #endif |
265a9e55 | 101 | |
311346bb | 102 | #ifdef FLOAT_CATCH_SIGILL |
9af30bdf | 103 | static void float_error (); |
311346bb | 104 | #endif |
b70021f4 MR |
105 | |
106 | /* Nonzero while executing in floating point. | |
107 | This tells float_error what to do. */ | |
108 | ||
109 | static int in_float; | |
110 | ||
111 | /* If an argument is out of range for a mathematical function, | |
21876236 RS |
112 | here is the actual argument value to use in the error message. |
113 | These variables are used only across the floating point library call | |
114 | so there is no need to staticpro them. */ | |
b70021f4 | 115 | |
4b6baf5f RS |
116 | static Lisp_Object float_error_arg, float_error_arg2; |
117 | ||
8ea90aa3 | 118 | static const char *float_error_fn_name; |
b70021f4 | 119 | |
265a9e55 JB |
120 | /* Evaluate the floating point expression D, recording NUM |
121 | as the original argument for error messages. | |
122 | D is normally an assignment expression. | |
f8d83099 JB |
123 | Handle errors which may result in signals or may set errno. |
124 | ||
125 | Note that float_error may be declared to return void, so you can't | |
9af30bdf | 126 | just cast the zero after the colon to (void) to make the types |
f8d83099 | 127 | check properly. */ |
265a9e55 | 128 | |
4b6baf5f RS |
129 | #ifdef FLOAT_CHECK_ERRNO |
130 | #define IN_FLOAT(d, name, num) \ | |
131 | do { \ | |
132 | float_error_arg = num; \ | |
133 | float_error_fn_name = name; \ | |
134 | in_float = 1; errno = 0; (d); in_float = 0; \ | |
135 | switch (errno) { \ | |
136 | case 0: break; \ | |
137 | case EDOM: domain_error (float_error_fn_name, float_error_arg); \ | |
138 | case ERANGE: range_error (float_error_fn_name, float_error_arg); \ | |
139 | default: arith_error (float_error_fn_name, float_error_arg); \ | |
140 | } \ | |
141 | } while (0) | |
142 | #define IN_FLOAT2(d, name, num, num2) \ | |
143 | do { \ | |
144 | float_error_arg = num; \ | |
145 | float_error_arg2 = num2; \ | |
146 | float_error_fn_name = name; \ | |
147 | in_float = 1; errno = 0; (d); in_float = 0; \ | |
148 | switch (errno) { \ | |
149 | case 0: break; \ | |
150 | case EDOM: domain_error (float_error_fn_name, float_error_arg); \ | |
151 | case ERANGE: range_error (float_error_fn_name, float_error_arg); \ | |
152 | default: arith_error (float_error_fn_name, float_error_arg); \ | |
153 | } \ | |
154 | } while (0) | |
155 | #else | |
f8131ed2 | 156 | #define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0) |
4b6baf5f RS |
157 | #define IN_FLOAT2(d, name, num, num2) (in_float = 1, (d), in_float = 0) |
158 | #endif | |
159 | ||
81a63ccc KH |
160 | /* Convert float to Lisp_Int if it fits, else signal a range error |
161 | using the given arguments. */ | |
162 | #define FLOAT_TO_INT(x, i, name, num) \ | |
163 | do \ | |
164 | { \ | |
29d823d6 | 165 | if (FIXNUM_OVERFLOW_P (x)) \ |
81a63ccc | 166 | range_error (name, num); \ |
e0cb2a68 | 167 | XSETINT (i, (EMACS_INT)(x)); \ |
81a63ccc KH |
168 | } \ |
169 | while (0) | |
170 | #define FLOAT_TO_INT2(x, i, name, num1, num2) \ | |
171 | do \ | |
172 | { \ | |
29d823d6 | 173 | if (FIXNUM_OVERFLOW_P (x)) \ |
81a63ccc | 174 | range_error2 (name, num1, num2); \ |
e0cb2a68 | 175 | XSETINT (i, (EMACS_INT)(x)); \ |
81a63ccc KH |
176 | } \ |
177 | while (0) | |
178 | ||
4b6baf5f | 179 | #define arith_error(op,arg) \ |
edef1631 | 180 | xsignal2 (Qarith_error, build_string ((op)), (arg)) |
4b6baf5f | 181 | #define range_error(op,arg) \ |
edef1631 | 182 | xsignal2 (Qrange_error, build_string ((op)), (arg)) |
81a63ccc | 183 | #define range_error2(op,a1,a2) \ |
edef1631 | 184 | xsignal3 (Qrange_error, build_string ((op)), (a1), (a2)) |
4b6baf5f | 185 | #define domain_error(op,arg) \ |
edef1631 | 186 | xsignal2 (Qdomain_error, build_string ((op)), (arg)) |
1384fa33 | 187 | #ifdef FLOAT_CHECK_DOMAIN |
4b6baf5f | 188 | #define domain_error2(op,a1,a2) \ |
edef1631 | 189 | xsignal3 (Qdomain_error, build_string ((op)), (a1), (a2)) |
1384fa33 | 190 | #endif |
b70021f4 MR |
191 | |
192 | /* Extract a Lisp number as a `double', or signal an error. */ | |
193 | ||
194 | double | |
d5a3eaaf | 195 | extract_float (Lisp_Object num) |
b70021f4 | 196 | { |
b7826503 | 197 | CHECK_NUMBER_OR_FLOAT (num); |
b70021f4 | 198 | |
207a45c1 | 199 | if (FLOATP (num)) |
70949dac | 200 | return XFLOAT_DATA (num); |
b70021f4 MR |
201 | return (double) XINT (num); |
202 | } | |
c2d4ea74 RS |
203 | \f |
204 | /* Trig functions. */ | |
b70021f4 MR |
205 | |
206 | DEFUN ("acos", Facos, Sacos, 1, 1, 0, | |
335c5470 | 207 | doc: /* Return the inverse cosine of ARG. */) |
5842a27b | 208 | (register Lisp_Object arg) |
b70021f4 | 209 | { |
4b6baf5f RS |
210 | double d = extract_float (arg); |
211 | #ifdef FLOAT_CHECK_DOMAIN | |
212 | if (d > 1.0 || d < -1.0) | |
213 | domain_error ("acos", arg); | |
214 | #endif | |
215 | IN_FLOAT (d = acos (d), "acos", arg); | |
b70021f4 MR |
216 | return make_float (d); |
217 | } | |
218 | ||
c2d4ea74 | 219 | DEFUN ("asin", Fasin, Sasin, 1, 1, 0, |
335c5470 | 220 | doc: /* Return the inverse sine of ARG. */) |
5842a27b | 221 | (register Lisp_Object arg) |
b70021f4 | 222 | { |
4b6baf5f RS |
223 | double d = extract_float (arg); |
224 | #ifdef FLOAT_CHECK_DOMAIN | |
225 | if (d > 1.0 || d < -1.0) | |
226 | domain_error ("asin", arg); | |
227 | #endif | |
228 | IN_FLOAT (d = asin (d), "asin", arg); | |
b70021f4 MR |
229 | return make_float (d); |
230 | } | |
231 | ||
250ffca6 EZ |
232 | DEFUN ("atan", Fatan, Satan, 1, 2, 0, |
233 | doc: /* Return the inverse tangent of the arguments. | |
234 | If only one argument Y is given, return the inverse tangent of Y. | |
235 | If two arguments Y and X are given, return the inverse tangent of Y | |
236 | divided by X, i.e. the angle in radians between the vector (X, Y) | |
237 | and the x-axis. */) | |
5842a27b | 238 | (register Lisp_Object y, Lisp_Object x) |
b70021f4 | 239 | { |
250ffca6 EZ |
240 | double d = extract_float (y); |
241 | ||
242 | if (NILP (x)) | |
243 | IN_FLOAT (d = atan (d), "atan", y); | |
244 | else | |
245 | { | |
246 | double d2 = extract_float (x); | |
247 | ||
248 | IN_FLOAT2 (d = atan2 (d, d2), "atan", y, x); | |
249 | } | |
b70021f4 MR |
250 | return make_float (d); |
251 | } | |
252 | ||
c2d4ea74 | 253 | DEFUN ("cos", Fcos, Scos, 1, 1, 0, |
335c5470 | 254 | doc: /* Return the cosine of ARG. */) |
5842a27b | 255 | (register Lisp_Object arg) |
b70021f4 | 256 | { |
4b6baf5f RS |
257 | double d = extract_float (arg); |
258 | IN_FLOAT (d = cos (d), "cos", arg); | |
b70021f4 MR |
259 | return make_float (d); |
260 | } | |
261 | ||
c2d4ea74 | 262 | DEFUN ("sin", Fsin, Ssin, 1, 1, 0, |
335c5470 | 263 | doc: /* Return the sine of ARG. */) |
5842a27b | 264 | (register Lisp_Object arg) |
b70021f4 | 265 | { |
4b6baf5f RS |
266 | double d = extract_float (arg); |
267 | IN_FLOAT (d = sin (d), "sin", arg); | |
b70021f4 MR |
268 | return make_float (d); |
269 | } | |
270 | ||
c2d4ea74 | 271 | DEFUN ("tan", Ftan, Stan, 1, 1, 0, |
335c5470 | 272 | doc: /* Return the tangent of ARG. */) |
5842a27b | 273 | (register Lisp_Object arg) |
4b6baf5f RS |
274 | { |
275 | double d = extract_float (arg); | |
276 | double c = cos (d); | |
277 | #ifdef FLOAT_CHECK_DOMAIN | |
278 | if (c == 0.0) | |
279 | domain_error ("tan", arg); | |
280 | #endif | |
281 | IN_FLOAT (d = sin (d) / c, "tan", arg); | |
b70021f4 MR |
282 | return make_float (d); |
283 | } | |
15e12598 | 284 | |
c8199d0f PE |
285 | #undef isnan |
286 | #define isnan(x) ((x) != (x)) | |
287 | ||
15e12598 VB |
288 | DEFUN ("isnan", Fisnan, Sisnan, 1, 1, 0, |
289 | doc: /* Return non nil iff argument X is a NaN. */) | |
5842a27b | 290 | (Lisp_Object x) |
15e12598 VB |
291 | { |
292 | CHECK_FLOAT (x); | |
293 | return isnan (XFLOAT_DATA (x)) ? Qt : Qnil; | |
294 | } | |
295 | ||
c8199d0f | 296 | #ifdef HAVE_COPYSIGN |
3c2907f7 | 297 | DEFUN ("copysign", Fcopysign, Scopysign, 2, 2, 0, |
15e12598 VB |
298 | doc: /* Copy sign of X2 to value of X1, and return the result. |
299 | Cause an error if X1 or X2 is not a float. */) | |
5842a27b | 300 | (Lisp_Object x1, Lisp_Object x2) |
15e12598 VB |
301 | { |
302 | double f1, f2; | |
303 | ||
304 | CHECK_FLOAT (x1); | |
305 | CHECK_FLOAT (x2); | |
306 | ||
307 | f1 = XFLOAT_DATA (x1); | |
308 | f2 = XFLOAT_DATA (x2); | |
309 | ||
310 | return make_float (copysign (f1, f2)); | |
311 | } | |
312 | ||
313 | DEFUN ("frexp", Ffrexp, Sfrexp, 1, 1, 0, | |
314 | doc: /* Get significand and exponent of a floating point number. | |
315 | Breaks the floating point number X into its binary significand SGNFCAND | |
316 | \(a floating point value between 0.5 (included) and 1.0 (excluded)) | |
317 | and an integral exponent EXP for 2, such that: | |
318 | ||
319 | X = SGNFCAND * 2^EXP | |
320 | ||
321 | The function returns the cons cell (SGNFCAND . EXP). | |
322 | If X is zero, both parts (SGNFCAND and EXP) are zero. */) | |
5842a27b | 323 | (Lisp_Object x) |
15e12598 VB |
324 | { |
325 | double f = XFLOATINT (x); | |
326 | ||
327 | if (f == 0.0) | |
328 | return Fcons (make_float (0.0), make_number (0)); | |
329 | else | |
330 | { | |
a885e2ed PE |
331 | int exponent; |
332 | double sgnfcand = frexp (f, &exponent); | |
333 | return Fcons (make_float (sgnfcand), make_number (exponent)); | |
15e12598 VB |
334 | } |
335 | } | |
336 | ||
337 | DEFUN ("ldexp", Fldexp, Sldexp, 1, 2, 0, | |
338 | doc: /* Construct number X from significand SGNFCAND and exponent EXP. | |
339 | Returns the floating point value resulting from multiplying SGNFCAND | |
340 | (the significand) by 2 raised to the power of EXP (the exponent). */) | |
a885e2ed | 341 | (Lisp_Object sgnfcand, Lisp_Object exponent) |
15e12598 | 342 | { |
a885e2ed PE |
343 | CHECK_NUMBER (exponent); |
344 | return make_float (ldexp (XFLOATINT (sgnfcand), XINT (exponent))); | |
15e12598 VB |
345 | } |
346 | #endif | |
b70021f4 | 347 | \f |
c2d4ea74 RS |
348 | #if 0 /* Leave these out unless we find there's a reason for them. */ |
349 | ||
b70021f4 | 350 | DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0, |
335c5470 | 351 | doc: /* Return the bessel function j0 of ARG. */) |
5842a27b | 352 | (register Lisp_Object arg) |
b70021f4 | 353 | { |
4b6baf5f RS |
354 | double d = extract_float (arg); |
355 | IN_FLOAT (d = j0 (d), "bessel-j0", arg); | |
b70021f4 MR |
356 | return make_float (d); |
357 | } | |
358 | ||
359 | DEFUN ("bessel-j1", Fbessel_j1, Sbessel_j1, 1, 1, 0, | |
335c5470 | 360 | doc: /* Return the bessel function j1 of ARG. */) |
5842a27b | 361 | (register Lisp_Object arg) |
b70021f4 | 362 | { |
4b6baf5f RS |
363 | double d = extract_float (arg); |
364 | IN_FLOAT (d = j1 (d), "bessel-j1", arg); | |
b70021f4 MR |
365 | return make_float (d); |
366 | } | |
367 | ||
368 | DEFUN ("bessel-jn", Fbessel_jn, Sbessel_jn, 2, 2, 0, | |
335c5470 PJ |
369 | doc: /* Return the order N bessel function output jn of ARG. |
370 | The first arg (the order) is truncated to an integer. */) | |
5842a27b | 371 | (register Lisp_Object n, Lisp_Object arg) |
b70021f4 | 372 | { |
3e670702 EN |
373 | int i1 = extract_float (n); |
374 | double f2 = extract_float (arg); | |
b70021f4 | 375 | |
3e670702 | 376 | IN_FLOAT (f2 = jn (i1, f2), "bessel-jn", n); |
b70021f4 MR |
377 | return make_float (f2); |
378 | } | |
379 | ||
380 | DEFUN ("bessel-y0", Fbessel_y0, Sbessel_y0, 1, 1, 0, | |
335c5470 | 381 | doc: /* Return the bessel function y0 of ARG. */) |
5842a27b | 382 | (register Lisp_Object arg) |
b70021f4 | 383 | { |
4b6baf5f RS |
384 | double d = extract_float (arg); |
385 | IN_FLOAT (d = y0 (d), "bessel-y0", arg); | |
b70021f4 MR |
386 | return make_float (d); |
387 | } | |
388 | ||
389 | DEFUN ("bessel-y1", Fbessel_y1, Sbessel_y1, 1, 1, 0, | |
335c5470 | 390 | doc: /* Return the bessel function y1 of ARG. */) |
5842a27b | 391 | (register Lisp_Object arg) |
b70021f4 | 392 | { |
4b6baf5f RS |
393 | double d = extract_float (arg); |
394 | IN_FLOAT (d = y1 (d), "bessel-y0", arg); | |
b70021f4 MR |
395 | return make_float (d); |
396 | } | |
397 | ||
398 | DEFUN ("bessel-yn", Fbessel_yn, Sbessel_yn, 2, 2, 0, | |
335c5470 PJ |
399 | doc: /* Return the order N bessel function output yn of ARG. |
400 | The first arg (the order) is truncated to an integer. */) | |
5842a27b | 401 | (register Lisp_Object n, Lisp_Object arg) |
b70021f4 | 402 | { |
3e670702 EN |
403 | int i1 = extract_float (n); |
404 | double f2 = extract_float (arg); | |
b70021f4 | 405 | |
3e670702 | 406 | IN_FLOAT (f2 = yn (i1, f2), "bessel-yn", n); |
b70021f4 MR |
407 | return make_float (f2); |
408 | } | |
b70021f4 | 409 | |
c2d4ea74 RS |
410 | #endif |
411 | \f | |
412 | #if 0 /* Leave these out unless we see they are worth having. */ | |
b70021f4 MR |
413 | |
414 | DEFUN ("erf", Ferf, Serf, 1, 1, 0, | |
335c5470 | 415 | doc: /* Return the mathematical error function of ARG. */) |
5842a27b | 416 | (register Lisp_Object arg) |
b70021f4 | 417 | { |
4b6baf5f RS |
418 | double d = extract_float (arg); |
419 | IN_FLOAT (d = erf (d), "erf", arg); | |
b70021f4 MR |
420 | return make_float (d); |
421 | } | |
422 | ||
423 | DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0, | |
335c5470 | 424 | doc: /* Return the complementary error function of ARG. */) |
5842a27b | 425 | (register Lisp_Object arg) |
b70021f4 | 426 | { |
4b6baf5f RS |
427 | double d = extract_float (arg); |
428 | IN_FLOAT (d = erfc (d), "erfc", arg); | |
b70021f4 MR |
429 | return make_float (d); |
430 | } | |
431 | ||
b70021f4 | 432 | DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0, |
335c5470 | 433 | doc: /* Return the log gamma of ARG. */) |
5842a27b | 434 | (register Lisp_Object arg) |
b70021f4 | 435 | { |
4b6baf5f RS |
436 | double d = extract_float (arg); |
437 | IN_FLOAT (d = lgamma (d), "log-gamma", arg); | |
b70021f4 MR |
438 | return make_float (d); |
439 | } | |
440 | ||
4b6baf5f | 441 | DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0, |
335c5470 | 442 | doc: /* Return the cube root of ARG. */) |
5842a27b | 443 | (register Lisp_Object arg) |
b70021f4 | 444 | { |
4b6baf5f RS |
445 | double d = extract_float (arg); |
446 | #ifdef HAVE_CBRT | |
447 | IN_FLOAT (d = cbrt (d), "cube-root", arg); | |
448 | #else | |
449 | if (d >= 0.0) | |
450 | IN_FLOAT (d = pow (d, 1.0/3.0), "cube-root", arg); | |
451 | else | |
452 | IN_FLOAT (d = -pow (-d, 1.0/3.0), "cube-root", arg); | |
453 | #endif | |
b70021f4 MR |
454 | return make_float (d); |
455 | } | |
456 | ||
706ac90d RS |
457 | #endif |
458 | \f | |
c2d4ea74 | 459 | DEFUN ("exp", Fexp, Sexp, 1, 1, 0, |
335c5470 | 460 | doc: /* Return the exponential base e of ARG. */) |
5842a27b | 461 | (register Lisp_Object arg) |
4b6baf5f RS |
462 | { |
463 | double d = extract_float (arg); | |
464 | #ifdef FLOAT_CHECK_DOMAIN | |
465 | if (d > 709.7827) /* Assume IEEE doubles here */ | |
466 | range_error ("exp", arg); | |
467 | else if (d < -709.0) | |
468 | return make_float (0.0); | |
469 | else | |
470 | #endif | |
471 | IN_FLOAT (d = exp (d), "exp", arg); | |
b70021f4 MR |
472 | return make_float (d); |
473 | } | |
474 | ||
b70021f4 | 475 | DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, |
335c5470 | 476 | doc: /* Return the exponential ARG1 ** ARG2. */) |
5842a27b | 477 | (register Lisp_Object arg1, Lisp_Object arg2) |
b70021f4 | 478 | { |
2742fe30 | 479 | double f1, f2, f3; |
b70021f4 | 480 | |
b7826503 PJ |
481 | CHECK_NUMBER_OR_FLOAT (arg1); |
482 | CHECK_NUMBER_OR_FLOAT (arg2); | |
207a45c1 | 483 | if (INTEGERP (arg1) /* common lisp spec */ |
5a9807a8 TTN |
484 | && INTEGERP (arg2) /* don't promote, if both are ints, and */ |
485 | && 0 <= XINT (arg2)) /* we are sure the result is not fractional */ | |
b70021f4 | 486 | { /* this can be improved by pre-calculating */ |
9a51b24a | 487 | EMACS_INT acc, x, y; /* some binary powers of x then accumulating */ |
4be1d460 RS |
488 | Lisp_Object val; |
489 | ||
4b6baf5f RS |
490 | x = XINT (arg1); |
491 | y = XINT (arg2); | |
b70021f4 | 492 | acc = 1; |
177c0ea7 | 493 | |
b70021f4 MR |
494 | if (y < 0) |
495 | { | |
4b6baf5f RS |
496 | if (x == 1) |
497 | acc = 1; | |
498 | else if (x == -1) | |
499 | acc = (y & 1) ? -1 : 1; | |
500 | else | |
501 | acc = 0; | |
b70021f4 MR |
502 | } |
503 | else | |
504 | { | |
4b6baf5f RS |
505 | while (y > 0) |
506 | { | |
507 | if (y & 1) | |
508 | acc *= x; | |
509 | x *= x; | |
395fcb93 | 510 | y >>= 1; |
4b6baf5f | 511 | } |
b70021f4 | 512 | } |
e0cb2a68 | 513 | XSETINT (val, acc); |
4be1d460 | 514 | return val; |
b70021f4 | 515 | } |
70949dac KR |
516 | f1 = FLOATP (arg1) ? XFLOAT_DATA (arg1) : XINT (arg1); |
517 | f2 = FLOATP (arg2) ? XFLOAT_DATA (arg2) : XINT (arg2); | |
4b6baf5f RS |
518 | /* Really should check for overflow, too */ |
519 | if (f1 == 0.0 && f2 == 0.0) | |
520 | f1 = 1.0; | |
521 | #ifdef FLOAT_CHECK_DOMAIN | |
5e617bc2 | 522 | else if ((f1 == 0.0 && f2 < 0.0) || (f1 < 0 && f2 != floor (f2))) |
4b6baf5f RS |
523 | domain_error2 ("expt", arg1, arg2); |
524 | #endif | |
2742fe30 MC |
525 | IN_FLOAT2 (f3 = pow (f1, f2), "expt", arg1, arg2); |
526 | /* Check for overflow in the result. */ | |
527 | if (f1 != 0.0 && f3 == 0.0) | |
528 | range_error ("expt", arg1); | |
529 | return make_float (f3); | |
b70021f4 | 530 | } |
c2d4ea74 | 531 | |
56abb480 | 532 | DEFUN ("log", Flog, Slog, 1, 2, 0, |
335c5470 | 533 | doc: /* Return the natural logarithm of ARG. |
356e6d8d | 534 | If the optional argument BASE is given, return log ARG using that base. */) |
5842a27b | 535 | (register Lisp_Object arg, Lisp_Object base) |
b70021f4 | 536 | { |
4b6baf5f | 537 | double d = extract_float (arg); |
56abb480 | 538 | |
4b6baf5f RS |
539 | #ifdef FLOAT_CHECK_DOMAIN |
540 | if (d <= 0.0) | |
541 | domain_error2 ("log", arg, base); | |
542 | #endif | |
56abb480 | 543 | if (NILP (base)) |
4b6baf5f | 544 | IN_FLOAT (d = log (d), "log", arg); |
56abb480 JB |
545 | else |
546 | { | |
547 | double b = extract_float (base); | |
548 | ||
4b6baf5f RS |
549 | #ifdef FLOAT_CHECK_DOMAIN |
550 | if (b <= 0.0 || b == 1.0) | |
551 | domain_error2 ("log", arg, base); | |
552 | #endif | |
553 | if (b == 10.0) | |
554 | IN_FLOAT2 (d = log10 (d), "log", arg, base); | |
555 | else | |
f8131ed2 | 556 | IN_FLOAT2 (d = log (d) / log (b), "log", arg, base); |
56abb480 | 557 | } |
b70021f4 MR |
558 | return make_float (d); |
559 | } | |
560 | ||
c2d4ea74 | 561 | DEFUN ("log10", Flog10, Slog10, 1, 1, 0, |
335c5470 | 562 | doc: /* Return the logarithm base 10 of ARG. */) |
5842a27b | 563 | (register Lisp_Object arg) |
b70021f4 | 564 | { |
4b6baf5f RS |
565 | double d = extract_float (arg); |
566 | #ifdef FLOAT_CHECK_DOMAIN | |
567 | if (d <= 0.0) | |
568 | domain_error ("log10", arg); | |
569 | #endif | |
570 | IN_FLOAT (d = log10 (d), "log10", arg); | |
c2d4ea74 RS |
571 | return make_float (d); |
572 | } | |
573 | ||
b70021f4 | 574 | DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0, |
335c5470 | 575 | doc: /* Return the square root of ARG. */) |
5842a27b | 576 | (register Lisp_Object arg) |
b70021f4 | 577 | { |
4b6baf5f RS |
578 | double d = extract_float (arg); |
579 | #ifdef FLOAT_CHECK_DOMAIN | |
580 | if (d < 0.0) | |
581 | domain_error ("sqrt", arg); | |
582 | #endif | |
583 | IN_FLOAT (d = sqrt (d), "sqrt", arg); | |
b70021f4 MR |
584 | return make_float (d); |
585 | } | |
c2d4ea74 | 586 | \f |
706ac90d | 587 | #if 0 /* Not clearly worth adding. */ |
b70021f4 | 588 | |
c2d4ea74 | 589 | DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0, |
335c5470 | 590 | doc: /* Return the inverse hyperbolic cosine of ARG. */) |
5842a27b | 591 | (register Lisp_Object arg) |
b70021f4 | 592 | { |
4b6baf5f RS |
593 | double d = extract_float (arg); |
594 | #ifdef FLOAT_CHECK_DOMAIN | |
595 | if (d < 1.0) | |
596 | domain_error ("acosh", arg); | |
597 | #endif | |
598 | #ifdef HAVE_INVERSE_HYPERBOLIC | |
599 | IN_FLOAT (d = acosh (d), "acosh", arg); | |
600 | #else | |
601 | IN_FLOAT (d = log (d + sqrt (d*d - 1.0)), "acosh", arg); | |
602 | #endif | |
c2d4ea74 RS |
603 | return make_float (d); |
604 | } | |
605 | ||
606 | DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0, | |
335c5470 | 607 | doc: /* Return the inverse hyperbolic sine of ARG. */) |
5842a27b | 608 | (register Lisp_Object arg) |
c2d4ea74 | 609 | { |
4b6baf5f RS |
610 | double d = extract_float (arg); |
611 | #ifdef HAVE_INVERSE_HYPERBOLIC | |
612 | IN_FLOAT (d = asinh (d), "asinh", arg); | |
613 | #else | |
614 | IN_FLOAT (d = log (d + sqrt (d*d + 1.0)), "asinh", arg); | |
615 | #endif | |
c2d4ea74 RS |
616 | return make_float (d); |
617 | } | |
618 | ||
619 | DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0, | |
335c5470 | 620 | doc: /* Return the inverse hyperbolic tangent of ARG. */) |
5842a27b | 621 | (register Lisp_Object arg) |
c2d4ea74 | 622 | { |
4b6baf5f RS |
623 | double d = extract_float (arg); |
624 | #ifdef FLOAT_CHECK_DOMAIN | |
625 | if (d >= 1.0 || d <= -1.0) | |
626 | domain_error ("atanh", arg); | |
627 | #endif | |
628 | #ifdef HAVE_INVERSE_HYPERBOLIC | |
629 | IN_FLOAT (d = atanh (d), "atanh", arg); | |
630 | #else | |
631 | IN_FLOAT (d = 0.5 * log ((1.0 + d) / (1.0 - d)), "atanh", arg); | |
632 | #endif | |
c2d4ea74 RS |
633 | return make_float (d); |
634 | } | |
635 | ||
636 | DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0, | |
335c5470 | 637 | doc: /* Return the hyperbolic cosine of ARG. */) |
5842a27b | 638 | (register Lisp_Object arg) |
c2d4ea74 | 639 | { |
4b6baf5f RS |
640 | double d = extract_float (arg); |
641 | #ifdef FLOAT_CHECK_DOMAIN | |
642 | if (d > 710.0 || d < -710.0) | |
643 | range_error ("cosh", arg); | |
644 | #endif | |
645 | IN_FLOAT (d = cosh (d), "cosh", arg); | |
c2d4ea74 RS |
646 | return make_float (d); |
647 | } | |
648 | ||
649 | DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0, | |
335c5470 | 650 | doc: /* Return the hyperbolic sine of ARG. */) |
5842a27b | 651 | (register Lisp_Object arg) |
c2d4ea74 | 652 | { |
4b6baf5f RS |
653 | double d = extract_float (arg); |
654 | #ifdef FLOAT_CHECK_DOMAIN | |
655 | if (d > 710.0 || d < -710.0) | |
656 | range_error ("sinh", arg); | |
657 | #endif | |
658 | IN_FLOAT (d = sinh (d), "sinh", arg); | |
b70021f4 MR |
659 | return make_float (d); |
660 | } | |
661 | ||
662 | DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0, | |
335c5470 | 663 | doc: /* Return the hyperbolic tangent of ARG. */) |
5842a27b | 664 | (register Lisp_Object arg) |
b70021f4 | 665 | { |
4b6baf5f RS |
666 | double d = extract_float (arg); |
667 | IN_FLOAT (d = tanh (d), "tanh", arg); | |
b70021f4 MR |
668 | return make_float (d); |
669 | } | |
c2d4ea74 | 670 | #endif |
b70021f4 MR |
671 | \f |
672 | DEFUN ("abs", Fabs, Sabs, 1, 1, 0, | |
335c5470 | 673 | doc: /* Return the absolute value of ARG. */) |
5842a27b | 674 | (register Lisp_Object arg) |
b70021f4 | 675 | { |
b7826503 | 676 | CHECK_NUMBER_OR_FLOAT (arg); |
b70021f4 | 677 | |
207a45c1 | 678 | if (FLOATP (arg)) |
70949dac | 679 | IN_FLOAT (arg = make_float (fabs (XFLOAT_DATA (arg))), "abs", arg); |
4b6baf5f | 680 | else if (XINT (arg) < 0) |
db37cb37 | 681 | XSETINT (arg, - XINT (arg)); |
b70021f4 | 682 | |
4b6baf5f | 683 | return arg; |
b70021f4 MR |
684 | } |
685 | ||
a7ca3326 | 686 | DEFUN ("float", Ffloat, Sfloat, 1, 1, 0, |
335c5470 | 687 | doc: /* Return the floating point number equal to ARG. */) |
5842a27b | 688 | (register Lisp_Object arg) |
b70021f4 | 689 | { |
b7826503 | 690 | CHECK_NUMBER_OR_FLOAT (arg); |
b70021f4 | 691 | |
207a45c1 | 692 | if (INTEGERP (arg)) |
4b6baf5f | 693 | return make_float ((double) XINT (arg)); |
b70021f4 | 694 | else /* give 'em the same float back */ |
4b6baf5f | 695 | return arg; |
b70021f4 MR |
696 | } |
697 | ||
698 | DEFUN ("logb", Flogb, Slogb, 1, 1, 0, | |
335c5470 PJ |
699 | doc: /* Returns largest integer <= the base 2 log of the magnitude of ARG. |
700 | This is the same as the exponent of a float. */) | |
5842a27b | 701 | (Lisp_Object arg) |
b70021f4 | 702 | { |
340176df | 703 | Lisp_Object val; |
a7bf3c54 | 704 | EMACS_INT value; |
5bf54166 | 705 | double f = extract_float (arg); |
340176df | 706 | |
6694b327 | 707 | if (f == 0.0) |
b916d672 | 708 | value = MOST_NEGATIVE_FIXNUM; |
6694b327 KH |
709 | else |
710 | { | |
6d3c6adb | 711 | #ifdef HAVE_LOGB |
6694b327 | 712 | IN_FLOAT (value = logb (f), "logb", arg); |
6d3c6adb JB |
713 | #else |
714 | #ifdef HAVE_FREXP | |
c8bf6cf3 KH |
715 | int ivalue; |
716 | IN_FLOAT (frexp (f, &ivalue), "logb", arg); | |
717 | value = ivalue - 1; | |
c26406fe | 718 | #else |
6694b327 KH |
719 | int i; |
720 | double d; | |
721 | if (f < 0.0) | |
722 | f = -f; | |
723 | value = -1; | |
724 | while (f < 0.5) | |
725 | { | |
726 | for (i = 1, d = 0.5; d * d >= f; i += i) | |
727 | d *= d; | |
728 | f /= d; | |
729 | value -= i; | |
730 | } | |
731 | while (f >= 1.0) | |
732 | { | |
733 | for (i = 1, d = 2.0; d * d <= f; i += i) | |
734 | d *= d; | |
735 | f /= d; | |
736 | value += i; | |
737 | } | |
6d3c6adb | 738 | #endif |
340176df | 739 | #endif |
6694b327 | 740 | } |
e0cb2a68 | 741 | XSETINT (val, value); |
c26406fe | 742 | return val; |
b70021f4 MR |
743 | } |
744 | ||
fc2157cb | 745 | |
acbbacbe PE |
746 | /* the rounding functions */ |
747 | ||
748 | static Lisp_Object | |
d2aa42f8 DN |
749 | rounding_driver (Lisp_Object arg, Lisp_Object divisor, |
750 | double (*double_round) (double), | |
751 | EMACS_INT (*int_round2) (EMACS_INT, EMACS_INT), | |
8ea90aa3 | 752 | const char *name) |
b70021f4 | 753 | { |
b7826503 | 754 | CHECK_NUMBER_OR_FLOAT (arg); |
b70021f4 | 755 | |
fc2157cb PE |
756 | if (! NILP (divisor)) |
757 | { | |
9a51b24a | 758 | EMACS_INT i1, i2; |
fc2157cb | 759 | |
b7826503 | 760 | CHECK_NUMBER_OR_FLOAT (divisor); |
fc2157cb | 761 | |
207a45c1 | 762 | if (FLOATP (arg) || FLOATP (divisor)) |
fc2157cb PE |
763 | { |
764 | double f1, f2; | |
765 | ||
70949dac KR |
766 | f1 = FLOATP (arg) ? XFLOAT_DATA (arg) : XINT (arg); |
767 | f2 = (FLOATP (divisor) ? XFLOAT_DATA (divisor) : XINT (divisor)); | |
d137ae2f | 768 | if (! IEEE_FLOATING_POINT && f2 == 0) |
edef1631 | 769 | xsignal0 (Qarith_error); |
fc2157cb | 770 | |
acbbacbe PE |
771 | IN_FLOAT2 (f1 = (*double_round) (f1 / f2), name, arg, divisor); |
772 | FLOAT_TO_INT2 (f1, arg, name, arg, divisor); | |
fc2157cb PE |
773 | return arg; |
774 | } | |
fc2157cb PE |
775 | |
776 | i1 = XINT (arg); | |
777 | i2 = XINT (divisor); | |
778 | ||
779 | if (i2 == 0) | |
edef1631 | 780 | xsignal0 (Qarith_error); |
fc2157cb | 781 | |
acbbacbe | 782 | XSETINT (arg, (*int_round2) (i1, i2)); |
fc2157cb PE |
783 | return arg; |
784 | } | |
785 | ||
207a45c1 | 786 | if (FLOATP (arg)) |
81a63ccc KH |
787 | { |
788 | double d; | |
acbbacbe | 789 | |
70949dac | 790 | IN_FLOAT (d = (*double_round) (XFLOAT_DATA (arg)), name, arg); |
acbbacbe | 791 | FLOAT_TO_INT (d, arg, name, arg); |
81a63ccc | 792 | } |
b70021f4 | 793 | |
4b6baf5f | 794 | return arg; |
b70021f4 MR |
795 | } |
796 | ||
acbbacbe PE |
797 | /* With C's /, the result is implementation-defined if either operand |
798 | is negative, so take care with negative operands in the following | |
799 | integer functions. */ | |
800 | ||
801 | static EMACS_INT | |
d2aa42f8 | 802 | ceiling2 (EMACS_INT i1, EMACS_INT i2) |
acbbacbe PE |
803 | { |
804 | return (i2 < 0 | |
805 | ? (i1 < 0 ? ((-1 - i1) / -i2) + 1 : - (i1 / -i2)) | |
806 | : (i1 <= 0 ? - (-i1 / i2) : ((i1 - 1) / i2) + 1)); | |
807 | } | |
808 | ||
809 | static EMACS_INT | |
d2aa42f8 | 810 | floor2 (EMACS_INT i1, EMACS_INT i2) |
acbbacbe PE |
811 | { |
812 | return (i2 < 0 | |
813 | ? (i1 <= 0 ? -i1 / -i2 : -1 - ((i1 - 1) / -i2)) | |
814 | : (i1 < 0 ? -1 - ((-1 - i1) / i2) : i1 / i2)); | |
815 | } | |
816 | ||
817 | static EMACS_INT | |
d2aa42f8 | 818 | truncate2 (EMACS_INT i1, EMACS_INT i2) |
acbbacbe PE |
819 | { |
820 | return (i2 < 0 | |
821 | ? (i1 < 0 ? -i1 / -i2 : - (i1 / -i2)) | |
822 | : (i1 < 0 ? - (-i1 / i2) : i1 / i2)); | |
823 | } | |
824 | ||
825 | static EMACS_INT | |
d2aa42f8 | 826 | round2 (EMACS_INT i1, EMACS_INT i2) |
acbbacbe PE |
827 | { |
828 | /* The C language's division operator gives us one remainder R, but | |
829 | we want the remainder R1 on the other side of 0 if R1 is closer | |
830 | to 0 than R is; because we want to round to even, we also want R1 | |
831 | if R and R1 are the same distance from 0 and if C's quotient is | |
832 | odd. */ | |
833 | EMACS_INT q = i1 / i2; | |
834 | EMACS_INT r = i1 % i2; | |
835 | EMACS_INT abs_r = r < 0 ? -r : r; | |
836 | EMACS_INT abs_r1 = (i2 < 0 ? -i2 : i2) - abs_r; | |
837 | return q + (abs_r + (q & 1) <= abs_r1 ? 0 : (i2 ^ r) < 0 ? -1 : 1); | |
838 | } | |
839 | ||
dca6c914 RS |
840 | /* The code uses emacs_rint, so that it works to undefine HAVE_RINT |
841 | if `rint' exists but does not work right. */ | |
842 | #ifdef HAVE_RINT | |
843 | #define emacs_rint rint | |
844 | #else | |
4b5878a8 | 845 | static double |
d2aa42f8 | 846 | emacs_rint (double d) |
4b5878a8 | 847 | { |
1b65c684 | 848 | return floor (d + 0.5); |
4b5878a8 KH |
849 | } |
850 | #endif | |
851 | ||
acbbacbe | 852 | static double |
d2aa42f8 | 853 | double_identity (double d) |
acbbacbe PE |
854 | { |
855 | return d; | |
856 | } | |
857 | ||
858 | DEFUN ("ceiling", Fceiling, Sceiling, 1, 2, 0, | |
1d6ea92f RS |
859 | doc: /* Return the smallest integer no less than ARG. |
860 | This rounds the value towards +inf. | |
335c5470 | 861 | With optional DIVISOR, return the smallest integer no less than ARG/DIVISOR. */) |
5842a27b | 862 | (Lisp_Object arg, Lisp_Object divisor) |
acbbacbe PE |
863 | { |
864 | return rounding_driver (arg, divisor, ceil, ceiling2, "ceiling"); | |
865 | } | |
866 | ||
867 | DEFUN ("floor", Ffloor, Sfloor, 1, 2, 0, | |
1d6ea92f | 868 | doc: /* Return the largest integer no greater than ARG. |
568b6e41 | 869 | This rounds the value towards -inf. |
335c5470 | 870 | With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR. */) |
5842a27b | 871 | (Lisp_Object arg, Lisp_Object divisor) |
acbbacbe PE |
872 | { |
873 | return rounding_driver (arg, divisor, floor, floor2, "floor"); | |
874 | } | |
875 | ||
876 | DEFUN ("round", Fround, Sround, 1, 2, 0, | |
335c5470 | 877 | doc: /* Return the nearest integer to ARG. |
6ded2c89 EZ |
878 | With optional DIVISOR, return the nearest integer to ARG/DIVISOR. |
879 | ||
a32a4857 EZ |
880 | Rounding a value equidistant between two integers may choose the |
881 | integer closer to zero, or it may prefer an even integer, depending on | |
882 | your machine. For example, \(round 2.5\) can return 3 on some | |
59fe0cee | 883 | systems, but 2 on others. */) |
5842a27b | 884 | (Lisp_Object arg, Lisp_Object divisor) |
acbbacbe | 885 | { |
dca6c914 | 886 | return rounding_driver (arg, divisor, emacs_rint, round2, "round"); |
acbbacbe PE |
887 | } |
888 | ||
a7ca3326 | 889 | DEFUN ("truncate", Ftruncate, Struncate, 1, 2, 0, |
335c5470 PJ |
890 | doc: /* Truncate a floating point number to an int. |
891 | Rounds ARG toward zero. | |
892 | With optional DIVISOR, truncate ARG/DIVISOR. */) | |
5842a27b | 893 | (Lisp_Object arg, Lisp_Object divisor) |
acbbacbe PE |
894 | { |
895 | return rounding_driver (arg, divisor, double_identity, truncate2, | |
896 | "truncate"); | |
897 | } | |
898 | ||
fc2157cb | 899 | |
d137ae2f | 900 | Lisp_Object |
dd4c5104 | 901 | fmod_float (Lisp_Object x, Lisp_Object y) |
d137ae2f PE |
902 | { |
903 | double f1, f2; | |
904 | ||
70949dac KR |
905 | f1 = FLOATP (x) ? XFLOAT_DATA (x) : XINT (x); |
906 | f2 = FLOATP (y) ? XFLOAT_DATA (y) : XINT (y); | |
d137ae2f PE |
907 | |
908 | if (! IEEE_FLOATING_POINT && f2 == 0) | |
edef1631 | 909 | xsignal0 (Qarith_error); |
d137ae2f PE |
910 | |
911 | /* If the "remainder" comes out with the wrong sign, fix it. */ | |
912 | IN_FLOAT2 ((f1 = fmod (f1, f2), | |
913 | f1 = (f2 < 0 ? f1 > 0 : f1 < 0) ? f1 + f2 : f1), | |
914 | "mod", x, y); | |
915 | return make_float (f1); | |
916 | } | |
4b6baf5f | 917 | \f |
4b6baf5f RS |
918 | /* It's not clear these are worth adding. */ |
919 | ||
920 | DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0, | |
335c5470 PJ |
921 | doc: /* Return the smallest integer no less than ARG, as a float. |
922 | \(Round toward +inf.\) */) | |
5842a27b | 923 | (register Lisp_Object arg) |
4b6baf5f RS |
924 | { |
925 | double d = extract_float (arg); | |
926 | IN_FLOAT (d = ceil (d), "fceiling", arg); | |
927 | return make_float (d); | |
928 | } | |
929 | ||
930 | DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0, | |
335c5470 PJ |
931 | doc: /* Return the largest integer no greater than ARG, as a float. |
932 | \(Round towards -inf.\) */) | |
5842a27b | 933 | (register Lisp_Object arg) |
4b6baf5f RS |
934 | { |
935 | double d = extract_float (arg); | |
936 | IN_FLOAT (d = floor (d), "ffloor", arg); | |
937 | return make_float (d); | |
938 | } | |
b70021f4 | 939 | |
4b6baf5f | 940 | DEFUN ("fround", Ffround, Sfround, 1, 1, 0, |
335c5470 | 941 | doc: /* Return the nearest integer to ARG, as a float. */) |
5842a27b | 942 | (register Lisp_Object arg) |
4b6baf5f RS |
943 | { |
944 | double d = extract_float (arg); | |
dca6c914 | 945 | IN_FLOAT (d = emacs_rint (d), "fround", arg); |
4b6baf5f RS |
946 | return make_float (d); |
947 | } | |
948 | ||
949 | DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0, | |
335c5470 PJ |
950 | doc: /* Truncate a floating point number to an integral float value. |
951 | Rounds the value toward zero. */) | |
5842a27b | 952 | (register Lisp_Object arg) |
4b6baf5f RS |
953 | { |
954 | double d = extract_float (arg); | |
955 | if (d >= 0.0) | |
956 | IN_FLOAT (d = floor (d), "ftruncate", arg); | |
957 | else | |
a3fc5236 | 958 | IN_FLOAT (d = ceil (d), "ftruncate", arg); |
4b6baf5f | 959 | return make_float (d); |
b70021f4 MR |
960 | } |
961 | \f | |
4b6baf5f | 962 | #ifdef FLOAT_CATCH_SIGILL |
9af30bdf | 963 | static void |
1dae0f0a | 964 | float_error (int signo) |
b70021f4 MR |
965 | { |
966 | if (! in_float) | |
967 | fatal_error_signal (signo); | |
968 | ||
6df54671 | 969 | #ifdef BSD_SYSTEM |
e065a56e | 970 | sigsetmask (SIGEMPTYMASK); |
265a9e55 JB |
971 | #else |
972 | /* Must reestablish handler each time it is called. */ | |
973 | signal (SIGILL, float_error); | |
6df54671 | 974 | #endif /* BSD_SYSTEM */ |
b70021f4 | 975 | |
333f1b6f | 976 | SIGNAL_THREAD_CHECK (signo); |
b70021f4 MR |
977 | in_float = 0; |
978 | ||
edef1631 | 979 | xsignal1 (Qarith_error, float_error_arg); |
b70021f4 MR |
980 | } |
981 | ||
4b6baf5f RS |
982 | /* Another idea was to replace the library function `infnan' |
983 | where SIGILL is signaled. */ | |
984 | ||
985 | #endif /* FLOAT_CATCH_SIGILL */ | |
986 | ||
987 | #ifdef HAVE_MATHERR | |
177c0ea7 | 988 | int |
d5a3eaaf | 989 | matherr (struct exception *x) |
4b6baf5f RS |
990 | { |
991 | Lisp_Object args; | |
42ca4633 J |
992 | const char *name = x->name; |
993 | ||
4b6baf5f RS |
994 | if (! in_float) |
995 | /* Not called from emacs-lisp float routines; do the default thing. */ | |
996 | return 0; | |
997 | if (!strcmp (x->name, "pow")) | |
42ca4633 | 998 | name = "expt"; |
4b6baf5f RS |
999 | |
1000 | args | |
42ca4633 | 1001 | = Fcons (build_string (name), |
4b6baf5f | 1002 | Fcons (make_float (x->arg1), |
42ca4633 | 1003 | ((!strcmp (name, "log") || !strcmp (name, "pow")) |
4b6baf5f RS |
1004 | ? Fcons (make_float (x->arg2), Qnil) |
1005 | : Qnil))); | |
1006 | switch (x->type) | |
1007 | { | |
edef1631 KS |
1008 | case DOMAIN: xsignal (Qdomain_error, args); break; |
1009 | case SING: xsignal (Qsingularity_error, args); break; | |
1010 | case OVERFLOW: xsignal (Qoverflow_error, args); break; | |
1011 | case UNDERFLOW: xsignal (Qunderflow_error, args); break; | |
1012 | default: xsignal (Qarith_error, args); break; | |
4b6baf5f RS |
1013 | } |
1014 | return (1); /* don't set errno or print a message */ | |
1015 | } | |
1016 | #endif /* HAVE_MATHERR */ | |
1017 | ||
dfcf069d | 1018 | void |
d5a3eaaf | 1019 | init_floatfns (void) |
b70021f4 | 1020 | { |
4b6baf5f | 1021 | #ifdef FLOAT_CATCH_SIGILL |
b70021f4 | 1022 | signal (SIGILL, float_error); |
177c0ea7 | 1023 | #endif |
b70021f4 MR |
1024 | in_float = 0; |
1025 | } | |
1026 | ||
dfcf069d | 1027 | void |
d5a3eaaf | 1028 | syms_of_floatfns (void) |
b70021f4 MR |
1029 | { |
1030 | defsubr (&Sacos); | |
b70021f4 | 1031 | defsubr (&Sasin); |
b70021f4 | 1032 | defsubr (&Satan); |
c2d4ea74 RS |
1033 | defsubr (&Scos); |
1034 | defsubr (&Ssin); | |
1035 | defsubr (&Stan); | |
15e12598 | 1036 | defsubr (&Sisnan); |
c8199d0f | 1037 | #ifdef HAVE_COPYSIGN |
15e12598 VB |
1038 | defsubr (&Scopysign); |
1039 | defsubr (&Sfrexp); | |
1040 | defsubr (&Sldexp); | |
1384fa33 | 1041 | #endif |
c2d4ea74 RS |
1042 | #if 0 |
1043 | defsubr (&Sacosh); | |
1044 | defsubr (&Sasinh); | |
b70021f4 | 1045 | defsubr (&Satanh); |
c2d4ea74 RS |
1046 | defsubr (&Scosh); |
1047 | defsubr (&Ssinh); | |
1048 | defsubr (&Stanh); | |
b70021f4 MR |
1049 | defsubr (&Sbessel_y0); |
1050 | defsubr (&Sbessel_y1); | |
1051 | defsubr (&Sbessel_yn); | |
1052 | defsubr (&Sbessel_j0); | |
1053 | defsubr (&Sbessel_j1); | |
1054 | defsubr (&Sbessel_jn); | |
b70021f4 MR |
1055 | defsubr (&Serf); |
1056 | defsubr (&Serfc); | |
c2d4ea74 | 1057 | defsubr (&Slog_gamma); |
4b6baf5f | 1058 | defsubr (&Scube_root); |
892ed7e0 | 1059 | #endif |
4b6baf5f RS |
1060 | defsubr (&Sfceiling); |
1061 | defsubr (&Sffloor); | |
1062 | defsubr (&Sfround); | |
1063 | defsubr (&Sftruncate); | |
b70021f4 | 1064 | defsubr (&Sexp); |
c2d4ea74 | 1065 | defsubr (&Sexpt); |
b70021f4 MR |
1066 | defsubr (&Slog); |
1067 | defsubr (&Slog10); | |
b70021f4 | 1068 | defsubr (&Ssqrt); |
b70021f4 MR |
1069 | |
1070 | defsubr (&Sabs); | |
1071 | defsubr (&Sfloat); | |
1072 | defsubr (&Slogb); | |
1073 | defsubr (&Sceiling); | |
acbbacbe | 1074 | defsubr (&Sfloor); |
b70021f4 MR |
1075 | defsubr (&Sround); |
1076 | defsubr (&Struncate); | |
1077 | } |