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. 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"
53 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
54 #ifndef IEEE_FLOATING_POINT
55 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
56 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
57 #define IEEE_FLOATING_POINT 1
59 #define IEEE_FLOATING_POINT 0
65 /* This declaration is omitted on some systems, like Ultrix. */
66 #if !defined (HPUX) && defined (HAVE_LOGB) && !defined (logb)
67 extern double logb (double);
68 #endif /* not HPUX and HAVE_LOGB and no logb macro */
70 #if defined (DOMAIN) && defined (SING) && defined (OVERFLOW)
71 /* If those are defined, then this is probably a `matherr' machine. */
82 # ifdef FLOAT_CHECK_ERRNO
83 # undef FLOAT_CHECK_ERRNO
85 # ifdef FLOAT_CHECK_DOMAIN
86 # undef FLOAT_CHECK_DOMAIN
90 #ifndef NO_FLOAT_CHECK_ERRNO
91 #define FLOAT_CHECK_ERRNO
94 #ifdef FLOAT_CHECK_ERRNO
98 /* True while executing in floating point.
99 This tells float_error what to do. */
101 static bool in_float
;
103 /* If an argument is out of range for a mathematical function,
104 here is the actual argument value to use in the error message.
105 These variables are used only across the floating point library call
106 so there is no need to staticpro them. */
108 static Lisp_Object float_error_arg
, float_error_arg2
;
110 static const char *float_error_fn_name
;
112 /* Evaluate the floating point expression D, recording NUM
113 as the original argument for error messages.
114 D is normally an assignment expression.
115 Handle errors which may result in signals or may set errno.
117 Note that float_error may be declared to return void, so you can't
118 just cast the zero after the colon to (void) to make the types
121 #ifdef FLOAT_CHECK_ERRNO
122 #define IN_FLOAT(d, name, num) \
124 float_error_arg = num; \
125 float_error_fn_name = name; \
126 in_float = 1; errno = 0; (d); in_float = 0; \
129 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
130 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
131 default: arith_error (float_error_fn_name, float_error_arg); \
134 #define IN_FLOAT2(d, name, num, num2) \
136 float_error_arg = num; \
137 float_error_arg2 = num2; \
138 float_error_fn_name = name; \
139 in_float = 1; errno = 0; (d); in_float = 0; \
142 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
143 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
144 default: arith_error (float_error_fn_name, float_error_arg); \
148 #define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0)
149 #define IN_FLOAT2(d, name, num, num2) (in_float = 1, (d), in_float = 0)
152 /* Convert float to Lisp_Int if it fits, else signal a range error
153 using the given arguments. */
154 #define FLOAT_TO_INT(x, i, name, num) \
157 if (FIXNUM_OVERFLOW_P (x)) \
158 range_error (name, num); \
159 XSETINT (i, (EMACS_INT)(x)); \
162 #define FLOAT_TO_INT2(x, i, name, num1, num2) \
165 if (FIXNUM_OVERFLOW_P (x)) \
166 range_error2 (name, num1, num2); \
167 XSETINT (i, (EMACS_INT)(x)); \
171 #define arith_error(op,arg) \
172 xsignal2 (Qarith_error, build_string ((op)), (arg))
173 #define range_error(op,arg) \
174 xsignal2 (Qrange_error, build_string ((op)), (arg))
175 #define range_error2(op,a1,a2) \
176 xsignal3 (Qrange_error, build_string ((op)), (a1), (a2))
177 #define domain_error(op,arg) \
178 xsignal2 (Qdomain_error, build_string ((op)), (arg))
179 #ifdef FLOAT_CHECK_DOMAIN
180 #define domain_error2(op,a1,a2) \
181 xsignal3 (Qdomain_error, build_string ((op)), (a1), (a2))
184 /* Extract a Lisp number as a `double', or signal an error. */
187 extract_float (Lisp_Object num
)
189 CHECK_NUMBER_OR_FLOAT (num
);
192 return XFLOAT_DATA (num
);
193 return (double) XINT (num
);
196 /* Trig functions. */
198 DEFUN ("acos", Facos
, Sacos
, 1, 1, 0,
199 doc
: /* Return the inverse cosine of ARG. */)
200 (register Lisp_Object arg
)
202 double d
= extract_float (arg
);
203 #ifdef FLOAT_CHECK_DOMAIN
204 if (d
> 1.0 || d
< -1.0)
205 domain_error ("acos", arg
);
207 IN_FLOAT (d
= acos (d
), "acos", arg
);
208 return make_float (d
);
211 DEFUN ("asin", Fasin
, Sasin
, 1, 1, 0,
212 doc
: /* Return the inverse sine of ARG. */)
213 (register Lisp_Object arg
)
215 double d
= extract_float (arg
);
216 #ifdef FLOAT_CHECK_DOMAIN
217 if (d
> 1.0 || d
< -1.0)
218 domain_error ("asin", arg
);
220 IN_FLOAT (d
= asin (d
), "asin", arg
);
221 return make_float (d
);
224 DEFUN ("atan", Fatan
, Satan
, 1, 2, 0,
225 doc
: /* Return the inverse tangent of the arguments.
226 If only one argument Y is given, return the inverse tangent of Y.
227 If two arguments Y and X are given, return the inverse tangent of Y
228 divided by X, i.e. the angle in radians between the vector (X, Y)
230 (register Lisp_Object y
, Lisp_Object x
)
232 double d
= extract_float (y
);
235 IN_FLOAT (d
= atan (d
), "atan", y
);
238 double d2
= extract_float (x
);
240 IN_FLOAT2 (d
= atan2 (d
, d2
), "atan", y
, x
);
242 return make_float (d
);
245 DEFUN ("cos", Fcos
, Scos
, 1, 1, 0,
246 doc
: /* Return the cosine of ARG. */)
247 (register Lisp_Object arg
)
249 double d
= extract_float (arg
);
250 IN_FLOAT (d
= cos (d
), "cos", arg
);
251 return make_float (d
);
254 DEFUN ("sin", Fsin
, Ssin
, 1, 1, 0,
255 doc
: /* Return the sine of ARG. */)
256 (register Lisp_Object arg
)
258 double d
= extract_float (arg
);
259 IN_FLOAT (d
= sin (d
), "sin", arg
);
260 return make_float (d
);
263 DEFUN ("tan", Ftan
, Stan
, 1, 1, 0,
264 doc
: /* Return the tangent of ARG. */)
265 (register Lisp_Object arg
)
267 double d
= extract_float (arg
);
268 #ifdef FLOAT_CHECK_DOMAIN
271 domain_error ("tan", arg
);
273 IN_FLOAT (d
= tan (d
), "tan", arg
);
274 return make_float (d
);
278 #define isnan(x) ((x) != (x))
280 DEFUN ("isnan", Fisnan
, Sisnan
, 1, 1, 0,
281 doc
: /* Return non nil iff argument X is a NaN. */)
285 return isnan (XFLOAT_DATA (x
)) ? Qt
: Qnil
;
289 DEFUN ("copysign", Fcopysign
, Scopysign
, 2, 2, 0,
290 doc
: /* Copy sign of X2 to value of X1, and return the result.
291 Cause an error if X1 or X2 is not a float. */)
292 (Lisp_Object x1
, Lisp_Object x2
)
299 f1
= XFLOAT_DATA (x1
);
300 f2
= XFLOAT_DATA (x2
);
302 return make_float (copysign (f1
, f2
));
305 DEFUN ("frexp", Ffrexp
, Sfrexp
, 1, 1, 0,
306 doc
: /* Get significand and exponent of a floating point number.
307 Breaks the floating point number X into its binary significand SGNFCAND
308 \(a floating point value between 0.5 (included) and 1.0 (excluded))
309 and an integral exponent EXP for 2, such that:
313 The function returns the cons cell (SGNFCAND . EXP).
314 If X is zero, both parts (SGNFCAND and EXP) are zero. */)
317 double f
= XFLOATINT (x
);
320 return Fcons (make_float (0.0), make_number (0));
324 double sgnfcand
= frexp (f
, &exponent
);
325 return Fcons (make_float (sgnfcand
), make_number (exponent
));
329 DEFUN ("ldexp", Fldexp
, Sldexp
, 1, 2, 0,
330 doc
: /* Construct number X from significand SGNFCAND and exponent EXP.
331 Returns the floating point value resulting from multiplying SGNFCAND
332 (the significand) by 2 raised to the power of EXP (the exponent). */)
333 (Lisp_Object sgnfcand
, Lisp_Object exponent
)
335 CHECK_NUMBER (exponent
);
336 return make_float (ldexp (XFLOATINT (sgnfcand
), XINT (exponent
)));
340 #if 0 /* Leave these out unless we find there's a reason for them. */
342 DEFUN ("bessel-j0", Fbessel_j0
, Sbessel_j0
, 1, 1, 0,
343 doc
: /* Return the bessel function j0 of ARG. */)
344 (register Lisp_Object arg
)
346 double d
= extract_float (arg
);
347 IN_FLOAT (d
= j0 (d
), "bessel-j0", arg
);
348 return make_float (d
);
351 DEFUN ("bessel-j1", Fbessel_j1
, Sbessel_j1
, 1, 1, 0,
352 doc
: /* Return the bessel function j1 of ARG. */)
353 (register Lisp_Object arg
)
355 double d
= extract_float (arg
);
356 IN_FLOAT (d
= j1 (d
), "bessel-j1", arg
);
357 return make_float (d
);
360 DEFUN ("bessel-jn", Fbessel_jn
, Sbessel_jn
, 2, 2, 0,
361 doc
: /* Return the order N bessel function output jn of ARG.
362 The first arg (the order) is truncated to an integer. */)
363 (register Lisp_Object n
, Lisp_Object arg
)
365 int i1
= extract_float (n
);
366 double f2
= extract_float (arg
);
368 IN_FLOAT (f2
= jn (i1
, f2
), "bessel-jn", n
);
369 return make_float (f2
);
372 DEFUN ("bessel-y0", Fbessel_y0
, Sbessel_y0
, 1, 1, 0,
373 doc
: /* Return the bessel function y0 of ARG. */)
374 (register Lisp_Object arg
)
376 double d
= extract_float (arg
);
377 IN_FLOAT (d
= y0 (d
), "bessel-y0", arg
);
378 return make_float (d
);
381 DEFUN ("bessel-y1", Fbessel_y1
, Sbessel_y1
, 1, 1, 0,
382 doc
: /* Return the bessel function y1 of ARG. */)
383 (register Lisp_Object arg
)
385 double d
= extract_float (arg
);
386 IN_FLOAT (d
= y1 (d
), "bessel-y0", arg
);
387 return make_float (d
);
390 DEFUN ("bessel-yn", Fbessel_yn
, Sbessel_yn
, 2, 2, 0,
391 doc
: /* Return the order N bessel function output yn of ARG.
392 The first arg (the order) is truncated to an integer. */)
393 (register Lisp_Object n
, Lisp_Object arg
)
395 int i1
= extract_float (n
);
396 double f2
= extract_float (arg
);
398 IN_FLOAT (f2
= yn (i1
, f2
), "bessel-yn", n
);
399 return make_float (f2
);
404 #if 0 /* Leave these out unless we see they are worth having. */
406 DEFUN ("erf", Ferf
, Serf
, 1, 1, 0,
407 doc
: /* Return the mathematical error function of ARG. */)
408 (register Lisp_Object arg
)
410 double d
= extract_float (arg
);
411 IN_FLOAT (d
= erf (d
), "erf", arg
);
412 return make_float (d
);
415 DEFUN ("erfc", Ferfc
, Serfc
, 1, 1, 0,
416 doc
: /* Return the complementary error function of ARG. */)
417 (register Lisp_Object arg
)
419 double d
= extract_float (arg
);
420 IN_FLOAT (d
= erfc (d
), "erfc", arg
);
421 return make_float (d
);
424 DEFUN ("log-gamma", Flog_gamma
, Slog_gamma
, 1, 1, 0,
425 doc
: /* Return the log gamma of ARG. */)
426 (register Lisp_Object arg
)
428 double d
= extract_float (arg
);
429 IN_FLOAT (d
= lgamma (d
), "log-gamma", arg
);
430 return make_float (d
);
433 DEFUN ("cube-root", Fcube_root
, Scube_root
, 1, 1, 0,
434 doc
: /* Return the cube root of ARG. */)
435 (register Lisp_Object arg
)
437 double d
= extract_float (arg
);
439 IN_FLOAT (d
= cbrt (d
), "cube-root", arg
);
442 IN_FLOAT (d
= pow (d
, 1.0/3.0), "cube-root", arg
);
444 IN_FLOAT (d
= -pow (-d
, 1.0/3.0), "cube-root", arg
);
446 return make_float (d
);
451 DEFUN ("exp", Fexp
, Sexp
, 1, 1, 0,
452 doc
: /* Return the exponential base e of ARG. */)
453 (register Lisp_Object arg
)
455 double d
= extract_float (arg
);
456 #ifdef FLOAT_CHECK_DOMAIN
457 if (d
> 709.7827) /* Assume IEEE doubles here */
458 range_error ("exp", arg
);
460 return make_float (0.0);
463 IN_FLOAT (d
= exp (d
), "exp", arg
);
464 return make_float (d
);
467 DEFUN ("expt", Fexpt
, Sexpt
, 2, 2, 0,
468 doc
: /* Return the exponential ARG1 ** ARG2. */)
469 (register Lisp_Object arg1
, Lisp_Object arg2
)
473 CHECK_NUMBER_OR_FLOAT (arg1
);
474 CHECK_NUMBER_OR_FLOAT (arg2
);
475 if (INTEGERP (arg1
) /* common lisp spec */
476 && INTEGERP (arg2
) /* don't promote, if both are ints, and */
477 && 0 <= XINT (arg2
)) /* we are sure the result is not fractional */
478 { /* this can be improved by pre-calculating */
479 EMACS_INT y
; /* some binary powers of x then accumulating */
480 EMACS_UINT acc
, x
; /* Unsigned so that overflow is well defined. */
485 acc
= (y
& 1 ? x
: 1);
487 while ((y
>>= 1) != 0)
496 f1
= FLOATP (arg1
) ? XFLOAT_DATA (arg1
) : XINT (arg1
);
497 f2
= FLOATP (arg2
) ? XFLOAT_DATA (arg2
) : XINT (arg2
);
498 /* Really should check for overflow, too */
499 if (f1
== 0.0 && f2
== 0.0)
501 #ifdef FLOAT_CHECK_DOMAIN
502 else if ((f1
== 0.0 && f2
< 0.0) || (f1
< 0 && f2
!= floor (f2
)))
503 domain_error2 ("expt", arg1
, arg2
);
505 IN_FLOAT2 (f3
= pow (f1
, f2
), "expt", arg1
, arg2
);
506 /* Check for overflow in the result. */
507 if (f1
!= 0.0 && f3
== 0.0)
508 range_error ("expt", arg1
);
509 return make_float (f3
);
512 DEFUN ("log", Flog
, Slog
, 1, 2, 0,
513 doc
: /* Return the natural logarithm of ARG.
514 If the optional argument BASE is given, return log ARG using that base. */)
515 (register Lisp_Object arg
, Lisp_Object base
)
517 double d
= extract_float (arg
);
519 #ifdef FLOAT_CHECK_DOMAIN
521 domain_error2 ("log", arg
, base
);
524 IN_FLOAT (d
= log (d
), "log", arg
);
527 double b
= extract_float (base
);
529 #ifdef FLOAT_CHECK_DOMAIN
530 if (b
<= 0.0 || b
== 1.0)
531 domain_error2 ("log", arg
, base
);
534 IN_FLOAT2 (d
= log10 (d
), "log", arg
, base
);
536 IN_FLOAT2 (d
= log (d
) / log (b
), "log", arg
, base
);
538 return make_float (d
);
541 DEFUN ("log10", Flog10
, Slog10
, 1, 1, 0,
542 doc
: /* Return the logarithm base 10 of ARG. */)
543 (register Lisp_Object arg
)
545 double d
= extract_float (arg
);
546 #ifdef FLOAT_CHECK_DOMAIN
548 domain_error ("log10", arg
);
550 IN_FLOAT (d
= log10 (d
), "log10", arg
);
551 return make_float (d
);
554 DEFUN ("sqrt", Fsqrt
, Ssqrt
, 1, 1, 0,
555 doc
: /* Return the square root of ARG. */)
556 (register Lisp_Object arg
)
558 double d
= extract_float (arg
);
559 #ifdef FLOAT_CHECK_DOMAIN
561 domain_error ("sqrt", arg
);
563 IN_FLOAT (d
= sqrt (d
), "sqrt", arg
);
564 return make_float (d
);
567 #if 0 /* Not clearly worth adding. */
569 DEFUN ("acosh", Facosh
, Sacosh
, 1, 1, 0,
570 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. */)
588 (register Lisp_Object arg
)
590 double d
= extract_float (arg
);
591 #ifdef HAVE_INVERSE_HYPERBOLIC
592 IN_FLOAT (d
= asinh (d
), "asinh", arg
);
594 IN_FLOAT (d
= log (d
+ sqrt (d
*d
+ 1.0)), "asinh", arg
);
596 return make_float (d
);
599 DEFUN ("atanh", Fatanh
, Satanh
, 1, 1, 0,
600 doc
: /* Return the inverse hyperbolic tangent of ARG. */)
601 (register Lisp_Object arg
)
603 double d
= extract_float (arg
);
604 #ifdef FLOAT_CHECK_DOMAIN
605 if (d
>= 1.0 || d
<= -1.0)
606 domain_error ("atanh", arg
);
608 #ifdef HAVE_INVERSE_HYPERBOLIC
609 IN_FLOAT (d
= atanh (d
), "atanh", arg
);
611 IN_FLOAT (d
= 0.5 * log ((1.0 + d
) / (1.0 - d
)), "atanh", arg
);
613 return make_float (d
);
616 DEFUN ("cosh", Fcosh
, Scosh
, 1, 1, 0,
617 doc
: /* Return the hyperbolic cosine of ARG. */)
618 (register Lisp_Object arg
)
620 double d
= extract_float (arg
);
621 #ifdef FLOAT_CHECK_DOMAIN
622 if (d
> 710.0 || d
< -710.0)
623 range_error ("cosh", arg
);
625 IN_FLOAT (d
= cosh (d
), "cosh", arg
);
626 return make_float (d
);
629 DEFUN ("sinh", Fsinh
, Ssinh
, 1, 1, 0,
630 doc
: /* Return the hyperbolic sine of ARG. */)
631 (register Lisp_Object arg
)
633 double d
= extract_float (arg
);
634 #ifdef FLOAT_CHECK_DOMAIN
635 if (d
> 710.0 || d
< -710.0)
636 range_error ("sinh", arg
);
638 IN_FLOAT (d
= sinh (d
), "sinh", arg
);
639 return make_float (d
);
642 DEFUN ("tanh", Ftanh
, Stanh
, 1, 1, 0,
643 doc
: /* Return the hyperbolic tangent of ARG. */)
644 (register Lisp_Object arg
)
646 double d
= extract_float (arg
);
647 IN_FLOAT (d
= tanh (d
), "tanh", arg
);
648 return make_float (d
);
652 DEFUN ("abs", Fabs
, Sabs
, 1, 1, 0,
653 doc
: /* Return the absolute value of ARG. */)
654 (register Lisp_Object arg
)
656 CHECK_NUMBER_OR_FLOAT (arg
);
659 arg
= make_float (fabs (XFLOAT_DATA (arg
)));
660 else if (XINT (arg
) < 0)
661 XSETINT (arg
, - XINT (arg
));
666 DEFUN ("float", Ffloat
, Sfloat
, 1, 1, 0,
667 doc
: /* Return the floating point number equal to ARG. */)
668 (register Lisp_Object arg
)
670 CHECK_NUMBER_OR_FLOAT (arg
);
673 return make_float ((double) XINT (arg
));
674 else /* give 'em the same float back */
678 DEFUN ("logb", Flogb
, Slogb
, 1, 1, 0,
679 doc
: /* Returns largest integer <= the base 2 log of the magnitude of ARG.
680 This is the same as the exponent of a float. */)
685 double f
= extract_float (arg
);
688 value
= MOST_NEGATIVE_FIXNUM
;
692 IN_FLOAT (value
= logb (f
), "logb", arg
);
696 IN_FLOAT (frexp (f
, &ivalue
), "logb", arg
);
706 for (i
= 1, d
= 0.5; d
* d
>= f
; i
+= i
)
713 for (i
= 1, d
= 2.0; d
* d
<= f
; i
+= i
)
721 XSETINT (val
, value
);
726 /* the rounding functions */
729 rounding_driver (Lisp_Object arg
, Lisp_Object divisor
,
730 double (*double_round
) (double),
731 EMACS_INT (*int_round2
) (EMACS_INT
, EMACS_INT
),
734 CHECK_NUMBER_OR_FLOAT (arg
);
736 if (! NILP (divisor
))
740 CHECK_NUMBER_OR_FLOAT (divisor
);
742 if (FLOATP (arg
) || FLOATP (divisor
))
746 f1
= FLOATP (arg
) ? XFLOAT_DATA (arg
) : XINT (arg
);
747 f2
= (FLOATP (divisor
) ? XFLOAT_DATA (divisor
) : XINT (divisor
));
748 if (! IEEE_FLOATING_POINT
&& f2
== 0)
749 xsignal0 (Qarith_error
);
751 IN_FLOAT2 (f1
= (*double_round
) (f1
/ f2
), name
, arg
, divisor
);
752 FLOAT_TO_INT2 (f1
, arg
, name
, arg
, divisor
);
760 xsignal0 (Qarith_error
);
762 XSETINT (arg
, (*int_round2
) (i1
, i2
));
770 IN_FLOAT (d
= (*double_round
) (XFLOAT_DATA (arg
)), name
, arg
);
771 FLOAT_TO_INT (d
, arg
, name
, arg
);
777 /* With C's /, the result is implementation-defined if either operand
778 is negative, so take care with negative operands in the following
779 integer functions. */
782 ceiling2 (EMACS_INT i1
, EMACS_INT i2
)
785 ? (i1
< 0 ? ((-1 - i1
) / -i2
) + 1 : - (i1
/ -i2
))
786 : (i1
<= 0 ? - (-i1
/ i2
) : ((i1
- 1) / i2
) + 1));
790 floor2 (EMACS_INT i1
, EMACS_INT i2
)
793 ? (i1
<= 0 ? -i1
/ -i2
: -1 - ((i1
- 1) / -i2
))
794 : (i1
< 0 ? -1 - ((-1 - i1
) / i2
) : i1
/ i2
));
798 truncate2 (EMACS_INT i1
, EMACS_INT i2
)
801 ? (i1
< 0 ? -i1
/ -i2
: - (i1
/ -i2
))
802 : (i1
< 0 ? - (-i1
/ i2
) : i1
/ i2
));
806 round2 (EMACS_INT i1
, EMACS_INT i2
)
808 /* The C language's division operator gives us one remainder R, but
809 we want the remainder R1 on the other side of 0 if R1 is closer
810 to 0 than R is; because we want to round to even, we also want R1
811 if R and R1 are the same distance from 0 and if C's quotient is
813 EMACS_INT q
= i1
/ i2
;
814 EMACS_INT r
= i1
% i2
;
815 EMACS_INT abs_r
= r
< 0 ? -r
: r
;
816 EMACS_INT abs_r1
= (i2
< 0 ? -i2
: i2
) - abs_r
;
817 return q
+ (abs_r
+ (q
& 1) <= abs_r1
? 0 : (i2
^ r
) < 0 ? -1 : 1);
820 /* The code uses emacs_rint, so that it works to undefine HAVE_RINT
821 if `rint' exists but does not work right. */
823 #define emacs_rint rint
826 emacs_rint (double d
)
828 return floor (d
+ 0.5);
833 double_identity (double d
)
838 DEFUN ("ceiling", Fceiling
, Sceiling
, 1, 2, 0,
839 doc
: /* Return the smallest integer no less than ARG.
840 This rounds the value towards +inf.
841 With optional DIVISOR, return the smallest integer no less than ARG/DIVISOR. */)
842 (Lisp_Object arg
, Lisp_Object divisor
)
844 return rounding_driver (arg
, divisor
, ceil
, ceiling2
, "ceiling");
847 DEFUN ("floor", Ffloor
, Sfloor
, 1, 2, 0,
848 doc
: /* Return the largest integer no greater than ARG.
849 This rounds the value towards -inf.
850 With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR. */)
851 (Lisp_Object arg
, Lisp_Object divisor
)
853 return rounding_driver (arg
, divisor
, floor
, floor2
, "floor");
856 DEFUN ("round", Fround
, Sround
, 1, 2, 0,
857 doc
: /* Return the nearest integer to ARG.
858 With optional DIVISOR, return the nearest integer to ARG/DIVISOR.
860 Rounding a value equidistant between two integers may choose the
861 integer closer to zero, or it may prefer an even integer, depending on
862 your machine. For example, \(round 2.5\) can return 3 on some
863 systems, but 2 on others. */)
864 (Lisp_Object arg
, Lisp_Object divisor
)
866 return rounding_driver (arg
, divisor
, emacs_rint
, round2
, "round");
869 DEFUN ("truncate", Ftruncate
, Struncate
, 1, 2, 0,
870 doc
: /* Truncate a floating point number to an int.
871 Rounds ARG toward zero.
872 With optional DIVISOR, truncate ARG/DIVISOR. */)
873 (Lisp_Object arg
, Lisp_Object divisor
)
875 return rounding_driver (arg
, divisor
, double_identity
, truncate2
,
881 fmod_float (Lisp_Object x
, Lisp_Object y
)
885 f1
= FLOATP (x
) ? XFLOAT_DATA (x
) : XINT (x
);
886 f2
= FLOATP (y
) ? XFLOAT_DATA (y
) : XINT (y
);
888 if (! IEEE_FLOATING_POINT
&& f2
== 0)
889 xsignal0 (Qarith_error
);
891 /* If the "remainder" comes out with the wrong sign, fix it. */
892 IN_FLOAT2 ((f1
= fmod (f1
, f2
),
893 f1
= (f2
< 0 ? f1
> 0 : f1
< 0) ? f1
+ f2
: f1
),
895 return make_float (f1
);
898 /* It's not clear these are worth adding. */
900 DEFUN ("fceiling", Ffceiling
, Sfceiling
, 1, 1, 0,
901 doc
: /* Return the smallest integer no less than ARG, as a float.
902 \(Round toward +inf.\) */)
903 (register Lisp_Object arg
)
905 double d
= extract_float (arg
);
906 IN_FLOAT (d
= ceil (d
), "fceiling", arg
);
907 return make_float (d
);
910 DEFUN ("ffloor", Fffloor
, Sffloor
, 1, 1, 0,
911 doc
: /* Return the largest integer no greater than ARG, as a float.
912 \(Round towards -inf.\) */)
913 (register Lisp_Object arg
)
915 double d
= extract_float (arg
);
916 IN_FLOAT (d
= floor (d
), "ffloor", arg
);
917 return make_float (d
);
920 DEFUN ("fround", Ffround
, Sfround
, 1, 1, 0,
921 doc
: /* Return the nearest integer to ARG, as a float. */)
922 (register Lisp_Object arg
)
924 double d
= extract_float (arg
);
925 IN_FLOAT (d
= emacs_rint (d
), "fround", arg
);
926 return make_float (d
);
929 DEFUN ("ftruncate", Fftruncate
, Sftruncate
, 1, 1, 0,
930 doc
: /* Truncate a floating point number to an integral float value.
931 Rounds the value toward zero. */)
932 (register Lisp_Object arg
)
934 double d
= extract_float (arg
);
936 IN_FLOAT (d
= floor (d
), "ftruncate", arg
);
938 IN_FLOAT (d
= ceil (d
), "ftruncate", arg
);
939 return make_float (d
);
944 matherr (struct exception
*x
)
947 const char *name
= x
->name
;
950 /* Not called from emacs-lisp float routines; do the default thing. */
952 if (!strcmp (x
->name
, "pow"))
956 = Fcons (build_string (name
),
957 Fcons (make_float (x
->arg1
),
958 ((!strcmp (name
, "log") || !strcmp (name
, "pow"))
959 ? Fcons (make_float (x
->arg2
), Qnil
)
963 case DOMAIN
: xsignal (Qdomain_error
, args
); break;
964 case SING
: xsignal (Qsingularity_error
, args
); break;
965 case OVERFLOW
: xsignal (Qoverflow_error
, args
); break;
966 case UNDERFLOW
: xsignal (Qunderflow_error
, args
); break;
967 default: xsignal (Qarith_error
, args
); break;
969 return (1); /* don't set errno or print a message */
971 #endif /* HAVE_MATHERR */
980 syms_of_floatfns (void)
990 defsubr (&Scopysign
);
1001 defsubr (&Sbessel_y0
);
1002 defsubr (&Sbessel_y1
);
1003 defsubr (&Sbessel_yn
);
1004 defsubr (&Sbessel_j0
);
1005 defsubr (&Sbessel_j1
);
1006 defsubr (&Sbessel_jn
);
1009 defsubr (&Slog_gamma
);
1010 defsubr (&Scube_root
);
1012 defsubr (&Sfceiling
);
1015 defsubr (&Sftruncate
);
1025 defsubr (&Sceiling
);
1028 defsubr (&Struncate
);