1 /* Primitive operations on floating point for GNU Emacs Lisp interpreter.
2 Copyright (C) 1988, 1993-1994, 1999, 2001-2011 Free Software Foundation, Inc.
4 Author: Wolfgang Rupprecht
5 (according to ack.texi)
7 This file is part of GNU Emacs.
9 GNU Emacs is free software: you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation, either version 3 of the License, or
12 (at your option) any later version.
14 GNU Emacs is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 You should have received a copy of the GNU General Public License
20 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
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.
27 Define HAVE_INVERSE_HYPERBOLIC if you have acosh, asinh, and atanh.
28 Define HAVE_CBRT if you have cbrt.
29 Define HAVE_RINT if you have a working rint.
30 If you don't define these, then the appropriate routines will be simulated.
32 Define HAVE_MATHERR if on a system supporting the SysV matherr callback.
33 (This should happen automatically.)
35 Define FLOAT_CHECK_ERRNO if the float library routines set errno.
36 This has no effect if HAVE_MATHERR is defined.
38 Define FLOAT_CATCH_SIGILL if the float library routines signal SIGILL.
39 (What systems actually do this? Please let us know.)
41 Define FLOAT_CHECK_DOMAIN if the float library doesn't handle errors by
42 either setting errno, or signaling SIGFPE/SIGILL. Otherwise, domain and
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.)
52 #include "syssignal.h"
58 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
59 #ifndef IEEE_FLOATING_POINT
60 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
61 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
62 #define IEEE_FLOATING_POINT 1
64 #define IEEE_FLOATING_POINT 0
70 /* This declaration is omitted on some systems, like Ultrix. */
71 #if !defined (HPUX) && defined (HAVE_LOGB) && !defined (logb)
72 extern double logb (double);
73 #endif /* not HPUX and HAVE_LOGB and no logb macro */
75 #if defined(DOMAIN) && defined(SING) && defined(OVERFLOW)
76 /* If those are defined, then this is probably a `matherr' machine. */
87 # ifdef FLOAT_CHECK_ERRNO
88 # undef FLOAT_CHECK_ERRNO
90 # ifdef FLOAT_CHECK_DOMAIN
91 # undef FLOAT_CHECK_DOMAIN
95 #ifndef NO_FLOAT_CHECK_ERRNO
96 #define FLOAT_CHECK_ERRNO
99 #ifdef FLOAT_CHECK_ERRNO
103 #ifdef FLOAT_CATCH_SIGILL
104 static SIGTYPE
float_error ();
107 /* Nonzero while executing in floating point.
108 This tells float_error what to do. */
112 /* If an argument is out of range for a mathematical function,
113 here is the actual argument value to use in the error message.
114 These variables are used only across the floating point library call
115 so there is no need to staticpro them. */
117 static Lisp_Object float_error_arg
, float_error_arg2
;
119 static const char *float_error_fn_name
;
121 /* Evaluate the floating point expression D, recording NUM
122 as the original argument for error messages.
123 D is normally an assignment expression.
124 Handle errors which may result in signals or may set errno.
126 Note that float_error may be declared to return void, so you can't
127 just cast the zero after the colon to (SIGTYPE) to make the types
130 #ifdef FLOAT_CHECK_ERRNO
131 #define IN_FLOAT(d, name, num) \
133 float_error_arg = num; \
134 float_error_fn_name = name; \
135 in_float = 1; errno = 0; (d); in_float = 0; \
138 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
139 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
140 default: arith_error (float_error_fn_name, float_error_arg); \
143 #define IN_FLOAT2(d, name, num, num2) \
145 float_error_arg = num; \
146 float_error_arg2 = num2; \
147 float_error_fn_name = name; \
148 in_float = 1; errno = 0; (d); in_float = 0; \
151 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
152 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
153 default: arith_error (float_error_fn_name, float_error_arg); \
157 #define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0)
158 #define IN_FLOAT2(d, name, num, num2) (in_float = 1, (d), in_float = 0)
161 /* Convert float to Lisp_Int if it fits, else signal a range error
162 using the given arguments. */
163 #define FLOAT_TO_INT(x, i, name, num) \
166 if (FIXNUM_OVERFLOW_P (x)) \
167 range_error (name, num); \
168 XSETINT (i, (EMACS_INT)(x)); \
171 #define FLOAT_TO_INT2(x, i, name, num1, num2) \
174 if (FIXNUM_OVERFLOW_P (x)) \
175 range_error2 (name, num1, num2); \
176 XSETINT (i, (EMACS_INT)(x)); \
180 #define arith_error(op,arg) \
181 xsignal2 (Qarith_error, build_string ((op)), (arg))
182 #define range_error(op,arg) \
183 xsignal2 (Qrange_error, build_string ((op)), (arg))
184 #define range_error2(op,a1,a2) \
185 xsignal3 (Qrange_error, build_string ((op)), (a1), (a2))
186 #define domain_error(op,arg) \
187 xsignal2 (Qdomain_error, build_string ((op)), (arg))
188 #define domain_error2(op,a1,a2) \
189 xsignal3 (Qdomain_error, build_string ((op)), (a1), (a2))
191 /* Extract a Lisp number as a `double', or signal an error. */
194 extract_float (Lisp_Object num
)
196 CHECK_NUMBER_OR_FLOAT (num
);
199 return XFLOAT_DATA (num
);
200 return (double) XINT (num
);
203 /* Trig functions. */
205 DEFUN ("acos", Facos
, Sacos
, 1, 1, 0,
206 doc
: /* Return the inverse cosine of ARG. */)
207 (register Lisp_Object arg
)
209 double d
= extract_float (arg
);
210 #ifdef FLOAT_CHECK_DOMAIN
211 if (d
> 1.0 || d
< -1.0)
212 domain_error ("acos", arg
);
214 IN_FLOAT (d
= acos (d
), "acos", arg
);
215 return make_float (d
);
218 DEFUN ("asin", Fasin
, Sasin
, 1, 1, 0,
219 doc
: /* Return the inverse sine of ARG. */)
220 (register Lisp_Object arg
)
222 double d
= extract_float (arg
);
223 #ifdef FLOAT_CHECK_DOMAIN
224 if (d
> 1.0 || d
< -1.0)
225 domain_error ("asin", arg
);
227 IN_FLOAT (d
= asin (d
), "asin", arg
);
228 return make_float (d
);
231 DEFUN ("atan", Fatan
, Satan
, 1, 2, 0,
232 doc
: /* Return the inverse tangent of the arguments.
233 If only one argument Y is given, return the inverse tangent of Y.
234 If two arguments Y and X are given, return the inverse tangent of Y
235 divided by X, i.e. the angle in radians between the vector (X, Y)
237 (register Lisp_Object y
, Lisp_Object x
)
239 double d
= extract_float (y
);
242 IN_FLOAT (d
= atan (d
), "atan", y
);
245 double d2
= extract_float (x
);
247 IN_FLOAT2 (d
= atan2 (d
, d2
), "atan", y
, x
);
249 return make_float (d
);
252 DEFUN ("cos", Fcos
, Scos
, 1, 1, 0,
253 doc
: /* Return the cosine of ARG. */)
254 (register Lisp_Object arg
)
256 double d
= extract_float (arg
);
257 IN_FLOAT (d
= cos (d
), "cos", arg
);
258 return make_float (d
);
261 DEFUN ("sin", Fsin
, Ssin
, 1, 1, 0,
262 doc
: /* Return the sine of ARG. */)
263 (register Lisp_Object arg
)
265 double d
= extract_float (arg
);
266 IN_FLOAT (d
= sin (d
), "sin", arg
);
267 return make_float (d
);
270 DEFUN ("tan", Ftan
, Stan
, 1, 1, 0,
271 doc
: /* Return the tangent of ARG. */)
272 (register Lisp_Object arg
)
274 double d
= extract_float (arg
);
276 #ifdef FLOAT_CHECK_DOMAIN
278 domain_error ("tan", arg
);
280 IN_FLOAT (d
= sin (d
) / c
, "tan", arg
);
281 return make_float (d
);
284 #if defined HAVE_ISNAN && defined HAVE_COPYSIGN
285 DEFUN ("isnan", Fisnan
, Sisnan
, 1, 1, 0,
286 doc
: /* Return non nil iff argument X is a NaN. */)
290 return isnan (XFLOAT_DATA (x
)) ? Qt
: Qnil
;
293 DEFUN ("copysign", Fcopysign
, Scopysign
, 1, 2, 0,
294 doc
: /* Copy sign of X2 to value of X1, and return the result.
295 Cause an error if X1 or X2 is not a float. */)
296 (Lisp_Object x1
, Lisp_Object x2
)
303 f1
= XFLOAT_DATA (x1
);
304 f2
= XFLOAT_DATA (x2
);
306 return make_float (copysign (f1
, f2
));
309 DEFUN ("frexp", Ffrexp
, Sfrexp
, 1, 1, 0,
310 doc
: /* Get significand and exponent of a floating point number.
311 Breaks the floating point number X into its binary significand SGNFCAND
312 \(a floating point value between 0.5 (included) and 1.0 (excluded))
313 and an integral exponent EXP for 2, such that:
317 The function returns the cons cell (SGNFCAND . EXP).
318 If X is zero, both parts (SGNFCAND and EXP) are zero. */)
321 double f
= XFLOATINT (x
);
324 return Fcons (make_float (0.0), make_number (0));
328 double sgnfcand
= frexp (f
, &exp
);
329 return Fcons (make_float (sgnfcand
), make_number (exp
));
333 DEFUN ("ldexp", Fldexp
, Sldexp
, 1, 2, 0,
334 doc
: /* Construct number X from significand SGNFCAND and exponent EXP.
335 Returns the floating point value resulting from multiplying SGNFCAND
336 (the significand) by 2 raised to the power of EXP (the exponent). */)
337 (Lisp_Object sgnfcand
, Lisp_Object exp
)
340 return make_float (ldexp (XFLOATINT (sgnfcand
), XINT (exp
)));
344 #if 0 /* Leave these out unless we find there's a reason for them. */
346 DEFUN ("bessel-j0", Fbessel_j0
, Sbessel_j0
, 1, 1, 0,
347 doc
: /* Return the bessel function j0 of ARG. */)
348 (register Lisp_Object arg
)
350 double d
= extract_float (arg
);
351 IN_FLOAT (d
= j0 (d
), "bessel-j0", arg
);
352 return make_float (d
);
355 DEFUN ("bessel-j1", Fbessel_j1
, Sbessel_j1
, 1, 1, 0,
356 doc
: /* Return the bessel function j1 of ARG. */)
357 (register Lisp_Object arg
)
359 double d
= extract_float (arg
);
360 IN_FLOAT (d
= j1 (d
), "bessel-j1", arg
);
361 return make_float (d
);
364 DEFUN ("bessel-jn", Fbessel_jn
, Sbessel_jn
, 2, 2, 0,
365 doc
: /* Return the order N bessel function output jn of ARG.
366 The first arg (the order) is truncated to an integer. */)
367 (register Lisp_Object n
, Lisp_Object arg
)
369 int i1
= extract_float (n
);
370 double f2
= extract_float (arg
);
372 IN_FLOAT (f2
= jn (i1
, f2
), "bessel-jn", n
);
373 return make_float (f2
);
376 DEFUN ("bessel-y0", Fbessel_y0
, Sbessel_y0
, 1, 1, 0,
377 doc
: /* Return the bessel function y0 of ARG. */)
378 (register Lisp_Object arg
)
380 double d
= extract_float (arg
);
381 IN_FLOAT (d
= y0 (d
), "bessel-y0", arg
);
382 return make_float (d
);
385 DEFUN ("bessel-y1", Fbessel_y1
, Sbessel_y1
, 1, 1, 0,
386 doc
: /* Return the bessel function y1 of ARG. */)
387 (register Lisp_Object arg
)
389 double d
= extract_float (arg
);
390 IN_FLOAT (d
= y1 (d
), "bessel-y0", arg
);
391 return make_float (d
);
394 DEFUN ("bessel-yn", Fbessel_yn
, Sbessel_yn
, 2, 2, 0,
395 doc
: /* Return the order N bessel function output yn of ARG.
396 The first arg (the order) is truncated to an integer. */)
397 (register Lisp_Object n
, Lisp_Object arg
)
399 int i1
= extract_float (n
);
400 double f2
= extract_float (arg
);
402 IN_FLOAT (f2
= yn (i1
, f2
), "bessel-yn", n
);
403 return make_float (f2
);
408 #if 0 /* Leave these out unless we see they are worth having. */
410 DEFUN ("erf", Ferf
, Serf
, 1, 1, 0,
411 doc
: /* Return the mathematical error function of ARG. */)
412 (register Lisp_Object arg
)
414 double d
= extract_float (arg
);
415 IN_FLOAT (d
= erf (d
), "erf", arg
);
416 return make_float (d
);
419 DEFUN ("erfc", Ferfc
, Serfc
, 1, 1, 0,
420 doc
: /* Return the complementary error function of ARG. */)
421 (register Lisp_Object arg
)
423 double d
= extract_float (arg
);
424 IN_FLOAT (d
= erfc (d
), "erfc", arg
);
425 return make_float (d
);
428 DEFUN ("log-gamma", Flog_gamma
, Slog_gamma
, 1, 1, 0,
429 doc
: /* Return the log gamma of ARG. */)
430 (register Lisp_Object arg
)
432 double d
= extract_float (arg
);
433 IN_FLOAT (d
= lgamma (d
), "log-gamma", arg
);
434 return make_float (d
);
437 DEFUN ("cube-root", Fcube_root
, Scube_root
, 1, 1, 0,
438 doc
: /* Return the cube root of ARG. */)
439 (register Lisp_Object arg
)
441 double d
= extract_float (arg
);
443 IN_FLOAT (d
= cbrt (d
), "cube-root", arg
);
446 IN_FLOAT (d
= pow (d
, 1.0/3.0), "cube-root", arg
);
448 IN_FLOAT (d
= -pow (-d
, 1.0/3.0), "cube-root", arg
);
450 return make_float (d
);
455 DEFUN ("exp", Fexp
, Sexp
, 1, 1, 0,
456 doc
: /* Return the exponential base e of ARG. */)
457 (register Lisp_Object arg
)
459 double d
= extract_float (arg
);
460 #ifdef FLOAT_CHECK_DOMAIN
461 if (d
> 709.7827) /* Assume IEEE doubles here */
462 range_error ("exp", arg
);
464 return make_float (0.0);
467 IN_FLOAT (d
= exp (d
), "exp", arg
);
468 return make_float (d
);
471 DEFUN ("expt", Fexpt
, Sexpt
, 2, 2, 0,
472 doc
: /* Return the exponential ARG1 ** ARG2. */)
473 (register Lisp_Object arg1
, Lisp_Object arg2
)
477 CHECK_NUMBER_OR_FLOAT (arg1
);
478 CHECK_NUMBER_OR_FLOAT (arg2
);
479 if (INTEGERP (arg1
) /* common lisp spec */
480 && INTEGERP (arg2
) /* don't promote, if both are ints, and */
481 && 0 <= XINT (arg2
)) /* we are sure the result is not fractional */
482 { /* this can be improved by pre-calculating */
483 EMACS_INT acc
, x
, y
; /* some binary powers of x then accumulating */
495 acc
= (y
& 1) ? -1 : 1;
506 y
= (unsigned)y
>> 1;
512 f1
= FLOATP (arg1
) ? XFLOAT_DATA (arg1
) : XINT (arg1
);
513 f2
= FLOATP (arg2
) ? XFLOAT_DATA (arg2
) : XINT (arg2
);
514 /* Really should check for overflow, too */
515 if (f1
== 0.0 && f2
== 0.0)
517 #ifdef FLOAT_CHECK_DOMAIN
518 else if ((f1
== 0.0 && f2
< 0.0) || (f1
< 0 && f2
!= floor(f2
)))
519 domain_error2 ("expt", arg1
, arg2
);
521 IN_FLOAT2 (f3
= pow (f1
, f2
), "expt", arg1
, arg2
);
522 /* Check for overflow in the result. */
523 if (f1
!= 0.0 && f3
== 0.0)
524 range_error ("expt", arg1
);
525 return make_float (f3
);
528 DEFUN ("log", Flog
, Slog
, 1, 2, 0,
529 doc
: /* Return the natural logarithm of ARG.
530 If the optional argument BASE is given, return log ARG using that base. */)
531 (register Lisp_Object arg
, Lisp_Object base
)
533 double d
= extract_float (arg
);
535 #ifdef FLOAT_CHECK_DOMAIN
537 domain_error2 ("log", arg
, base
);
540 IN_FLOAT (d
= log (d
), "log", arg
);
543 double b
= extract_float (base
);
545 #ifdef FLOAT_CHECK_DOMAIN
546 if (b
<= 0.0 || b
== 1.0)
547 domain_error2 ("log", arg
, base
);
550 IN_FLOAT2 (d
= log10 (d
), "log", arg
, base
);
552 IN_FLOAT2 (d
= log (d
) / log (b
), "log", arg
, base
);
554 return make_float (d
);
557 DEFUN ("log10", Flog10
, Slog10
, 1, 1, 0,
558 doc
: /* Return the logarithm base 10 of ARG. */)
559 (register Lisp_Object arg
)
561 double d
= extract_float (arg
);
562 #ifdef FLOAT_CHECK_DOMAIN
564 domain_error ("log10", arg
);
566 IN_FLOAT (d
= log10 (d
), "log10", arg
);
567 return make_float (d
);
570 DEFUN ("sqrt", Fsqrt
, Ssqrt
, 1, 1, 0,
571 doc
: /* Return the square root of ARG. */)
572 (register Lisp_Object arg
)
574 double d
= extract_float (arg
);
575 #ifdef FLOAT_CHECK_DOMAIN
577 domain_error ("sqrt", arg
);
579 IN_FLOAT (d
= sqrt (d
), "sqrt", arg
);
580 return make_float (d
);
583 #if 0 /* Not clearly worth adding. */
585 DEFUN ("acosh", Facosh
, Sacosh
, 1, 1, 0,
586 doc
: /* Return the inverse hyperbolic cosine of ARG. */)
587 (register Lisp_Object arg
)
589 double d
= extract_float (arg
);
590 #ifdef FLOAT_CHECK_DOMAIN
592 domain_error ("acosh", arg
);
594 #ifdef HAVE_INVERSE_HYPERBOLIC
595 IN_FLOAT (d
= acosh (d
), "acosh", arg
);
597 IN_FLOAT (d
= log (d
+ sqrt (d
*d
- 1.0)), "acosh", arg
);
599 return make_float (d
);
602 DEFUN ("asinh", Fasinh
, Sasinh
, 1, 1, 0,
603 doc
: /* Return the inverse hyperbolic sine of ARG. */)
604 (register Lisp_Object arg
)
606 double d
= extract_float (arg
);
607 #ifdef HAVE_INVERSE_HYPERBOLIC
608 IN_FLOAT (d
= asinh (d
), "asinh", arg
);
610 IN_FLOAT (d
= log (d
+ sqrt (d
*d
+ 1.0)), "asinh", arg
);
612 return make_float (d
);
615 DEFUN ("atanh", Fatanh
, Satanh
, 1, 1, 0,
616 doc
: /* Return the inverse hyperbolic tangent of ARG. */)
617 (register Lisp_Object arg
)
619 double d
= extract_float (arg
);
620 #ifdef FLOAT_CHECK_DOMAIN
621 if (d
>= 1.0 || d
<= -1.0)
622 domain_error ("atanh", arg
);
624 #ifdef HAVE_INVERSE_HYPERBOLIC
625 IN_FLOAT (d
= atanh (d
), "atanh", arg
);
627 IN_FLOAT (d
= 0.5 * log ((1.0 + d
) / (1.0 - d
)), "atanh", arg
);
629 return make_float (d
);
632 DEFUN ("cosh", Fcosh
, Scosh
, 1, 1, 0,
633 doc
: /* Return the hyperbolic cosine of ARG. */)
634 (register Lisp_Object arg
)
636 double d
= extract_float (arg
);
637 #ifdef FLOAT_CHECK_DOMAIN
638 if (d
> 710.0 || d
< -710.0)
639 range_error ("cosh", arg
);
641 IN_FLOAT (d
= cosh (d
), "cosh", arg
);
642 return make_float (d
);
645 DEFUN ("sinh", Fsinh
, Ssinh
, 1, 1, 0,
646 doc
: /* Return the hyperbolic sine of ARG. */)
647 (register Lisp_Object arg
)
649 double d
= extract_float (arg
);
650 #ifdef FLOAT_CHECK_DOMAIN
651 if (d
> 710.0 || d
< -710.0)
652 range_error ("sinh", arg
);
654 IN_FLOAT (d
= sinh (d
), "sinh", arg
);
655 return make_float (d
);
658 DEFUN ("tanh", Ftanh
, Stanh
, 1, 1, 0,
659 doc
: /* Return the hyperbolic tangent of ARG. */)
660 (register Lisp_Object arg
)
662 double d
= extract_float (arg
);
663 IN_FLOAT (d
= tanh (d
), "tanh", arg
);
664 return make_float (d
);
668 DEFUN ("abs", Fabs
, Sabs
, 1, 1, 0,
669 doc
: /* Return the absolute value of ARG. */)
670 (register Lisp_Object arg
)
672 CHECK_NUMBER_OR_FLOAT (arg
);
675 IN_FLOAT (arg
= make_float (fabs (XFLOAT_DATA (arg
))), "abs", arg
);
676 else if (XINT (arg
) < 0)
677 XSETINT (arg
, - XINT (arg
));
682 DEFUN ("float", Ffloat
, Sfloat
, 1, 1, 0,
683 doc
: /* Return the floating point number equal to ARG. */)
684 (register Lisp_Object arg
)
686 CHECK_NUMBER_OR_FLOAT (arg
);
689 return make_float ((double) XINT (arg
));
690 else /* give 'em the same float back */
694 DEFUN ("logb", Flogb
, Slogb
, 1, 1, 0,
695 doc
: /* Returns largest integer <= the base 2 log of the magnitude of ARG.
696 This is the same as the exponent of a float. */)
701 double f
= extract_float (arg
);
704 value
= MOST_NEGATIVE_FIXNUM
;
708 IN_FLOAT (value
= logb (f
), "logb", arg
);
712 IN_FLOAT (frexp (f
, &ivalue
), "logb", arg
);
722 for (i
= 1, d
= 0.5; d
* d
>= f
; i
+= i
)
729 for (i
= 1, d
= 2.0; d
* d
<= f
; i
+= i
)
737 XSETINT (val
, value
);
742 /* the rounding functions */
745 rounding_driver (Lisp_Object arg
, Lisp_Object divisor
,
746 double (*double_round
) (double),
747 EMACS_INT (*int_round2
) (EMACS_INT
, EMACS_INT
),
750 CHECK_NUMBER_OR_FLOAT (arg
);
752 if (! NILP (divisor
))
756 CHECK_NUMBER_OR_FLOAT (divisor
);
758 if (FLOATP (arg
) || FLOATP (divisor
))
762 f1
= FLOATP (arg
) ? XFLOAT_DATA (arg
) : XINT (arg
);
763 f2
= (FLOATP (divisor
) ? XFLOAT_DATA (divisor
) : XINT (divisor
));
764 if (! IEEE_FLOATING_POINT
&& f2
== 0)
765 xsignal0 (Qarith_error
);
767 IN_FLOAT2 (f1
= (*double_round
) (f1
/ f2
), name
, arg
, divisor
);
768 FLOAT_TO_INT2 (f1
, arg
, name
, arg
, divisor
);
776 xsignal0 (Qarith_error
);
778 XSETINT (arg
, (*int_round2
) (i1
, i2
));
786 IN_FLOAT (d
= (*double_round
) (XFLOAT_DATA (arg
)), name
, arg
);
787 FLOAT_TO_INT (d
, arg
, name
, arg
);
793 /* With C's /, the result is implementation-defined if either operand
794 is negative, so take care with negative operands in the following
795 integer functions. */
798 ceiling2 (EMACS_INT i1
, EMACS_INT i2
)
801 ? (i1
< 0 ? ((-1 - i1
) / -i2
) + 1 : - (i1
/ -i2
))
802 : (i1
<= 0 ? - (-i1
/ i2
) : ((i1
- 1) / i2
) + 1));
806 floor2 (EMACS_INT i1
, EMACS_INT i2
)
809 ? (i1
<= 0 ? -i1
/ -i2
: -1 - ((i1
- 1) / -i2
))
810 : (i1
< 0 ? -1 - ((-1 - i1
) / i2
) : i1
/ i2
));
814 truncate2 (EMACS_INT i1
, EMACS_INT i2
)
817 ? (i1
< 0 ? -i1
/ -i2
: - (i1
/ -i2
))
818 : (i1
< 0 ? - (-i1
/ i2
) : i1
/ i2
));
822 round2 (EMACS_INT i1
, EMACS_INT i2
)
824 /* The C language's division operator gives us one remainder R, but
825 we want the remainder R1 on the other side of 0 if R1 is closer
826 to 0 than R is; because we want to round to even, we also want R1
827 if R and R1 are the same distance from 0 and if C's quotient is
829 EMACS_INT q
= i1
/ i2
;
830 EMACS_INT r
= i1
% i2
;
831 EMACS_INT abs_r
= r
< 0 ? -r
: r
;
832 EMACS_INT abs_r1
= (i2
< 0 ? -i2
: i2
) - abs_r
;
833 return q
+ (abs_r
+ (q
& 1) <= abs_r1
? 0 : (i2
^ r
) < 0 ? -1 : 1);
836 /* The code uses emacs_rint, so that it works to undefine HAVE_RINT
837 if `rint' exists but does not work right. */
839 #define emacs_rint rint
842 emacs_rint (double d
)
844 return floor (d
+ 0.5);
849 double_identity (double d
)
854 DEFUN ("ceiling", Fceiling
, Sceiling
, 1, 2, 0,
855 doc
: /* Return the smallest integer no less than ARG.
856 This rounds the value towards +inf.
857 With optional DIVISOR, return the smallest integer no less than ARG/DIVISOR. */)
858 (Lisp_Object arg
, Lisp_Object 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. */)
867 (Lisp_Object arg
, Lisp_Object divisor
)
869 return rounding_driver (arg
, divisor
, floor
, floor2
, "floor");
872 DEFUN ("round", Fround
, Sround
, 1, 2, 0,
873 doc
: /* Return the nearest integer to ARG.
874 With optional DIVISOR, return the nearest integer to ARG/DIVISOR.
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
879 systems, but 2 on others. */)
880 (Lisp_Object arg
, Lisp_Object divisor
)
882 return rounding_driver (arg
, divisor
, emacs_rint
, round2
, "round");
885 DEFUN ("truncate", Ftruncate
, Struncate
, 1, 2, 0,
886 doc
: /* Truncate a floating point number to an int.
887 Rounds ARG toward zero.
888 With optional DIVISOR, truncate ARG/DIVISOR. */)
889 (Lisp_Object arg
, Lisp_Object divisor
)
891 return rounding_driver (arg
, divisor
, double_identity
, truncate2
,
897 fmod_float (Lisp_Object x
, Lisp_Object y
)
901 f1
= FLOATP (x
) ? XFLOAT_DATA (x
) : XINT (x
);
902 f2
= FLOATP (y
) ? XFLOAT_DATA (y
) : XINT (y
);
904 if (! IEEE_FLOATING_POINT
&& f2
== 0)
905 xsignal0 (Qarith_error
);
907 /* If the "remainder" comes out with the wrong sign, fix it. */
908 IN_FLOAT2 ((f1
= fmod (f1
, f2
),
909 f1
= (f2
< 0 ? f1
> 0 : f1
< 0) ? f1
+ f2
: f1
),
911 return make_float (f1
);
914 /* It's not clear these are worth adding. */
916 DEFUN ("fceiling", Ffceiling
, Sfceiling
, 1, 1, 0,
917 doc
: /* Return the smallest integer no less than ARG, as a float.
918 \(Round toward +inf.\) */)
919 (register Lisp_Object arg
)
921 double d
= extract_float (arg
);
922 IN_FLOAT (d
= ceil (d
), "fceiling", arg
);
923 return make_float (d
);
926 DEFUN ("ffloor", Fffloor
, Sffloor
, 1, 1, 0,
927 doc
: /* Return the largest integer no greater than ARG, as a float.
928 \(Round towards -inf.\) */)
929 (register Lisp_Object arg
)
931 double d
= extract_float (arg
);
932 IN_FLOAT (d
= floor (d
), "ffloor", arg
);
933 return make_float (d
);
936 DEFUN ("fround", Ffround
, Sfround
, 1, 1, 0,
937 doc
: /* Return the nearest integer to ARG, as a float. */)
938 (register Lisp_Object arg
)
940 double d
= extract_float (arg
);
941 IN_FLOAT (d
= emacs_rint (d
), "fround", arg
);
942 return make_float (d
);
945 DEFUN ("ftruncate", Fftruncate
, Sftruncate
, 1, 1, 0,
946 doc
: /* Truncate a floating point number to an integral float value.
947 Rounds the value toward zero. */)
948 (register Lisp_Object arg
)
950 double d
= extract_float (arg
);
952 IN_FLOAT (d
= floor (d
), "ftruncate", arg
);
954 IN_FLOAT (d
= ceil (d
), "ftruncate", arg
);
955 return make_float (d
);
958 #ifdef FLOAT_CATCH_SIGILL
964 fatal_error_signal (signo
);
967 sigsetmask (SIGEMPTYMASK
);
969 /* Must reestablish handler each time it is called. */
970 signal (SIGILL
, float_error
);
971 #endif /* BSD_SYSTEM */
973 SIGNAL_THREAD_CHECK (signo
);
976 xsignal1 (Qarith_error
, float_error_arg
);
979 /* Another idea was to replace the library function `infnan'
980 where SIGILL is signaled. */
982 #endif /* FLOAT_CATCH_SIGILL */
986 matherr (struct exception
*x
)
989 const char *name
= x
->name
;
992 /* Not called from emacs-lisp float routines; do the default thing. */
994 if (!strcmp (x
->name
, "pow"))
998 = Fcons (build_string (name
),
999 Fcons (make_float (x
->arg1
),
1000 ((!strcmp (name
, "log") || !strcmp (name
, "pow"))
1001 ? Fcons (make_float (x
->arg2
), Qnil
)
1005 case DOMAIN
: xsignal (Qdomain_error
, args
); break;
1006 case SING
: xsignal (Qsingularity_error
, args
); break;
1007 case OVERFLOW
: xsignal (Qoverflow_error
, args
); break;
1008 case UNDERFLOW
: xsignal (Qunderflow_error
, args
); break;
1009 default: xsignal (Qarith_error
, args
); break;
1011 return (1); /* don't set errno or print a message */
1013 #endif /* HAVE_MATHERR */
1016 init_floatfns (void)
1018 #ifdef FLOAT_CATCH_SIGILL
1019 signal (SIGILL
, float_error
);
1025 syms_of_floatfns (void)
1033 #if defined HAVE_ISNAN && defined HAVE_COPYSIGN
1035 defsubr (&Scopysign
);
1046 defsubr (&Sbessel_y0
);
1047 defsubr (&Sbessel_y1
);
1048 defsubr (&Sbessel_yn
);
1049 defsubr (&Sbessel_j0
);
1050 defsubr (&Sbessel_j1
);
1051 defsubr (&Sbessel_jn
);
1054 defsubr (&Slog_gamma
);
1055 defsubr (&Scube_root
);
1057 defsubr (&Sfceiling
);
1060 defsubr (&Sftruncate
);
1070 defsubr (&Sceiling
);
1073 defsubr (&Struncate
);