1 /* Primitive operations on floating point for GNU Emacs Lisp interpreter.
3 Copyright (C) 1988, 1993-1994, 1999, 2001-2011
4 Free Software Foundation, Inc.
6 Author: Wolfgang Rupprecht
7 (according to ack.texi)
9 This file is part of GNU Emacs.
11 GNU Emacs is free software: you can redistribute it and/or modify
12 it under the terms of the GNU General Public License as published by
13 the Free Software Foundation, either version 3 of the License, or
14 (at your option) any later version.
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.
21 You should have received a copy of the GNU General Public License
22 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
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.
29 Define HAVE_INVERSE_HYPERBOLIC if you have acosh, asinh, and atanh.
30 Define HAVE_CBRT if you have cbrt.
31 Define HAVE_RINT if you have a working rint.
32 If you don't define these, then the appropriate routines will be simulated.
34 Define HAVE_MATHERR if on a system supporting the SysV matherr callback.
35 (This should happen automatically.)
37 Define FLOAT_CHECK_ERRNO if the float library routines set errno.
38 This has no effect if HAVE_MATHERR is defined.
40 Define FLOAT_CATCH_SIGILL if the float library routines signal SIGILL.
41 (What systems actually do this? Please let us know.)
43 Define FLOAT_CHECK_DOMAIN if the float library doesn't handle errors by
44 either setting errno, or signaling SIGFPE/SIGILL. Otherwise, domain and
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.)
54 #include "syssignal.h"
60 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
61 #ifndef IEEE_FLOATING_POINT
62 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
63 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
64 #define IEEE_FLOATING_POINT 1
66 #define IEEE_FLOATING_POINT 0
72 /* This declaration is omitted on some systems, like Ultrix. */
73 #if !defined (HPUX) && defined (HAVE_LOGB) && !defined (logb)
74 extern double logb (double);
75 #endif /* not HPUX and HAVE_LOGB and no logb macro */
77 #if defined(DOMAIN) && defined(SING) && defined(OVERFLOW)
78 /* If those are defined, then this is probably a `matherr' machine. */
89 # ifdef FLOAT_CHECK_ERRNO
90 # undef FLOAT_CHECK_ERRNO
92 # ifdef FLOAT_CHECK_DOMAIN
93 # undef FLOAT_CHECK_DOMAIN
97 #ifndef NO_FLOAT_CHECK_ERRNO
98 #define FLOAT_CHECK_ERRNO
101 #ifdef FLOAT_CHECK_ERRNO
105 #ifdef FLOAT_CATCH_SIGILL
106 static void float_error ();
109 /* Nonzero while executing in floating point.
110 This tells float_error what to do. */
114 /* If an argument is out of range for a mathematical function,
115 here is the actual argument value to use in the error message.
116 These variables are used only across the floating point library call
117 so there is no need to staticpro them. */
119 static Lisp_Object float_error_arg
, float_error_arg2
;
121 static const char *float_error_fn_name
;
123 /* Evaluate the floating point expression D, recording NUM
124 as the original argument for error messages.
125 D is normally an assignment expression.
126 Handle errors which may result in signals or may set errno.
128 Note that float_error may be declared to return void, so you can't
129 just cast the zero after the colon to (void) to make the types
132 #ifdef FLOAT_CHECK_ERRNO
133 #define IN_FLOAT(d, name, num) \
135 float_error_arg = num; \
136 float_error_fn_name = name; \
137 in_float = 1; errno = 0; (d); in_float = 0; \
140 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
141 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
142 default: arith_error (float_error_fn_name, float_error_arg); \
145 #define IN_FLOAT2(d, name, num, num2) \
147 float_error_arg = num; \
148 float_error_arg2 = num2; \
149 float_error_fn_name = name; \
150 in_float = 1; errno = 0; (d); in_float = 0; \
153 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
154 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
155 default: arith_error (float_error_fn_name, float_error_arg); \
159 #define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0)
160 #define IN_FLOAT2(d, name, num, num2) (in_float = 1, (d), in_float = 0)
163 /* Convert float to Lisp_Int if it fits, else signal a range error
164 using the given arguments. */
165 #define FLOAT_TO_INT(x, i, name, num) \
168 if (FIXNUM_OVERFLOW_P (x)) \
169 range_error (name, num); \
170 XSETINT (i, (EMACS_INT)(x)); \
173 #define FLOAT_TO_INT2(x, i, name, num1, num2) \
176 if (FIXNUM_OVERFLOW_P (x)) \
177 range_error2 (name, num1, num2); \
178 XSETINT (i, (EMACS_INT)(x)); \
182 #define arith_error(op,arg) \
183 xsignal2 (Qarith_error, build_string ((op)), (arg))
184 #define range_error(op,arg) \
185 xsignal2 (Qrange_error, build_string ((op)), (arg))
186 #define range_error2(op,a1,a2) \
187 xsignal3 (Qrange_error, build_string ((op)), (a1), (a2))
188 #define domain_error(op,arg) \
189 xsignal2 (Qdomain_error, build_string ((op)), (arg))
190 #ifdef FLOAT_CHECK_DOMAIN
191 #define domain_error2(op,a1,a2) \
192 xsignal3 (Qdomain_error, build_string ((op)), (a1), (a2))
195 /* Extract a Lisp number as a `double', or signal an error. */
198 extract_float (Lisp_Object num
)
200 CHECK_NUMBER_OR_FLOAT (num
);
203 return XFLOAT_DATA (num
);
204 return (double) XINT (num
);
207 /* Trig functions. */
209 DEFUN ("acos", Facos
, Sacos
, 1, 1, 0,
210 doc
: /* Return the inverse cosine of ARG. */)
211 (register Lisp_Object arg
)
213 double d
= extract_float (arg
);
214 #ifdef FLOAT_CHECK_DOMAIN
215 if (d
> 1.0 || d
< -1.0)
216 domain_error ("acos", arg
);
218 IN_FLOAT (d
= acos (d
), "acos", arg
);
219 return make_float (d
);
222 DEFUN ("asin", Fasin
, Sasin
, 1, 1, 0,
223 doc
: /* Return the inverse sine of ARG. */)
224 (register Lisp_Object arg
)
226 double d
= extract_float (arg
);
227 #ifdef FLOAT_CHECK_DOMAIN
228 if (d
> 1.0 || d
< -1.0)
229 domain_error ("asin", arg
);
231 IN_FLOAT (d
= asin (d
), "asin", arg
);
232 return make_float (d
);
235 DEFUN ("atan", Fatan
, Satan
, 1, 2, 0,
236 doc
: /* Return the inverse tangent of the arguments.
237 If only one argument Y is given, return the inverse tangent of Y.
238 If two arguments Y and X are given, return the inverse tangent of Y
239 divided by X, i.e. the angle in radians between the vector (X, Y)
241 (register Lisp_Object y
, Lisp_Object x
)
243 double d
= extract_float (y
);
246 IN_FLOAT (d
= atan (d
), "atan", y
);
249 double d2
= extract_float (x
);
251 IN_FLOAT2 (d
= atan2 (d
, d2
), "atan", y
, x
);
253 return make_float (d
);
256 DEFUN ("cos", Fcos
, Scos
, 1, 1, 0,
257 doc
: /* Return the cosine of ARG. */)
258 (register Lisp_Object arg
)
260 double d
= extract_float (arg
);
261 IN_FLOAT (d
= cos (d
), "cos", arg
);
262 return make_float (d
);
265 DEFUN ("sin", Fsin
, Ssin
, 1, 1, 0,
266 doc
: /* Return the sine of ARG. */)
267 (register Lisp_Object arg
)
269 double d
= extract_float (arg
);
270 IN_FLOAT (d
= sin (d
), "sin", arg
);
271 return make_float (d
);
274 DEFUN ("tan", Ftan
, Stan
, 1, 1, 0,
275 doc
: /* Return the tangent of ARG. */)
276 (register Lisp_Object arg
)
278 double d
= extract_float (arg
);
280 #ifdef FLOAT_CHECK_DOMAIN
282 domain_error ("tan", arg
);
284 IN_FLOAT (d
= sin (d
) / c
, "tan", arg
);
285 return make_float (d
);
288 #if defined HAVE_ISNAN && defined HAVE_COPYSIGN
289 DEFUN ("isnan", Fisnan
, Sisnan
, 1, 1, 0,
290 doc
: /* Return non nil iff argument X is a NaN. */)
294 return isnan (XFLOAT_DATA (x
)) ? Qt
: Qnil
;
297 DEFUN ("copysign", Fcopysign
, Scopysign
, 1, 2, 0,
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. */)
300 (Lisp_Object x1
, Lisp_Object x2
)
307 f1
= XFLOAT_DATA (x1
);
308 f2
= XFLOAT_DATA (x2
);
310 return make_float (copysign (f1
, f2
));
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:
321 The function returns the cons cell (SGNFCAND . EXP).
322 If X is zero, both parts (SGNFCAND and EXP) are zero. */)
325 double f
= XFLOATINT (x
);
328 return Fcons (make_float (0.0), make_number (0));
332 double sgnfcand
= frexp (f
, &exponent
);
333 return Fcons (make_float (sgnfcand
), make_number (exponent
));
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). */)
341 (Lisp_Object sgnfcand
, Lisp_Object exponent
)
343 CHECK_NUMBER (exponent
);
344 return make_float (ldexp (XFLOATINT (sgnfcand
), XINT (exponent
)));
348 #if 0 /* Leave these out unless we find there's a reason for them. */
350 DEFUN ("bessel-j0", Fbessel_j0
, Sbessel_j0
, 1, 1, 0,
351 doc
: /* Return the bessel function j0 of ARG. */)
352 (register Lisp_Object arg
)
354 double d
= extract_float (arg
);
355 IN_FLOAT (d
= j0 (d
), "bessel-j0", arg
);
356 return make_float (d
);
359 DEFUN ("bessel-j1", Fbessel_j1
, Sbessel_j1
, 1, 1, 0,
360 doc
: /* Return the bessel function j1 of ARG. */)
361 (register Lisp_Object arg
)
363 double d
= extract_float (arg
);
364 IN_FLOAT (d
= j1 (d
), "bessel-j1", arg
);
365 return make_float (d
);
368 DEFUN ("bessel-jn", Fbessel_jn
, Sbessel_jn
, 2, 2, 0,
369 doc
: /* Return the order N bessel function output jn of ARG.
370 The first arg (the order) is truncated to an integer. */)
371 (register Lisp_Object n
, Lisp_Object arg
)
373 int i1
= extract_float (n
);
374 double f2
= extract_float (arg
);
376 IN_FLOAT (f2
= jn (i1
, f2
), "bessel-jn", n
);
377 return make_float (f2
);
380 DEFUN ("bessel-y0", Fbessel_y0
, Sbessel_y0
, 1, 1, 0,
381 doc
: /* Return the bessel function y0 of ARG. */)
382 (register Lisp_Object arg
)
384 double d
= extract_float (arg
);
385 IN_FLOAT (d
= y0 (d
), "bessel-y0", arg
);
386 return make_float (d
);
389 DEFUN ("bessel-y1", Fbessel_y1
, Sbessel_y1
, 1, 1, 0,
390 doc
: /* Return the bessel function y1 of ARG. */)
391 (register Lisp_Object arg
)
393 double d
= extract_float (arg
);
394 IN_FLOAT (d
= y1 (d
), "bessel-y0", arg
);
395 return make_float (d
);
398 DEFUN ("bessel-yn", Fbessel_yn
, Sbessel_yn
, 2, 2, 0,
399 doc
: /* Return the order N bessel function output yn of ARG.
400 The first arg (the order) is truncated to an integer. */)
401 (register Lisp_Object n
, Lisp_Object arg
)
403 int i1
= extract_float (n
);
404 double f2
= extract_float (arg
);
406 IN_FLOAT (f2
= yn (i1
, f2
), "bessel-yn", n
);
407 return make_float (f2
);
412 #if 0 /* Leave these out unless we see they are worth having. */
414 DEFUN ("erf", Ferf
, Serf
, 1, 1, 0,
415 doc
: /* Return the mathematical error function of ARG. */)
416 (register Lisp_Object arg
)
418 double d
= extract_float (arg
);
419 IN_FLOAT (d
= erf (d
), "erf", arg
);
420 return make_float (d
);
423 DEFUN ("erfc", Ferfc
, Serfc
, 1, 1, 0,
424 doc
: /* Return the complementary error function of ARG. */)
425 (register Lisp_Object arg
)
427 double d
= extract_float (arg
);
428 IN_FLOAT (d
= erfc (d
), "erfc", arg
);
429 return make_float (d
);
432 DEFUN ("log-gamma", Flog_gamma
, Slog_gamma
, 1, 1, 0,
433 doc
: /* Return the log gamma of ARG. */)
434 (register Lisp_Object arg
)
436 double d
= extract_float (arg
);
437 IN_FLOAT (d
= lgamma (d
), "log-gamma", arg
);
438 return make_float (d
);
441 DEFUN ("cube-root", Fcube_root
, Scube_root
, 1, 1, 0,
442 doc
: /* Return the cube root of ARG. */)
443 (register Lisp_Object arg
)
445 double d
= extract_float (arg
);
447 IN_FLOAT (d
= cbrt (d
), "cube-root", arg
);
450 IN_FLOAT (d
= pow (d
, 1.0/3.0), "cube-root", arg
);
452 IN_FLOAT (d
= -pow (-d
, 1.0/3.0), "cube-root", arg
);
454 return make_float (d
);
459 DEFUN ("exp", Fexp
, Sexp
, 1, 1, 0,
460 doc
: /* Return the exponential base e of ARG. */)
461 (register Lisp_Object arg
)
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
);
468 return make_float (0.0);
471 IN_FLOAT (d
= exp (d
), "exp", arg
);
472 return make_float (d
);
475 DEFUN ("expt", Fexpt
, Sexpt
, 2, 2, 0,
476 doc
: /* Return the exponential ARG1 ** ARG2. */)
477 (register Lisp_Object arg1
, Lisp_Object arg2
)
481 CHECK_NUMBER_OR_FLOAT (arg1
);
482 CHECK_NUMBER_OR_FLOAT (arg2
);
483 if (INTEGERP (arg1
) /* common lisp spec */
484 && INTEGERP (arg2
) /* don't promote, if both are ints, and */
485 && 0 <= XINT (arg2
)) /* we are sure the result is not fractional */
486 { /* this can be improved by pre-calculating */
487 EMACS_INT acc
, x
, y
; /* some binary powers of x then accumulating */
494 if ((x
== 0 && y
!= 0) || x
== 1 || (x
== -1 && (y
& 1)))
505 ? acc
< MOST_POSITIVE_FIXNUM
/ x
506 : MOST_NEGATIVE_FIXNUM
/ x
< acc
)
508 ? acc
< MOST_NEGATIVE_FIXNUM
/ x
509 : MOST_POSITIVE_FIXNUM
/ x
< acc
))
522 ? x
< MOST_POSITIVE_FIXNUM
/ x
523 : MOST_POSITIVE_FIXNUM
/ x
< x
)
528 f1
= FLOATP (arg1
) ? XFLOAT_DATA (arg1
) : XINT (arg1
);
529 f2
= FLOATP (arg2
) ? XFLOAT_DATA (arg2
) : XINT (arg2
);
530 /* Really should check for overflow, too */
531 if (f1
== 0.0 && f2
== 0.0)
533 #ifdef FLOAT_CHECK_DOMAIN
534 else if ((f1
== 0.0 && f2
< 0.0) || (f1
< 0 && f2
!= floor(f2
)))
535 domain_error2 ("expt", arg1
, arg2
);
537 IN_FLOAT2 (f3
= pow (f1
, f2
), "expt", arg1
, arg2
);
538 /* Check for overflow in the result. */
539 if (f1
!= 0.0 && f3
== 0.0)
540 range_error ("expt", arg1
);
541 return make_float (f3
);
544 DEFUN ("log", Flog
, Slog
, 1, 2, 0,
545 doc
: /* Return the natural logarithm of ARG.
546 If the optional argument BASE is given, return log ARG using that base. */)
547 (register Lisp_Object arg
, Lisp_Object base
)
549 double d
= extract_float (arg
);
551 #ifdef FLOAT_CHECK_DOMAIN
553 domain_error2 ("log", arg
, base
);
556 IN_FLOAT (d
= log (d
), "log", arg
);
559 double b
= extract_float (base
);
561 #ifdef FLOAT_CHECK_DOMAIN
562 if (b
<= 0.0 || b
== 1.0)
563 domain_error2 ("log", arg
, base
);
566 IN_FLOAT2 (d
= log10 (d
), "log", arg
, base
);
568 IN_FLOAT2 (d
= log (d
) / log (b
), "log", arg
, base
);
570 return make_float (d
);
573 DEFUN ("log10", Flog10
, Slog10
, 1, 1, 0,
574 doc
: /* Return the logarithm base 10 of ARG. */)
575 (register Lisp_Object arg
)
577 double d
= extract_float (arg
);
578 #ifdef FLOAT_CHECK_DOMAIN
580 domain_error ("log10", arg
);
582 IN_FLOAT (d
= log10 (d
), "log10", arg
);
583 return make_float (d
);
586 DEFUN ("sqrt", Fsqrt
, Ssqrt
, 1, 1, 0,
587 doc
: /* Return the square root of ARG. */)
588 (register Lisp_Object arg
)
590 double d
= extract_float (arg
);
591 #ifdef FLOAT_CHECK_DOMAIN
593 domain_error ("sqrt", arg
);
595 IN_FLOAT (d
= sqrt (d
), "sqrt", arg
);
596 return make_float (d
);
599 #if 0 /* Not clearly worth adding. */
601 DEFUN ("acosh", Facosh
, Sacosh
, 1, 1, 0,
602 doc
: /* Return the inverse hyperbolic cosine of ARG. */)
603 (register Lisp_Object arg
)
605 double d
= extract_float (arg
);
606 #ifdef FLOAT_CHECK_DOMAIN
608 domain_error ("acosh", arg
);
610 #ifdef HAVE_INVERSE_HYPERBOLIC
611 IN_FLOAT (d
= acosh (d
), "acosh", arg
);
613 IN_FLOAT (d
= log (d
+ sqrt (d
*d
- 1.0)), "acosh", arg
);
615 return make_float (d
);
618 DEFUN ("asinh", Fasinh
, Sasinh
, 1, 1, 0,
619 doc
: /* Return the inverse hyperbolic sine of ARG. */)
620 (register Lisp_Object arg
)
622 double d
= extract_float (arg
);
623 #ifdef HAVE_INVERSE_HYPERBOLIC
624 IN_FLOAT (d
= asinh (d
), "asinh", arg
);
626 IN_FLOAT (d
= log (d
+ sqrt (d
*d
+ 1.0)), "asinh", arg
);
628 return make_float (d
);
631 DEFUN ("atanh", Fatanh
, Satanh
, 1, 1, 0,
632 doc
: /* Return the inverse hyperbolic tangent of ARG. */)
633 (register Lisp_Object arg
)
635 double d
= extract_float (arg
);
636 #ifdef FLOAT_CHECK_DOMAIN
637 if (d
>= 1.0 || d
<= -1.0)
638 domain_error ("atanh", arg
);
640 #ifdef HAVE_INVERSE_HYPERBOLIC
641 IN_FLOAT (d
= atanh (d
), "atanh", arg
);
643 IN_FLOAT (d
= 0.5 * log ((1.0 + d
) / (1.0 - d
)), "atanh", arg
);
645 return make_float (d
);
648 DEFUN ("cosh", Fcosh
, Scosh
, 1, 1, 0,
649 doc
: /* Return the hyperbolic cosine of ARG. */)
650 (register Lisp_Object arg
)
652 double d
= extract_float (arg
);
653 #ifdef FLOAT_CHECK_DOMAIN
654 if (d
> 710.0 || d
< -710.0)
655 range_error ("cosh", arg
);
657 IN_FLOAT (d
= cosh (d
), "cosh", arg
);
658 return make_float (d
);
661 DEFUN ("sinh", Fsinh
, Ssinh
, 1, 1, 0,
662 doc
: /* Return the hyperbolic sine of ARG. */)
663 (register Lisp_Object arg
)
665 double d
= extract_float (arg
);
666 #ifdef FLOAT_CHECK_DOMAIN
667 if (d
> 710.0 || d
< -710.0)
668 range_error ("sinh", arg
);
670 IN_FLOAT (d
= sinh (d
), "sinh", arg
);
671 return make_float (d
);
674 DEFUN ("tanh", Ftanh
, Stanh
, 1, 1, 0,
675 doc
: /* Return the hyperbolic tangent of ARG. */)
676 (register Lisp_Object arg
)
678 double d
= extract_float (arg
);
679 IN_FLOAT (d
= tanh (d
), "tanh", arg
);
680 return make_float (d
);
684 DEFUN ("abs", Fabs
, Sabs
, 1, 1, 0,
685 doc
: /* Return the absolute value of ARG. */)
686 (register Lisp_Object arg
)
688 CHECK_NUMBER_OR_FLOAT (arg
);
691 IN_FLOAT (arg
= make_float (fabs (XFLOAT_DATA (arg
))), "abs", arg
);
692 else if (XINT (arg
) < 0)
693 XSETINT (arg
, - XINT (arg
));
698 DEFUN ("float", Ffloat
, Sfloat
, 1, 1, 0,
699 doc
: /* Return the floating point number equal to ARG. */)
700 (register Lisp_Object arg
)
702 CHECK_NUMBER_OR_FLOAT (arg
);
705 return make_float ((double) XINT (arg
));
706 else /* give 'em the same float back */
710 DEFUN ("logb", Flogb
, Slogb
, 1, 1, 0,
711 doc
: /* Returns largest integer <= the base 2 log of the magnitude of ARG.
712 This is the same as the exponent of a float. */)
717 double f
= extract_float (arg
);
720 value
= MOST_NEGATIVE_FIXNUM
;
724 IN_FLOAT (value
= logb (f
), "logb", arg
);
728 IN_FLOAT (frexp (f
, &ivalue
), "logb", arg
);
738 for (i
= 1, d
= 0.5; d
* d
>= f
; i
+= i
)
745 for (i
= 1, d
= 2.0; d
* d
<= f
; i
+= i
)
753 XSETINT (val
, value
);
758 /* the rounding functions */
761 rounding_driver (Lisp_Object arg
, Lisp_Object divisor
,
762 double (*double_round
) (double),
763 EMACS_INT (*int_round2
) (EMACS_INT
, EMACS_INT
),
766 CHECK_NUMBER_OR_FLOAT (arg
);
768 if (! NILP (divisor
))
772 CHECK_NUMBER_OR_FLOAT (divisor
);
774 if (FLOATP (arg
) || FLOATP (divisor
))
778 f1
= FLOATP (arg
) ? XFLOAT_DATA (arg
) : XINT (arg
);
779 f2
= (FLOATP (divisor
) ? XFLOAT_DATA (divisor
) : XINT (divisor
));
780 if (! IEEE_FLOATING_POINT
&& f2
== 0)
781 xsignal0 (Qarith_error
);
783 IN_FLOAT2 (f1
= (*double_round
) (f1
/ f2
), name
, arg
, divisor
);
784 FLOAT_TO_INT2 (f1
, arg
, name
, arg
, divisor
);
792 xsignal0 (Qarith_error
);
794 XSETINT (arg
, (*int_round2
) (i1
, i2
));
802 IN_FLOAT (d
= (*double_round
) (XFLOAT_DATA (arg
)), name
, arg
);
803 FLOAT_TO_INT (d
, arg
, name
, arg
);
809 /* With C's /, the result is implementation-defined if either operand
810 is negative, so take care with negative operands in the following
811 integer functions. */
814 ceiling2 (EMACS_INT i1
, EMACS_INT i2
)
817 ? (i1
< 0 ? ((-1 - i1
) / -i2
) + 1 : - (i1
/ -i2
))
818 : (i1
<= 0 ? - (-i1
/ i2
) : ((i1
- 1) / i2
) + 1));
822 floor2 (EMACS_INT i1
, EMACS_INT i2
)
825 ? (i1
<= 0 ? -i1
/ -i2
: -1 - ((i1
- 1) / -i2
))
826 : (i1
< 0 ? -1 - ((-1 - i1
) / i2
) : i1
/ i2
));
830 truncate2 (EMACS_INT i1
, EMACS_INT i2
)
833 ? (i1
< 0 ? -i1
/ -i2
: - (i1
/ -i2
))
834 : (i1
< 0 ? - (-i1
/ i2
) : i1
/ i2
));
838 round2 (EMACS_INT i1
, EMACS_INT i2
)
840 /* The C language's division operator gives us one remainder R, but
841 we want the remainder R1 on the other side of 0 if R1 is closer
842 to 0 than R is; because we want to round to even, we also want R1
843 if R and R1 are the same distance from 0 and if C's quotient is
845 EMACS_INT q
= i1
/ i2
;
846 EMACS_INT r
= i1
% i2
;
847 EMACS_INT abs_r
= r
< 0 ? -r
: r
;
848 EMACS_INT abs_r1
= (i2
< 0 ? -i2
: i2
) - abs_r
;
849 return q
+ (abs_r
+ (q
& 1) <= abs_r1
? 0 : (i2
^ r
) < 0 ? -1 : 1);
852 /* The code uses emacs_rint, so that it works to undefine HAVE_RINT
853 if `rint' exists but does not work right. */
855 #define emacs_rint rint
858 emacs_rint (double d
)
860 return floor (d
+ 0.5);
865 double_identity (double d
)
870 DEFUN ("ceiling", Fceiling
, Sceiling
, 1, 2, 0,
871 doc
: /* Return the smallest integer no less than ARG.
872 This rounds the value towards +inf.
873 With optional DIVISOR, return the smallest integer no less than ARG/DIVISOR. */)
874 (Lisp_Object arg
, Lisp_Object divisor
)
876 return rounding_driver (arg
, divisor
, ceil
, ceiling2
, "ceiling");
879 DEFUN ("floor", Ffloor
, Sfloor
, 1, 2, 0,
880 doc
: /* Return the largest integer no greater than ARG.
881 This rounds the value towards -inf.
882 With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR. */)
883 (Lisp_Object arg
, Lisp_Object divisor
)
885 return rounding_driver (arg
, divisor
, floor
, floor2
, "floor");
888 DEFUN ("round", Fround
, Sround
, 1, 2, 0,
889 doc
: /* Return the nearest integer to ARG.
890 With optional DIVISOR, return the nearest integer to ARG/DIVISOR.
892 Rounding a value equidistant between two integers may choose the
893 integer closer to zero, or it may prefer an even integer, depending on
894 your machine. For example, \(round 2.5\) can return 3 on some
895 systems, but 2 on others. */)
896 (Lisp_Object arg
, Lisp_Object divisor
)
898 return rounding_driver (arg
, divisor
, emacs_rint
, round2
, "round");
901 DEFUN ("truncate", Ftruncate
, Struncate
, 1, 2, 0,
902 doc
: /* Truncate a floating point number to an int.
903 Rounds ARG toward zero.
904 With optional DIVISOR, truncate ARG/DIVISOR. */)
905 (Lisp_Object arg
, Lisp_Object divisor
)
907 return rounding_driver (arg
, divisor
, double_identity
, truncate2
,
913 fmod_float (Lisp_Object x
, Lisp_Object y
)
917 f1
= FLOATP (x
) ? XFLOAT_DATA (x
) : XINT (x
);
918 f2
= FLOATP (y
) ? XFLOAT_DATA (y
) : XINT (y
);
920 if (! IEEE_FLOATING_POINT
&& f2
== 0)
921 xsignal0 (Qarith_error
);
923 /* If the "remainder" comes out with the wrong sign, fix it. */
924 IN_FLOAT2 ((f1
= fmod (f1
, f2
),
925 f1
= (f2
< 0 ? f1
> 0 : f1
< 0) ? f1
+ f2
: f1
),
927 return make_float (f1
);
930 /* It's not clear these are worth adding. */
932 DEFUN ("fceiling", Ffceiling
, Sfceiling
, 1, 1, 0,
933 doc
: /* Return the smallest integer no less than ARG, as a float.
934 \(Round toward +inf.\) */)
935 (register Lisp_Object arg
)
937 double d
= extract_float (arg
);
938 IN_FLOAT (d
= ceil (d
), "fceiling", arg
);
939 return make_float (d
);
942 DEFUN ("ffloor", Fffloor
, Sffloor
, 1, 1, 0,
943 doc
: /* Return the largest integer no greater than ARG, as a float.
944 \(Round towards -inf.\) */)
945 (register Lisp_Object arg
)
947 double d
= extract_float (arg
);
948 IN_FLOAT (d
= floor (d
), "ffloor", arg
);
949 return make_float (d
);
952 DEFUN ("fround", Ffround
, Sfround
, 1, 1, 0,
953 doc
: /* Return the nearest integer to ARG, as a float. */)
954 (register Lisp_Object arg
)
956 double d
= extract_float (arg
);
957 IN_FLOAT (d
= emacs_rint (d
), "fround", arg
);
958 return make_float (d
);
961 DEFUN ("ftruncate", Fftruncate
, Sftruncate
, 1, 1, 0,
962 doc
: /* Truncate a floating point number to an integral float value.
963 Rounds the value toward zero. */)
964 (register Lisp_Object arg
)
966 double d
= extract_float (arg
);
968 IN_FLOAT (d
= floor (d
), "ftruncate", arg
);
970 IN_FLOAT (d
= ceil (d
), "ftruncate", arg
);
971 return make_float (d
);
974 #ifdef FLOAT_CATCH_SIGILL
980 fatal_error_signal (signo
);
983 sigsetmask (SIGEMPTYMASK
);
985 /* Must reestablish handler each time it is called. */
986 signal (SIGILL
, float_error
);
987 #endif /* BSD_SYSTEM */
989 SIGNAL_THREAD_CHECK (signo
);
992 xsignal1 (Qarith_error
, float_error_arg
);
995 /* Another idea was to replace the library function `infnan'
996 where SIGILL is signaled. */
998 #endif /* FLOAT_CATCH_SIGILL */
1002 matherr (struct exception
*x
)
1005 const char *name
= x
->name
;
1008 /* Not called from emacs-lisp float routines; do the default thing. */
1010 if (!strcmp (x
->name
, "pow"))
1014 = Fcons (build_string (name
),
1015 Fcons (make_float (x
->arg1
),
1016 ((!strcmp (name
, "log") || !strcmp (name
, "pow"))
1017 ? Fcons (make_float (x
->arg2
), Qnil
)
1021 case DOMAIN
: xsignal (Qdomain_error
, args
); break;
1022 case SING
: xsignal (Qsingularity_error
, args
); break;
1023 case OVERFLOW
: xsignal (Qoverflow_error
, args
); break;
1024 case UNDERFLOW
: xsignal (Qunderflow_error
, args
); break;
1025 default: xsignal (Qarith_error
, args
); break;
1027 return (1); /* don't set errno or print a message */
1029 #endif /* HAVE_MATHERR */
1032 init_floatfns (void)
1034 #ifdef FLOAT_CATCH_SIGILL
1035 signal (SIGILL
, float_error
);
1041 syms_of_floatfns (void)
1049 #if defined HAVE_ISNAN && defined HAVE_COPYSIGN
1051 defsubr (&Scopysign
);
1062 defsubr (&Sbessel_y0
);
1063 defsubr (&Sbessel_y1
);
1064 defsubr (&Sbessel_yn
);
1065 defsubr (&Sbessel_j0
);
1066 defsubr (&Sbessel_j1
);
1067 defsubr (&Sbessel_jn
);
1070 defsubr (&Slog_gamma
);
1071 defsubr (&Scube_root
);
1073 defsubr (&Sfceiling
);
1076 defsubr (&Sftruncate
);
1086 defsubr (&Sceiling
);
1089 defsubr (&Struncate
);