1 /* Primitive operations on floating point for GNU Emacs Lisp interpreter.
2 Copyright (C) 1988, 1993, 1994, 1999, 2003, 2005 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
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 2, or (at your option)
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.
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, Inc., 51 Franklin Street, Fifth Floor,
19 Boston, MA 02110-1301, USA. */
22 /* ANSI C requires only these float functions:
23 acos, asin, atan, atan2, ceil, cos, cosh, exp, fabs, floor, fmod,
24 frexp, ldexp, log, log10, modf, pow, sin, sinh, sqrt, tan, tanh.
26 Define HAVE_INVERSE_HYPERBOLIC if you have acosh, asinh, and atanh.
27 Define HAVE_CBRT if you have cbrt.
28 Define HAVE_RINT if you have a working rint.
29 If you don't define these, then the appropriate routines will be simulated.
31 Define HAVE_MATHERR if on a system supporting the SysV matherr callback.
32 (This should happen automatically.)
34 Define FLOAT_CHECK_ERRNO if the float library routines set errno.
35 This has no effect if HAVE_MATHERR is defined.
37 Define FLOAT_CATCH_SIGILL if the float library routines signal SIGILL.
38 (What systems actually do this? Please let us know.)
40 Define FLOAT_CHECK_DOMAIN if the float library doesn't handle errors by
41 either setting errno, or signaling SIGFPE/SIGILL. Otherwise, domain and
42 range checking will happen before calling the float routines. This has
43 no effect if HAVE_MATHERR is defined (since matherr will be called when
44 a domain error occurs.)
50 #include "syssignal.h"
56 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
57 #ifndef IEEE_FLOATING_POINT
58 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
59 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
60 #define IEEE_FLOATING_POINT 1
62 #define IEEE_FLOATING_POINT 0
66 /* Work around a problem that happens because math.h on hpux 7
67 defines two static variables--which, in Emacs, are not really static,
68 because `static' is defined as nothing. The problem is that they are
69 defined both here and in lread.c.
70 These macros prevent the name conflict. */
71 #if defined (HPUX) && !defined (HPUX8)
72 #define _MAXLDBL floatfns_maxldbl
73 #define _NMAXLDBL floatfns_nmaxldbl
78 /* This declaration is omitted on some systems, like Ultrix. */
79 #if !defined (HPUX) && defined (HAVE_LOGB) && !defined (logb)
80 extern double logb ();
81 #endif /* not HPUX and HAVE_LOGB and no logb macro */
83 #if defined(DOMAIN) && defined(SING) && defined(OVERFLOW)
84 /* If those are defined, then this is probably a `matherr' machine. */
95 # ifdef FLOAT_CHECK_ERRNO
96 # undef FLOAT_CHECK_ERRNO
98 # ifdef FLOAT_CHECK_DOMAIN
99 # undef FLOAT_CHECK_DOMAIN
103 #ifndef NO_FLOAT_CHECK_ERRNO
104 #define FLOAT_CHECK_ERRNO
107 #ifdef FLOAT_CHECK_ERRNO
115 /* Avoid traps on VMS from sinh and cosh.
116 All the other functions set errno instead. */
121 #define cosh(x) ((exp(x)+exp(-x))*0.5)
122 #define sinh(x) ((exp(x)-exp(-x))*0.5)
125 #ifdef FLOAT_CATCH_SIGILL
126 static SIGTYPE
float_error ();
129 /* Nonzero while executing in floating point.
130 This tells float_error what to do. */
134 /* If an argument is out of range for a mathematical function,
135 here is the actual argument value to use in the error message.
136 These variables are used only across the floating point library call
137 so there is no need to staticpro them. */
139 static Lisp_Object float_error_arg
, float_error_arg2
;
141 static char *float_error_fn_name
;
143 /* Evaluate the floating point expression D, recording NUM
144 as the original argument for error messages.
145 D is normally an assignment expression.
146 Handle errors which may result in signals or may set errno.
148 Note that float_error may be declared to return void, so you can't
149 just cast the zero after the colon to (SIGTYPE) to make the types
152 #ifdef FLOAT_CHECK_ERRNO
153 #define IN_FLOAT(d, name, num) \
155 float_error_arg = num; \
156 float_error_fn_name = name; \
157 in_float = 1; errno = 0; (d); in_float = 0; \
160 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
161 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
162 default: arith_error (float_error_fn_name, float_error_arg); \
165 #define IN_FLOAT2(d, name, num, num2) \
167 float_error_arg = num; \
168 float_error_arg2 = num2; \
169 float_error_fn_name = name; \
170 in_float = 1; errno = 0; (d); in_float = 0; \
173 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
174 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
175 default: arith_error (float_error_fn_name, float_error_arg); \
179 #define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0)
180 #define IN_FLOAT2(d, name, num, num2) (in_float = 1, (d), in_float = 0)
183 /* Convert float to Lisp_Int if it fits, else signal a range error
184 using the given arguments. */
185 #define FLOAT_TO_INT(x, i, name, num) \
188 if (FIXNUM_OVERFLOW_P (x)) \
189 range_error (name, num); \
190 XSETINT (i, (EMACS_INT)(x)); \
193 #define FLOAT_TO_INT2(x, i, name, num1, num2) \
196 if (FIXNUM_OVERFLOW_P (x)) \
197 range_error2 (name, num1, num2); \
198 XSETINT (i, (EMACS_INT)(x)); \
202 #define arith_error(op,arg) \
203 Fsignal (Qarith_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
204 #define range_error(op,arg) \
205 Fsignal (Qrange_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
206 #define range_error2(op,a1,a2) \
207 Fsignal (Qrange_error, Fcons (build_string ((op)), \
208 Fcons ((a1), Fcons ((a2), Qnil))))
209 #define domain_error(op,arg) \
210 Fsignal (Qdomain_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
211 #define domain_error2(op,a1,a2) \
212 Fsignal (Qdomain_error, Fcons (build_string ((op)), \
213 Fcons ((a1), Fcons ((a2), Qnil))))
215 /* Extract a Lisp number as a `double', or signal an error. */
221 CHECK_NUMBER_OR_FLOAT (num
);
224 return XFLOAT_DATA (num
);
225 return (double) XINT (num
);
228 /* Trig functions. */
230 DEFUN ("acos", Facos
, Sacos
, 1, 1, 0,
231 doc
: /* Return the inverse cosine of ARG. */)
233 register Lisp_Object arg
;
235 double d
= extract_float (arg
);
236 #ifdef FLOAT_CHECK_DOMAIN
237 if (d
> 1.0 || d
< -1.0)
238 domain_error ("acos", arg
);
240 IN_FLOAT (d
= acos (d
), "acos", arg
);
241 return make_float (d
);
244 DEFUN ("asin", Fasin
, Sasin
, 1, 1, 0,
245 doc
: /* Return the inverse sine of ARG. */)
247 register Lisp_Object arg
;
249 double d
= extract_float (arg
);
250 #ifdef FLOAT_CHECK_DOMAIN
251 if (d
> 1.0 || d
< -1.0)
252 domain_error ("asin", arg
);
254 IN_FLOAT (d
= asin (d
), "asin", arg
);
255 return make_float (d
);
258 DEFUN ("atan", Fatan
, Satan
, 1, 2, 0,
259 doc
: /* Return the inverse tangent of the arguments.
260 If only one argument Y is given, return the inverse tangent of Y.
261 If two arguments Y and X are given, return the inverse tangent of Y
262 divided by X, i.e. the angle in radians between the vector (X, Y)
265 register Lisp_Object y
, x
;
267 double d
= extract_float (y
);
270 IN_FLOAT (d
= atan (d
), "atan", y
);
273 double d2
= extract_float (x
);
275 IN_FLOAT2 (d
= atan2 (d
, d2
), "atan", y
, x
);
277 return make_float (d
);
280 DEFUN ("cos", Fcos
, Scos
, 1, 1, 0,
281 doc
: /* Return the cosine of ARG. */)
283 register Lisp_Object arg
;
285 double d
= extract_float (arg
);
286 IN_FLOAT (d
= cos (d
), "cos", arg
);
287 return make_float (d
);
290 DEFUN ("sin", Fsin
, Ssin
, 1, 1, 0,
291 doc
: /* Return the sine of ARG. */)
293 register Lisp_Object arg
;
295 double d
= extract_float (arg
);
296 IN_FLOAT (d
= sin (d
), "sin", arg
);
297 return make_float (d
);
300 DEFUN ("tan", Ftan
, Stan
, 1, 1, 0,
301 doc
: /* Return the tangent of ARG. */)
303 register Lisp_Object arg
;
305 double d
= extract_float (arg
);
307 #ifdef FLOAT_CHECK_DOMAIN
309 domain_error ("tan", arg
);
311 IN_FLOAT (d
= sin (d
) / c
, "tan", arg
);
312 return make_float (d
);
315 #if 0 /* Leave these out unless we find there's a reason for them. */
317 DEFUN ("bessel-j0", Fbessel_j0
, Sbessel_j0
, 1, 1, 0,
318 doc
: /* Return the bessel function j0 of ARG. */)
320 register Lisp_Object arg
;
322 double d
= extract_float (arg
);
323 IN_FLOAT (d
= j0 (d
), "bessel-j0", arg
);
324 return make_float (d
);
327 DEFUN ("bessel-j1", Fbessel_j1
, Sbessel_j1
, 1, 1, 0,
328 doc
: /* Return the bessel function j1 of ARG. */)
330 register Lisp_Object arg
;
332 double d
= extract_float (arg
);
333 IN_FLOAT (d
= j1 (d
), "bessel-j1", arg
);
334 return make_float (d
);
337 DEFUN ("bessel-jn", Fbessel_jn
, Sbessel_jn
, 2, 2, 0,
338 doc
: /* Return the order N bessel function output jn of ARG.
339 The first arg (the order) is truncated to an integer. */)
341 register Lisp_Object n
, arg
;
343 int i1
= extract_float (n
);
344 double f2
= extract_float (arg
);
346 IN_FLOAT (f2
= jn (i1
, f2
), "bessel-jn", n
);
347 return make_float (f2
);
350 DEFUN ("bessel-y0", Fbessel_y0
, Sbessel_y0
, 1, 1, 0,
351 doc
: /* Return the bessel function y0 of ARG. */)
353 register Lisp_Object arg
;
355 double d
= extract_float (arg
);
356 IN_FLOAT (d
= y0 (d
), "bessel-y0", arg
);
357 return make_float (d
);
360 DEFUN ("bessel-y1", Fbessel_y1
, Sbessel_y1
, 1, 1, 0,
361 doc
: /* Return the bessel function y1 of ARG. */)
363 register Lisp_Object arg
;
365 double d
= extract_float (arg
);
366 IN_FLOAT (d
= y1 (d
), "bessel-y0", arg
);
367 return make_float (d
);
370 DEFUN ("bessel-yn", Fbessel_yn
, Sbessel_yn
, 2, 2, 0,
371 doc
: /* Return the order N bessel function output yn of ARG.
372 The first arg (the order) is truncated to an integer. */)
374 register Lisp_Object n
, arg
;
376 int i1
= extract_float (n
);
377 double f2
= extract_float (arg
);
379 IN_FLOAT (f2
= yn (i1
, f2
), "bessel-yn", n
);
380 return make_float (f2
);
385 #if 0 /* Leave these out unless we see they are worth having. */
387 DEFUN ("erf", Ferf
, Serf
, 1, 1, 0,
388 doc
: /* Return the mathematical error function of ARG. */)
390 register Lisp_Object arg
;
392 double d
= extract_float (arg
);
393 IN_FLOAT (d
= erf (d
), "erf", arg
);
394 return make_float (d
);
397 DEFUN ("erfc", Ferfc
, Serfc
, 1, 1, 0,
398 doc
: /* Return the complementary error function of ARG. */)
400 register Lisp_Object arg
;
402 double d
= extract_float (arg
);
403 IN_FLOAT (d
= erfc (d
), "erfc", arg
);
404 return make_float (d
);
407 DEFUN ("log-gamma", Flog_gamma
, Slog_gamma
, 1, 1, 0,
408 doc
: /* Return the log gamma of ARG. */)
410 register Lisp_Object arg
;
412 double d
= extract_float (arg
);
413 IN_FLOAT (d
= lgamma (d
), "log-gamma", arg
);
414 return make_float (d
);
417 DEFUN ("cube-root", Fcube_root
, Scube_root
, 1, 1, 0,
418 doc
: /* Return the cube root of ARG. */)
420 register Lisp_Object arg
;
422 double d
= extract_float (arg
);
424 IN_FLOAT (d
= cbrt (d
), "cube-root", arg
);
427 IN_FLOAT (d
= pow (d
, 1.0/3.0), "cube-root", arg
);
429 IN_FLOAT (d
= -pow (-d
, 1.0/3.0), "cube-root", arg
);
431 return make_float (d
);
436 DEFUN ("exp", Fexp
, Sexp
, 1, 1, 0,
437 doc
: /* Return the exponential base e of ARG. */)
439 register Lisp_Object arg
;
441 double d
= extract_float (arg
);
442 #ifdef FLOAT_CHECK_DOMAIN
443 if (d
> 709.7827) /* Assume IEEE doubles here */
444 range_error ("exp", arg
);
446 return make_float (0.0);
449 IN_FLOAT (d
= exp (d
), "exp", arg
);
450 return make_float (d
);
453 DEFUN ("expt", Fexpt
, Sexpt
, 2, 2, 0,
454 doc
: /* Return the exponential ARG1 ** ARG2. */)
456 register Lisp_Object arg1
, arg2
;
460 CHECK_NUMBER_OR_FLOAT (arg1
);
461 CHECK_NUMBER_OR_FLOAT (arg2
);
462 if (INTEGERP (arg1
) /* common lisp spec */
463 && INTEGERP (arg2
) /* don't promote, if both are ints, and */
464 && 0 <= XINT (arg2
)) /* we are not computing the -ARG2 root */
465 { /* this can be improved by pre-calculating */
466 EMACS_INT acc
, x
, y
; /* some binary powers of x then accumulating */
478 acc
= (y
& 1) ? -1 : 1;
489 y
= (unsigned)y
>> 1;
495 f1
= FLOATP (arg1
) ? XFLOAT_DATA (arg1
) : XINT (arg1
);
496 f2
= FLOATP (arg2
) ? XFLOAT_DATA (arg2
) : XINT (arg2
);
497 /* Really should check for overflow, too */
498 if (f1
== 0.0 && f2
== 0.0)
500 #ifdef FLOAT_CHECK_DOMAIN
501 else if ((f1
== 0.0 && f2
< 0.0) || (f1
< 0 && f2
!= floor(f2
)))
502 domain_error2 ("expt", arg1
, arg2
);
504 IN_FLOAT2 (f1
= pow (f1
, f2
), "expt", arg1
, arg2
);
505 return make_float (f1
);
508 DEFUN ("log", Flog
, Slog
, 1, 2, 0,
509 doc
: /* Return the natural logarithm of ARG.
510 If second optional argument BASE is given, return log ARG using that base. */)
512 register Lisp_Object arg
, base
;
514 double d
= extract_float (arg
);
516 #ifdef FLOAT_CHECK_DOMAIN
518 domain_error2 ("log", arg
, base
);
521 IN_FLOAT (d
= log (d
), "log", arg
);
524 double b
= extract_float (base
);
526 #ifdef FLOAT_CHECK_DOMAIN
527 if (b
<= 0.0 || b
== 1.0)
528 domain_error2 ("log", arg
, base
);
531 IN_FLOAT2 (d
= log10 (d
), "log", arg
, base
);
533 IN_FLOAT2 (d
= log (d
) / log (b
), "log", arg
, base
);
535 return make_float (d
);
538 DEFUN ("log10", Flog10
, Slog10
, 1, 1, 0,
539 doc
: /* Return the logarithm base 10 of ARG. */)
541 register Lisp_Object arg
;
543 double d
= extract_float (arg
);
544 #ifdef FLOAT_CHECK_DOMAIN
546 domain_error ("log10", arg
);
548 IN_FLOAT (d
= log10 (d
), "log10", arg
);
549 return make_float (d
);
552 DEFUN ("sqrt", Fsqrt
, Ssqrt
, 1, 1, 0,
553 doc
: /* Return the square root of ARG. */)
555 register Lisp_Object arg
;
557 double d
= extract_float (arg
);
558 #ifdef FLOAT_CHECK_DOMAIN
560 domain_error ("sqrt", arg
);
562 IN_FLOAT (d
= sqrt (d
), "sqrt", arg
);
563 return make_float (d
);
566 #if 0 /* Not clearly worth adding. */
568 DEFUN ("acosh", Facosh
, Sacosh
, 1, 1, 0,
569 doc
: /* Return the inverse hyperbolic cosine of ARG. */)
571 register Lisp_Object arg
;
573 double d
= extract_float (arg
);
574 #ifdef FLOAT_CHECK_DOMAIN
576 domain_error ("acosh", arg
);
578 #ifdef HAVE_INVERSE_HYPERBOLIC
579 IN_FLOAT (d
= acosh (d
), "acosh", arg
);
581 IN_FLOAT (d
= log (d
+ sqrt (d
*d
- 1.0)), "acosh", arg
);
583 return make_float (d
);
586 DEFUN ("asinh", Fasinh
, Sasinh
, 1, 1, 0,
587 doc
: /* Return the inverse hyperbolic sine of ARG. */)
589 register Lisp_Object arg
;
591 double d
= extract_float (arg
);
592 #ifdef HAVE_INVERSE_HYPERBOLIC
593 IN_FLOAT (d
= asinh (d
), "asinh", arg
);
595 IN_FLOAT (d
= log (d
+ sqrt (d
*d
+ 1.0)), "asinh", arg
);
597 return make_float (d
);
600 DEFUN ("atanh", Fatanh
, Satanh
, 1, 1, 0,
601 doc
: /* Return the inverse hyperbolic tangent of ARG. */)
603 register Lisp_Object arg
;
605 double d
= extract_float (arg
);
606 #ifdef FLOAT_CHECK_DOMAIN
607 if (d
>= 1.0 || d
<= -1.0)
608 domain_error ("atanh", arg
);
610 #ifdef HAVE_INVERSE_HYPERBOLIC
611 IN_FLOAT (d
= atanh (d
), "atanh", arg
);
613 IN_FLOAT (d
= 0.5 * log ((1.0 + d
) / (1.0 - d
)), "atanh", arg
);
615 return make_float (d
);
618 DEFUN ("cosh", Fcosh
, Scosh
, 1, 1, 0,
619 doc
: /* Return the hyperbolic cosine of ARG. */)
621 register Lisp_Object arg
;
623 double d
= extract_float (arg
);
624 #ifdef FLOAT_CHECK_DOMAIN
625 if (d
> 710.0 || d
< -710.0)
626 range_error ("cosh", arg
);
628 IN_FLOAT (d
= cosh (d
), "cosh", arg
);
629 return make_float (d
);
632 DEFUN ("sinh", Fsinh
, Ssinh
, 1, 1, 0,
633 doc
: /* Return the hyperbolic sine of ARG. */)
635 register Lisp_Object arg
;
637 double d
= extract_float (arg
);
638 #ifdef FLOAT_CHECK_DOMAIN
639 if (d
> 710.0 || d
< -710.0)
640 range_error ("sinh", arg
);
642 IN_FLOAT (d
= sinh (d
), "sinh", arg
);
643 return make_float (d
);
646 DEFUN ("tanh", Ftanh
, Stanh
, 1, 1, 0,
647 doc
: /* Return the hyperbolic tangent of ARG. */)
649 register Lisp_Object arg
;
651 double d
= extract_float (arg
);
652 IN_FLOAT (d
= tanh (d
), "tanh", arg
);
653 return make_float (d
);
657 DEFUN ("abs", Fabs
, Sabs
, 1, 1, 0,
658 doc
: /* Return the absolute value of ARG. */)
660 register Lisp_Object arg
;
662 CHECK_NUMBER_OR_FLOAT (arg
);
665 IN_FLOAT (arg
= make_float (fabs (XFLOAT_DATA (arg
))), "abs", arg
);
666 else if (XINT (arg
) < 0)
667 XSETINT (arg
, - XINT (arg
));
672 DEFUN ("float", Ffloat
, Sfloat
, 1, 1, 0,
673 doc
: /* Return the floating point number equal to ARG. */)
675 register Lisp_Object arg
;
677 CHECK_NUMBER_OR_FLOAT (arg
);
680 return make_float ((double) XINT (arg
));
681 else /* give 'em the same float back */
685 DEFUN ("logb", Flogb
, Slogb
, 1, 1, 0,
686 doc
: /* Returns largest integer <= the base 2 log of the magnitude of ARG.
687 This is the same as the exponent of a float. */)
693 double f
= extract_float (arg
);
696 value
= MOST_NEGATIVE_FIXNUM
;
700 IN_FLOAT (value
= logb (f
), "logb", arg
);
704 IN_FLOAT (frexp (f
, &ivalue
), "logb", arg
);
714 for (i
= 1, d
= 0.5; d
* d
>= f
; i
+= i
)
721 for (i
= 1, d
= 2.0; d
* d
<= f
; i
+= i
)
729 XSETINT (val
, value
);
734 /* the rounding functions */
737 rounding_driver (arg
, divisor
, double_round
, int_round2
, name
)
738 register Lisp_Object arg
, divisor
;
739 double (*double_round
) ();
740 EMACS_INT (*int_round2
) ();
743 CHECK_NUMBER_OR_FLOAT (arg
);
745 if (! NILP (divisor
))
749 CHECK_NUMBER_OR_FLOAT (divisor
);
751 if (FLOATP (arg
) || FLOATP (divisor
))
755 f1
= FLOATP (arg
) ? XFLOAT_DATA (arg
) : XINT (arg
);
756 f2
= (FLOATP (divisor
) ? XFLOAT_DATA (divisor
) : XINT (divisor
));
757 if (! IEEE_FLOATING_POINT
&& f2
== 0)
758 Fsignal (Qarith_error
, Qnil
);
760 IN_FLOAT2 (f1
= (*double_round
) (f1
/ f2
), name
, arg
, divisor
);
761 FLOAT_TO_INT2 (f1
, arg
, name
, arg
, divisor
);
769 Fsignal (Qarith_error
, Qnil
);
771 XSETINT (arg
, (*int_round2
) (i1
, i2
));
779 IN_FLOAT (d
= (*double_round
) (XFLOAT_DATA (arg
)), name
, arg
);
780 FLOAT_TO_INT (d
, arg
, name
, arg
);
786 /* With C's /, the result is implementation-defined if either operand
787 is negative, so take care with negative operands in the following
788 integer functions. */
795 ? (i1
< 0 ? ((-1 - i1
) / -i2
) + 1 : - (i1
/ -i2
))
796 : (i1
<= 0 ? - (-i1
/ i2
) : ((i1
- 1) / i2
) + 1));
804 ? (i1
<= 0 ? -i1
/ -i2
: -1 - ((i1
- 1) / -i2
))
805 : (i1
< 0 ? -1 - ((-1 - i1
) / i2
) : i1
/ i2
));
813 ? (i1
< 0 ? -i1
/ -i2
: - (i1
/ -i2
))
814 : (i1
< 0 ? - (-i1
/ i2
) : i1
/ i2
));
821 /* The C language's division operator gives us one remainder R, but
822 we want the remainder R1 on the other side of 0 if R1 is closer
823 to 0 than R is; because we want to round to even, we also want R1
824 if R and R1 are the same distance from 0 and if C's quotient is
826 EMACS_INT q
= i1
/ i2
;
827 EMACS_INT r
= i1
% i2
;
828 EMACS_INT abs_r
= r
< 0 ? -r
: r
;
829 EMACS_INT abs_r1
= (i2
< 0 ? -i2
: i2
) - abs_r
;
830 return q
+ (abs_r
+ (q
& 1) <= abs_r1
? 0 : (i2
^ r
) < 0 ? -1 : 1);
833 /* The code uses emacs_rint, so that it works to undefine HAVE_RINT
834 if `rint' exists but does not work right. */
836 #define emacs_rint rint
842 return floor (d
+ 0.5);
853 DEFUN ("ceiling", Fceiling
, Sceiling
, 1, 2, 0,
854 doc
: /* Return the smallest integer no less than ARG.
855 This rounds the value towards +inf.
856 With optional DIVISOR, return the smallest integer no less than ARG/DIVISOR. */)
858 Lisp_Object arg
, divisor
;
860 return rounding_driver (arg
, divisor
, ceil
, ceiling2
, "ceiling");
863 DEFUN ("floor", Ffloor
, Sfloor
, 1, 2, 0,
864 doc
: /* Return the largest integer no greater than ARG.
865 This rounds the value towards -inf.
866 With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR. */)
868 Lisp_Object arg
, divisor
;
870 return rounding_driver (arg
, divisor
, floor
, floor2
, "floor");
873 DEFUN ("round", Fround
, Sround
, 1, 2, 0,
874 doc
: /* Return the nearest integer to ARG.
875 With optional DIVISOR, return the nearest integer to ARG/DIVISOR.
877 Rounding a value equidistant between two integers may choose the
878 integer closer to zero, or it may prefer an even integer, depending on
879 your machine. For example, \(round 2.5\) can return 3 on some
880 systems, but 2 on others. */)
882 Lisp_Object arg
, divisor
;
884 return rounding_driver (arg
, divisor
, emacs_rint
, round2
, "round");
887 DEFUN ("truncate", Ftruncate
, Struncate
, 1, 2, 0,
888 doc
: /* Truncate a floating point number to an int.
889 Rounds ARG toward zero.
890 With optional DIVISOR, truncate ARG/DIVISOR. */)
892 Lisp_Object arg
, divisor
;
894 return rounding_driver (arg
, divisor
, double_identity
, truncate2
,
901 register Lisp_Object x
, y
;
905 f1
= FLOATP (x
) ? XFLOAT_DATA (x
) : XINT (x
);
906 f2
= FLOATP (y
) ? XFLOAT_DATA (y
) : XINT (y
);
908 if (! IEEE_FLOATING_POINT
&& f2
== 0)
909 Fsignal (Qarith_error
, Qnil
);
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
),
915 return make_float (f1
);
918 /* It's not clear these are worth adding. */
920 DEFUN ("fceiling", Ffceiling
, Sfceiling
, 1, 1, 0,
921 doc
: /* Return the smallest integer no less than ARG, as a float.
922 \(Round toward +inf.\) */)
924 register Lisp_Object arg
;
926 double d
= extract_float (arg
);
927 IN_FLOAT (d
= ceil (d
), "fceiling", arg
);
928 return make_float (d
);
931 DEFUN ("ffloor", Fffloor
, Sffloor
, 1, 1, 0,
932 doc
: /* Return the largest integer no greater than ARG, as a float.
933 \(Round towards -inf.\) */)
935 register Lisp_Object arg
;
937 double d
= extract_float (arg
);
938 IN_FLOAT (d
= floor (d
), "ffloor", arg
);
939 return make_float (d
);
942 DEFUN ("fround", Ffround
, Sfround
, 1, 1, 0,
943 doc
: /* Return the nearest integer to ARG, as a float. */)
945 register Lisp_Object arg
;
947 double d
= extract_float (arg
);
948 IN_FLOAT (d
= emacs_rint (d
), "fround", arg
);
949 return make_float (d
);
952 DEFUN ("ftruncate", Fftruncate
, Sftruncate
, 1, 1, 0,
953 doc
: /* Truncate a floating point number to an integral float value.
954 Rounds the value toward zero. */)
956 register Lisp_Object arg
;
958 double d
= extract_float (arg
);
960 IN_FLOAT (d
= floor (d
), "ftruncate", arg
);
962 IN_FLOAT (d
= ceil (d
), "ftruncate", arg
);
963 return make_float (d
);
966 #ifdef FLOAT_CATCH_SIGILL
972 fatal_error_signal (signo
);
977 #else /* not BSD4_1 */
978 sigsetmask (SIGEMPTYMASK
);
979 #endif /* not BSD4_1 */
981 /* Must reestablish handler each time it is called. */
982 signal (SIGILL
, float_error
);
983 #endif /* BSD_SYSTEM */
985 SIGNAL_THREAD_CHECK (signo
);
988 Fsignal (Qarith_error
, Fcons (float_error_arg
, Qnil
));
991 /* Another idea was to replace the library function `infnan'
992 where SIGILL is signaled. */
994 #endif /* FLOAT_CATCH_SIGILL */
1003 /* Not called from emacs-lisp float routines; do the default thing. */
1005 if (!strcmp (x
->name
, "pow"))
1009 = Fcons (build_string (x
->name
),
1010 Fcons (make_float (x
->arg1
),
1011 ((!strcmp (x
->name
, "log") || !strcmp (x
->name
, "pow"))
1012 ? Fcons (make_float (x
->arg2
), Qnil
)
1016 case DOMAIN
: Fsignal (Qdomain_error
, args
); break;
1017 case SING
: Fsignal (Qsingularity_error
, args
); break;
1018 case OVERFLOW
: Fsignal (Qoverflow_error
, args
); break;
1019 case UNDERFLOW
: Fsignal (Qunderflow_error
, args
); break;
1020 default: Fsignal (Qarith_error
, args
); break;
1022 return (1); /* don't set errno or print a message */
1024 #endif /* HAVE_MATHERR */
1029 #ifdef FLOAT_CATCH_SIGILL
1030 signal (SIGILL
, float_error
);
1051 defsubr (&Sbessel_y0
);
1052 defsubr (&Sbessel_y1
);
1053 defsubr (&Sbessel_yn
);
1054 defsubr (&Sbessel_j0
);
1055 defsubr (&Sbessel_j1
);
1056 defsubr (&Sbessel_jn
);
1059 defsubr (&Slog_gamma
);
1060 defsubr (&Scube_root
);
1062 defsubr (&Sfceiling
);
1065 defsubr (&Sftruncate
);
1075 defsubr (&Sceiling
);
1078 defsubr (&Struncate
);
1081 /* arch-tag: be05bf9d-049e-4e31-91b9-e6153d483ae7
1082 (do not change this comment) */