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