1 /* Primitive operations on floating point for GNU Emacs Lisp interpreter.
3 Copyright (C) 1988, 1993-1994, 1999, 2001-2012
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_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.)
51 #include "syssignal.h"
54 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
55 #ifndef IEEE_FLOATING_POINT
56 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
57 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
58 #define IEEE_FLOATING_POINT 1
60 #define IEEE_FLOATING_POINT 0
66 /* This declaration is omitted on some systems, like Ultrix. */
67 #if !defined (HPUX) && defined (HAVE_LOGB) && !defined (logb)
68 extern double logb (double);
69 #endif /* not HPUX and HAVE_LOGB and no logb macro */
71 #if defined (DOMAIN) && defined (SING) && defined (OVERFLOW)
72 /* If those are defined, then this is probably a `matherr' machine. */
83 # ifdef FLOAT_CHECK_ERRNO
84 # undef FLOAT_CHECK_ERRNO
86 # ifdef FLOAT_CHECK_DOMAIN
87 # undef FLOAT_CHECK_DOMAIN
91 #ifndef NO_FLOAT_CHECK_ERRNO
92 #define FLOAT_CHECK_ERRNO
95 #ifdef FLOAT_CHECK_ERRNO
99 /* True while executing in floating point.
100 This tells float_error what to do. */
102 static bool in_float
;
104 /* If an argument is out of range for a mathematical function,
105 here is the actual argument value to use in the error message.
106 These variables are used only across the floating point library call
107 so there is no need to staticpro them. */
109 static Lisp_Object float_error_arg
, float_error_arg2
;
111 static const char *float_error_fn_name
;
113 /* Evaluate the floating point expression D, recording NUM
114 as the original argument for error messages.
115 D is normally an assignment expression.
116 Handle errors which may result in signals or may set errno.
118 Note that float_error may be declared to return void, so you can't
119 just cast the zero after the colon to (void) to make the types
122 #ifdef FLOAT_CHECK_ERRNO
123 #define IN_FLOAT(d, name, num) \
125 float_error_arg = num; \
126 float_error_fn_name = name; \
127 in_float = 1; errno = 0; (d); in_float = 0; \
130 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
131 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
132 default: arith_error (float_error_fn_name, float_error_arg); \
135 #define IN_FLOAT2(d, name, num, num2) \
137 float_error_arg = num; \
138 float_error_arg2 = num2; \
139 float_error_fn_name = name; \
140 in_float = 1; errno = 0; (d); in_float = 0; \
143 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
144 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
145 default: arith_error (float_error_fn_name, float_error_arg); \
149 #define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0)
150 #define IN_FLOAT2(d, name, num, num2) (in_float = 1, (d), in_float = 0)
153 /* Convert float to Lisp_Int if it fits, else signal a range error
154 using the given arguments. */
155 #define FLOAT_TO_INT(x, i, name, num) \
158 if (FIXNUM_OVERFLOW_P (x)) \
159 range_error (name, num); \
160 XSETINT (i, (EMACS_INT)(x)); \
163 #define FLOAT_TO_INT2(x, i, name, num1, num2) \
166 if (FIXNUM_OVERFLOW_P (x)) \
167 range_error2 (name, num1, num2); \
168 XSETINT (i, (EMACS_INT)(x)); \
172 #define arith_error(op,arg) \
173 xsignal2 (Qarith_error, build_string ((op)), (arg))
174 #define range_error(op,arg) \
175 xsignal2 (Qrange_error, build_string ((op)), (arg))
176 #define range_error2(op,a1,a2) \
177 xsignal3 (Qrange_error, build_string ((op)), (a1), (a2))
178 #define domain_error(op,arg) \
179 xsignal2 (Qdomain_error, build_string ((op)), (arg))
180 #ifdef FLOAT_CHECK_DOMAIN
181 #define domain_error2(op,a1,a2) \
182 xsignal3 (Qdomain_error, build_string ((op)), (a1), (a2))
185 /* Extract a Lisp number as a `double', or signal an error. */
188 extract_float (Lisp_Object num
)
190 CHECK_NUMBER_OR_FLOAT (num
);
193 return XFLOAT_DATA (num
);
194 return (double) XINT (num
);
197 /* Trig functions. */
199 DEFUN ("acos", Facos
, Sacos
, 1, 1, 0,
200 doc
: /* Return the inverse cosine of ARG. */)
201 (register Lisp_Object arg
)
203 double d
= extract_float (arg
);
204 #ifdef FLOAT_CHECK_DOMAIN
205 if (d
> 1.0 || d
< -1.0)
206 domain_error ("acos", arg
);
208 IN_FLOAT (d
= acos (d
), "acos", arg
);
209 return make_float (d
);
212 DEFUN ("asin", Fasin
, Sasin
, 1, 1, 0,
213 doc
: /* Return the inverse sine of ARG. */)
214 (register Lisp_Object arg
)
216 double d
= extract_float (arg
);
217 #ifdef FLOAT_CHECK_DOMAIN
218 if (d
> 1.0 || d
< -1.0)
219 domain_error ("asin", arg
);
221 IN_FLOAT (d
= asin (d
), "asin", arg
);
222 return make_float (d
);
225 DEFUN ("atan", Fatan
, Satan
, 1, 2, 0,
226 doc
: /* Return the inverse tangent of the arguments.
227 If only one argument Y is given, return the inverse tangent of Y.
228 If two arguments Y and X are given, return the inverse tangent of Y
229 divided by X, i.e. the angle in radians between the vector (X, Y)
231 (register Lisp_Object y
, Lisp_Object x
)
233 double d
= extract_float (y
);
236 IN_FLOAT (d
= atan (d
), "atan", y
);
239 double d2
= extract_float (x
);
241 IN_FLOAT2 (d
= atan2 (d
, d2
), "atan", y
, x
);
243 return make_float (d
);
246 DEFUN ("cos", Fcos
, Scos
, 1, 1, 0,
247 doc
: /* Return the cosine of ARG. */)
248 (register Lisp_Object arg
)
250 double d
= extract_float (arg
);
251 IN_FLOAT (d
= cos (d
), "cos", arg
);
252 return make_float (d
);
255 DEFUN ("sin", Fsin
, Ssin
, 1, 1, 0,
256 doc
: /* Return the sine of ARG. */)
257 (register Lisp_Object arg
)
259 double d
= extract_float (arg
);
260 IN_FLOAT (d
= sin (d
), "sin", arg
);
261 return make_float (d
);
264 DEFUN ("tan", Ftan
, Stan
, 1, 1, 0,
265 doc
: /* Return the tangent of ARG. */)
266 (register Lisp_Object arg
)
268 double d
= extract_float (arg
);
270 #ifdef FLOAT_CHECK_DOMAIN
272 domain_error ("tan", arg
);
274 IN_FLOAT (d
= sin (d
) / c
, "tan", arg
);
275 return make_float (d
);
279 #define isnan(x) ((x) != (x))
281 DEFUN ("isnan", Fisnan
, Sisnan
, 1, 1, 0,
282 doc
: /* Return non nil iff argument X is a NaN. */)
286 return isnan (XFLOAT_DATA (x
)) ? Qt
: Qnil
;
290 DEFUN ("copysign", Fcopysign
, Scopysign
, 2, 2, 0,
291 doc
: /* Copy sign of X2 to value of X1, and return the result.
292 Cause an error if X1 or X2 is not a float. */)
293 (Lisp_Object x1
, Lisp_Object x2
)
300 f1
= XFLOAT_DATA (x1
);
301 f2
= XFLOAT_DATA (x2
);
303 return make_float (copysign (f1
, f2
));
306 DEFUN ("frexp", Ffrexp
, Sfrexp
, 1, 1, 0,
307 doc
: /* Get significand and exponent of a floating point number.
308 Breaks the floating point number X into its binary significand SGNFCAND
309 \(a floating point value between 0.5 (included) and 1.0 (excluded))
310 and an integral exponent EXP for 2, such that:
314 The function returns the cons cell (SGNFCAND . EXP).
315 If X is zero, both parts (SGNFCAND and EXP) are zero. */)
318 double f
= XFLOATINT (x
);
321 return Fcons (make_float (0.0), make_number (0));
325 double sgnfcand
= frexp (f
, &exponent
);
326 return Fcons (make_float (sgnfcand
), make_number (exponent
));
330 DEFUN ("ldexp", Fldexp
, Sldexp
, 1, 2, 0,
331 doc
: /* Construct number X from significand SGNFCAND and exponent EXP.
332 Returns the floating point value resulting from multiplying SGNFCAND
333 (the significand) by 2 raised to the power of EXP (the exponent). */)
334 (Lisp_Object sgnfcand
, Lisp_Object exponent
)
336 CHECK_NUMBER (exponent
);
337 return make_float (ldexp (XFLOATINT (sgnfcand
), XINT (exponent
)));
341 #if 0 /* Leave these out unless we find there's a reason for them. */
343 DEFUN ("bessel-j0", Fbessel_j0
, Sbessel_j0
, 1, 1, 0,
344 doc
: /* Return the bessel function j0 of ARG. */)
345 (register Lisp_Object arg
)
347 double d
= extract_float (arg
);
348 IN_FLOAT (d
= j0 (d
), "bessel-j0", arg
);
349 return make_float (d
);
352 DEFUN ("bessel-j1", Fbessel_j1
, Sbessel_j1
, 1, 1, 0,
353 doc
: /* Return the bessel function j1 of ARG. */)
354 (register Lisp_Object arg
)
356 double d
= extract_float (arg
);
357 IN_FLOAT (d
= j1 (d
), "bessel-j1", arg
);
358 return make_float (d
);
361 DEFUN ("bessel-jn", Fbessel_jn
, Sbessel_jn
, 2, 2, 0,
362 doc
: /* Return the order N bessel function output jn of ARG.
363 The first arg (the order) is truncated to an integer. */)
364 (register Lisp_Object n
, Lisp_Object arg
)
366 int i1
= extract_float (n
);
367 double f2
= extract_float (arg
);
369 IN_FLOAT (f2
= jn (i1
, f2
), "bessel-jn", n
);
370 return make_float (f2
);
373 DEFUN ("bessel-y0", Fbessel_y0
, Sbessel_y0
, 1, 1, 0,
374 doc
: /* Return the bessel function y0 of ARG. */)
375 (register Lisp_Object arg
)
377 double d
= extract_float (arg
);
378 IN_FLOAT (d
= y0 (d
), "bessel-y0", arg
);
379 return make_float (d
);
382 DEFUN ("bessel-y1", Fbessel_y1
, Sbessel_y1
, 1, 1, 0,
383 doc
: /* Return the bessel function y1 of ARG. */)
384 (register Lisp_Object arg
)
386 double d
= extract_float (arg
);
387 IN_FLOAT (d
= y1 (d
), "bessel-y0", arg
);
388 return make_float (d
);
391 DEFUN ("bessel-yn", Fbessel_yn
, Sbessel_yn
, 2, 2, 0,
392 doc
: /* Return the order N bessel function output yn of ARG.
393 The first arg (the order) is truncated to an integer. */)
394 (register Lisp_Object n
, Lisp_Object arg
)
396 int i1
= extract_float (n
);
397 double f2
= extract_float (arg
);
399 IN_FLOAT (f2
= yn (i1
, f2
), "bessel-yn", n
);
400 return make_float (f2
);
405 #if 0 /* Leave these out unless we see they are worth having. */
407 DEFUN ("erf", Ferf
, Serf
, 1, 1, 0,
408 doc
: /* Return the mathematical error function of ARG. */)
409 (register Lisp_Object arg
)
411 double d
= extract_float (arg
);
412 IN_FLOAT (d
= erf (d
), "erf", arg
);
413 return make_float (d
);
416 DEFUN ("erfc", Ferfc
, Serfc
, 1, 1, 0,
417 doc
: /* Return the complementary error function of ARG. */)
418 (register Lisp_Object arg
)
420 double d
= extract_float (arg
);
421 IN_FLOAT (d
= erfc (d
), "erfc", arg
);
422 return make_float (d
);
425 DEFUN ("log-gamma", Flog_gamma
, Slog_gamma
, 1, 1, 0,
426 doc
: /* Return the log gamma of ARG. */)
427 (register Lisp_Object arg
)
429 double d
= extract_float (arg
);
430 IN_FLOAT (d
= lgamma (d
), "log-gamma", arg
);
431 return make_float (d
);
434 DEFUN ("cube-root", Fcube_root
, Scube_root
, 1, 1, 0,
435 doc
: /* Return the cube root of ARG. */)
436 (register Lisp_Object arg
)
438 double d
= extract_float (arg
);
440 IN_FLOAT (d
= cbrt (d
), "cube-root", arg
);
443 IN_FLOAT (d
= pow (d
, 1.0/3.0), "cube-root", arg
);
445 IN_FLOAT (d
= -pow (-d
, 1.0/3.0), "cube-root", arg
);
447 return make_float (d
);
452 DEFUN ("exp", Fexp
, Sexp
, 1, 1, 0,
453 doc
: /* Return the exponential base e of ARG. */)
454 (register Lisp_Object arg
)
456 double d
= extract_float (arg
);
457 #ifdef FLOAT_CHECK_DOMAIN
458 if (d
> 709.7827) /* Assume IEEE doubles here */
459 range_error ("exp", arg
);
461 return make_float (0.0);
464 IN_FLOAT (d
= exp (d
), "exp", arg
);
465 return make_float (d
);
468 DEFUN ("expt", Fexpt
, Sexpt
, 2, 2, 0,
469 doc
: /* Return the exponential ARG1 ** ARG2. */)
470 (register Lisp_Object arg1
, Lisp_Object arg2
)
474 CHECK_NUMBER_OR_FLOAT (arg1
);
475 CHECK_NUMBER_OR_FLOAT (arg2
);
476 if (INTEGERP (arg1
) /* common lisp spec */
477 && INTEGERP (arg2
) /* don't promote, if both are ints, and */
478 && 0 <= XINT (arg2
)) /* we are sure the result is not fractional */
479 { /* this can be improved by pre-calculating */
480 EMACS_INT y
; /* some binary powers of x then accumulating */
481 EMACS_UINT acc
, x
; /* Unsigned so that overflow is well defined. */
486 acc
= (y
& 1 ? x
: 1);
488 while ((y
>>= 1) != 0)
497 f1
= FLOATP (arg1
) ? XFLOAT_DATA (arg1
) : XINT (arg1
);
498 f2
= FLOATP (arg2
) ? XFLOAT_DATA (arg2
) : XINT (arg2
);
499 /* Really should check for overflow, too */
500 if (f1
== 0.0 && f2
== 0.0)
502 #ifdef FLOAT_CHECK_DOMAIN
503 else if ((f1
== 0.0 && f2
< 0.0) || (f1
< 0 && f2
!= floor (f2
)))
504 domain_error2 ("expt", arg1
, arg2
);
506 IN_FLOAT2 (f3
= pow (f1
, f2
), "expt", arg1
, arg2
);
507 /* Check for overflow in the result. */
508 if (f1
!= 0.0 && f3
== 0.0)
509 range_error ("expt", arg1
);
510 return make_float (f3
);
513 DEFUN ("log", Flog
, Slog
, 1, 2, 0,
514 doc
: /* Return the natural logarithm of ARG.
515 If the optional argument BASE is given, return log ARG using that base. */)
516 (register Lisp_Object arg
, Lisp_Object base
)
518 double d
= extract_float (arg
);
520 #ifdef FLOAT_CHECK_DOMAIN
522 domain_error2 ("log", arg
, base
);
525 IN_FLOAT (d
= log (d
), "log", arg
);
528 double b
= extract_float (base
);
530 #ifdef FLOAT_CHECK_DOMAIN
531 if (b
<= 0.0 || b
== 1.0)
532 domain_error2 ("log", arg
, base
);
535 IN_FLOAT2 (d
= log10 (d
), "log", arg
, base
);
537 IN_FLOAT2 (d
= log (d
) / log (b
), "log", arg
, base
);
539 return make_float (d
);
542 DEFUN ("log10", Flog10
, Slog10
, 1, 1, 0,
543 doc
: /* Return the logarithm base 10 of ARG. */)
544 (register Lisp_Object arg
)
546 double d
= extract_float (arg
);
547 #ifdef FLOAT_CHECK_DOMAIN
549 domain_error ("log10", arg
);
551 IN_FLOAT (d
= log10 (d
), "log10", arg
);
552 return make_float (d
);
555 DEFUN ("sqrt", Fsqrt
, Ssqrt
, 1, 1, 0,
556 doc
: /* Return the square root of ARG. */)
557 (register Lisp_Object arg
)
559 double d
= extract_float (arg
);
560 #ifdef FLOAT_CHECK_DOMAIN
562 domain_error ("sqrt", arg
);
564 IN_FLOAT (d
= sqrt (d
), "sqrt", arg
);
565 return make_float (d
);
568 #if 0 /* Not clearly worth adding. */
570 DEFUN ("acosh", Facosh
, Sacosh
, 1, 1, 0,
571 doc
: /* Return the inverse hyperbolic cosine of ARG. */)
572 (register Lisp_Object arg
)
574 double d
= extract_float (arg
);
575 #ifdef FLOAT_CHECK_DOMAIN
577 domain_error ("acosh", arg
);
579 #ifdef HAVE_INVERSE_HYPERBOLIC
580 IN_FLOAT (d
= acosh (d
), "acosh", arg
);
582 IN_FLOAT (d
= log (d
+ sqrt (d
*d
- 1.0)), "acosh", arg
);
584 return make_float (d
);
587 DEFUN ("asinh", Fasinh
, Sasinh
, 1, 1, 0,
588 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. */)
602 (register Lisp_Object arg
)
604 double d
= extract_float (arg
);
605 #ifdef FLOAT_CHECK_DOMAIN
606 if (d
>= 1.0 || d
<= -1.0)
607 domain_error ("atanh", arg
);
609 #ifdef HAVE_INVERSE_HYPERBOLIC
610 IN_FLOAT (d
= atanh (d
), "atanh", arg
);
612 IN_FLOAT (d
= 0.5 * log ((1.0 + d
) / (1.0 - d
)), "atanh", arg
);
614 return make_float (d
);
617 DEFUN ("cosh", Fcosh
, Scosh
, 1, 1, 0,
618 doc
: /* Return the hyperbolic cosine of ARG. */)
619 (register Lisp_Object arg
)
621 double d
= extract_float (arg
);
622 #ifdef FLOAT_CHECK_DOMAIN
623 if (d
> 710.0 || d
< -710.0)
624 range_error ("cosh", arg
);
626 IN_FLOAT (d
= cosh (d
), "cosh", arg
);
627 return make_float (d
);
630 DEFUN ("sinh", Fsinh
, Ssinh
, 1, 1, 0,
631 doc
: /* Return the hyperbolic sine of ARG. */)
632 (register Lisp_Object arg
)
634 double d
= extract_float (arg
);
635 #ifdef FLOAT_CHECK_DOMAIN
636 if (d
> 710.0 || d
< -710.0)
637 range_error ("sinh", arg
);
639 IN_FLOAT (d
= sinh (d
), "sinh", arg
);
640 return make_float (d
);
643 DEFUN ("tanh", Ftanh
, Stanh
, 1, 1, 0,
644 doc
: /* Return the hyperbolic tangent of ARG. */)
645 (register Lisp_Object arg
)
647 double d
= extract_float (arg
);
648 IN_FLOAT (d
= tanh (d
), "tanh", arg
);
649 return make_float (d
);
653 DEFUN ("abs", Fabs
, Sabs
, 1, 1, 0,
654 doc
: /* Return the absolute value of ARG. */)
655 (register Lisp_Object arg
)
657 CHECK_NUMBER_OR_FLOAT (arg
);
660 arg
= make_float (fabs (XFLOAT_DATA (arg
)));
661 else if (XINT (arg
) < 0)
662 XSETINT (arg
, - XINT (arg
));
667 DEFUN ("float", Ffloat
, Sfloat
, 1, 1, 0,
668 doc
: /* Return the floating point number equal to ARG. */)
669 (register Lisp_Object arg
)
671 CHECK_NUMBER_OR_FLOAT (arg
);
674 return make_float ((double) XINT (arg
));
675 else /* give 'em the same float back */
679 DEFUN ("logb", Flogb
, Slogb
, 1, 1, 0,
680 doc
: /* Returns largest integer <= the base 2 log of the magnitude of ARG.
681 This is the same as the exponent of a float. */)
686 double f
= extract_float (arg
);
689 value
= MOST_NEGATIVE_FIXNUM
;
693 IN_FLOAT (value
= logb (f
), "logb", arg
);
697 IN_FLOAT (frexp (f
, &ivalue
), "logb", arg
);
707 for (i
= 1, d
= 0.5; d
* d
>= f
; i
+= i
)
714 for (i
= 1, d
= 2.0; d
* d
<= f
; i
+= i
)
722 XSETINT (val
, value
);
727 /* the rounding functions */
730 rounding_driver (Lisp_Object arg
, Lisp_Object divisor
,
731 double (*double_round
) (double),
732 EMACS_INT (*int_round2
) (EMACS_INT
, EMACS_INT
),
735 CHECK_NUMBER_OR_FLOAT (arg
);
737 if (! NILP (divisor
))
741 CHECK_NUMBER_OR_FLOAT (divisor
);
743 if (FLOATP (arg
) || FLOATP (divisor
))
747 f1
= FLOATP (arg
) ? XFLOAT_DATA (arg
) : XINT (arg
);
748 f2
= (FLOATP (divisor
) ? XFLOAT_DATA (divisor
) : XINT (divisor
));
749 if (! IEEE_FLOATING_POINT
&& f2
== 0)
750 xsignal0 (Qarith_error
);
752 IN_FLOAT2 (f1
= (*double_round
) (f1
/ f2
), name
, arg
, divisor
);
753 FLOAT_TO_INT2 (f1
, arg
, name
, arg
, divisor
);
761 xsignal0 (Qarith_error
);
763 XSETINT (arg
, (*int_round2
) (i1
, i2
));
771 IN_FLOAT (d
= (*double_round
) (XFLOAT_DATA (arg
)), name
, arg
);
772 FLOAT_TO_INT (d
, arg
, name
, arg
);
778 /* With C's /, the result is implementation-defined if either operand
779 is negative, so take care with negative operands in the following
780 integer functions. */
783 ceiling2 (EMACS_INT i1
, EMACS_INT i2
)
786 ? (i1
< 0 ? ((-1 - i1
) / -i2
) + 1 : - (i1
/ -i2
))
787 : (i1
<= 0 ? - (-i1
/ i2
) : ((i1
- 1) / i2
) + 1));
791 floor2 (EMACS_INT i1
, EMACS_INT i2
)
794 ? (i1
<= 0 ? -i1
/ -i2
: -1 - ((i1
- 1) / -i2
))
795 : (i1
< 0 ? -1 - ((-1 - i1
) / i2
) : i1
/ i2
));
799 truncate2 (EMACS_INT i1
, EMACS_INT i2
)
802 ? (i1
< 0 ? -i1
/ -i2
: - (i1
/ -i2
))
803 : (i1
< 0 ? - (-i1
/ i2
) : i1
/ i2
));
807 round2 (EMACS_INT i1
, EMACS_INT i2
)
809 /* The C language's division operator gives us one remainder R, but
810 we want the remainder R1 on the other side of 0 if R1 is closer
811 to 0 than R is; because we want to round to even, we also want R1
812 if R and R1 are the same distance from 0 and if C's quotient is
814 EMACS_INT q
= i1
/ i2
;
815 EMACS_INT r
= i1
% i2
;
816 EMACS_INT abs_r
= r
< 0 ? -r
: r
;
817 EMACS_INT abs_r1
= (i2
< 0 ? -i2
: i2
) - abs_r
;
818 return q
+ (abs_r
+ (q
& 1) <= abs_r1
? 0 : (i2
^ r
) < 0 ? -1 : 1);
821 /* The code uses emacs_rint, so that it works to undefine HAVE_RINT
822 if `rint' exists but does not work right. */
824 #define emacs_rint rint
827 emacs_rint (double d
)
829 return floor (d
+ 0.5);
834 double_identity (double d
)
839 DEFUN ("ceiling", Fceiling
, Sceiling
, 1, 2, 0,
840 doc
: /* Return the smallest integer no less than ARG.
841 This rounds the value towards +inf.
842 With optional DIVISOR, return the smallest integer no less than ARG/DIVISOR. */)
843 (Lisp_Object arg
, Lisp_Object divisor
)
845 return rounding_driver (arg
, divisor
, ceil
, ceiling2
, "ceiling");
848 DEFUN ("floor", Ffloor
, Sfloor
, 1, 2, 0,
849 doc
: /* Return the largest integer no greater than ARG.
850 This rounds the value towards -inf.
851 With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR. */)
852 (Lisp_Object arg
, Lisp_Object divisor
)
854 return rounding_driver (arg
, divisor
, floor
, floor2
, "floor");
857 DEFUN ("round", Fround
, Sround
, 1, 2, 0,
858 doc
: /* Return the nearest integer to ARG.
859 With optional DIVISOR, return the nearest integer to ARG/DIVISOR.
861 Rounding a value equidistant between two integers may choose the
862 integer closer to zero, or it may prefer an even integer, depending on
863 your machine. For example, \(round 2.5\) can return 3 on some
864 systems, but 2 on others. */)
865 (Lisp_Object arg
, Lisp_Object divisor
)
867 return rounding_driver (arg
, divisor
, emacs_rint
, round2
, "round");
870 DEFUN ("truncate", Ftruncate
, Struncate
, 1, 2, 0,
871 doc
: /* Truncate a floating point number to an int.
872 Rounds ARG toward zero.
873 With optional DIVISOR, truncate ARG/DIVISOR. */)
874 (Lisp_Object arg
, Lisp_Object divisor
)
876 return rounding_driver (arg
, divisor
, double_identity
, truncate2
,
882 fmod_float (Lisp_Object x
, Lisp_Object y
)
886 f1
= FLOATP (x
) ? XFLOAT_DATA (x
) : XINT (x
);
887 f2
= FLOATP (y
) ? XFLOAT_DATA (y
) : XINT (y
);
889 if (! IEEE_FLOATING_POINT
&& f2
== 0)
890 xsignal0 (Qarith_error
);
892 /* If the "remainder" comes out with the wrong sign, fix it. */
893 IN_FLOAT2 ((f1
= fmod (f1
, f2
),
894 f1
= (f2
< 0 ? f1
> 0 : f1
< 0) ? f1
+ f2
: f1
),
896 return make_float (f1
);
899 /* It's not clear these are worth adding. */
901 DEFUN ("fceiling", Ffceiling
, Sfceiling
, 1, 1, 0,
902 doc
: /* Return the smallest integer no less than ARG, as a float.
903 \(Round toward +inf.\) */)
904 (register Lisp_Object arg
)
906 double d
= extract_float (arg
);
907 IN_FLOAT (d
= ceil (d
), "fceiling", arg
);
908 return make_float (d
);
911 DEFUN ("ffloor", Fffloor
, Sffloor
, 1, 1, 0,
912 doc
: /* Return the largest integer no greater than ARG, as a float.
913 \(Round towards -inf.\) */)
914 (register Lisp_Object arg
)
916 double d
= extract_float (arg
);
917 IN_FLOAT (d
= floor (d
), "ffloor", arg
);
918 return make_float (d
);
921 DEFUN ("fround", Ffround
, Sfround
, 1, 1, 0,
922 doc
: /* Return the nearest integer to ARG, as a float. */)
923 (register Lisp_Object arg
)
925 double d
= extract_float (arg
);
926 IN_FLOAT (d
= emacs_rint (d
), "fround", arg
);
927 return make_float (d
);
930 DEFUN ("ftruncate", Fftruncate
, Sftruncate
, 1, 1, 0,
931 doc
: /* Truncate a floating point number to an integral float value.
932 Rounds the value toward zero. */)
933 (register Lisp_Object arg
)
935 double d
= extract_float (arg
);
937 IN_FLOAT (d
= floor (d
), "ftruncate", arg
);
939 IN_FLOAT (d
= ceil (d
), "ftruncate", arg
);
940 return make_float (d
);
945 matherr (struct exception
*x
)
948 const char *name
= x
->name
;
951 /* Not called from emacs-lisp float routines; do the default thing. */
953 if (!strcmp (x
->name
, "pow"))
957 = Fcons (build_string (name
),
958 Fcons (make_float (x
->arg1
),
959 ((!strcmp (name
, "log") || !strcmp (name
, "pow"))
960 ? Fcons (make_float (x
->arg2
), Qnil
)
964 case DOMAIN
: xsignal (Qdomain_error
, args
); break;
965 case SING
: xsignal (Qsingularity_error
, args
); break;
966 case OVERFLOW
: xsignal (Qoverflow_error
, args
); break;
967 case UNDERFLOW
: xsignal (Qunderflow_error
, args
); break;
968 default: xsignal (Qarith_error
, args
); break;
970 return (1); /* don't set errno or print a message */
972 #endif /* HAVE_MATHERR */
981 syms_of_floatfns (void)
991 defsubr (&Scopysign
);
1002 defsubr (&Sbessel_y0
);
1003 defsubr (&Sbessel_y1
);
1004 defsubr (&Sbessel_yn
);
1005 defsubr (&Sbessel_j0
);
1006 defsubr (&Sbessel_j1
);
1007 defsubr (&Sbessel_jn
);
1010 defsubr (&Slog_gamma
);
1011 defsubr (&Scube_root
);
1013 defsubr (&Sfceiling
);
1016 defsubr (&Sftruncate
);
1026 defsubr (&Sceiling
);
1029 defsubr (&Struncate
);