1 /* Primitive operations on floating point for GNU Emacs Lisp interpreter.
2 Copyright (C) 1988, 1993, 1994 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
22 /* ANSI C requires only these float functions:
23 acos, asin, atan, atan2, ceil, cos, cosh, exp, fabs, floor, fmod,
24 frexp, ldexp, log, log10, modf, pow, sin, sinh, sqrt, tan, tanh.
26 Define HAVE_INVERSE_HYPERBOLIC if you have acosh, asinh, and atanh.
27 Define HAVE_CBRT if you have cbrt.
28 Define HAVE_RINT if you have a working rint.
29 If you don't define these, then the appropriate routines will be simulated.
31 Define HAVE_MATHERR if on a system supporting the SysV matherr callback.
32 (This should happen automatically.)
34 Define FLOAT_CHECK_ERRNO if the float library routines set errno.
35 This has no effect if HAVE_MATHERR is defined.
37 Define FLOAT_CATCH_SIGILL if the float library routines signal SIGILL.
38 (What systems actually do this? Please let us know.)
40 Define FLOAT_CHECK_DOMAIN if the float library doesn't handle errors by
41 either setting errno, or signaling SIGFPE/SIGILL. Otherwise, domain and
42 range checking will happen before calling the float routines. This has
43 no effect if HAVE_MATHERR is defined (since matherr will be called when
44 a domain error occurs.)
51 /* Put this before lisp.h so that lisp.h can define DBL_DIG if not defined. */
57 #include "syssignal.h"
59 #ifdef LISP_FLOAT_TYPE
61 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
62 #ifndef IEEE_FLOATING_POINT
63 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
64 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
65 #define IEEE_FLOATING_POINT 1
67 #define IEEE_FLOATING_POINT 0
71 /* Work around a problem that happens because math.h on hpux 7
72 defines two static variables--which, in Emacs, are not really static,
73 because `static' is defined as nothing. The problem is that they are
74 defined both here and in lread.c.
75 These macros prevent the name conflict. */
76 #if defined (HPUX) && !defined (HPUX8)
77 #define _MAXLDBL floatfns_maxldbl
78 #define _NMAXLDBL floatfns_nmaxldbl
83 /* This declaration is omitted on some systems, like Ultrix. */
84 #if !defined (HPUX) && defined (HAVE_LOGB) && !defined (logb)
85 extern double logb ();
86 #endif /* not HPUX and HAVE_LOGB and no logb macro */
88 #if defined(DOMAIN) && defined(SING) && defined(OVERFLOW)
89 /* If those are defined, then this is probably a `matherr' machine. */
100 # ifdef FLOAT_CHECK_ERRNO
101 # undef FLOAT_CHECK_ERRNO
103 # ifdef FLOAT_CHECK_DOMAIN
104 # undef FLOAT_CHECK_DOMAIN
108 #ifndef NO_FLOAT_CHECK_ERRNO
109 #define FLOAT_CHECK_ERRNO
112 #ifdef FLOAT_CHECK_ERRNO
118 /* Avoid traps on VMS from sinh and cosh.
119 All the other functions set errno instead. */
124 #define cosh(x) ((exp(x)+exp(-x))*0.5)
125 #define sinh(x) ((exp(x)-exp(-x))*0.5)
128 static SIGTYPE
float_error ();
130 /* Nonzero while executing in floating point.
131 This tells float_error what to do. */
135 /* If an argument is out of range for a mathematical function,
136 here is the actual argument value to use in the error message.
137 These variables are used only across the floating point library call
138 so there is no need to staticpro them. */
140 static Lisp_Object float_error_arg
, float_error_arg2
;
142 static char *float_error_fn_name
;
144 /* Evaluate the floating point expression D, recording NUM
145 as the original argument for error messages.
146 D is normally an assignment expression.
147 Handle errors which may result in signals or may set errno.
149 Note that float_error may be declared to return void, so you can't
150 just cast the zero after the colon to (SIGTYPE) to make the types
153 #ifdef FLOAT_CHECK_ERRNO
154 #define IN_FLOAT(d, name, num) \
156 float_error_arg = num; \
157 float_error_fn_name = name; \
158 in_float = 1; errno = 0; (d); in_float = 0; \
161 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
162 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
163 default: arith_error (float_error_fn_name, float_error_arg); \
166 #define IN_FLOAT2(d, name, num, num2) \
168 float_error_arg = num; \
169 float_error_arg2 = num2; \
170 float_error_fn_name = name; \
171 in_float = 1; errno = 0; (d); in_float = 0; \
174 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
175 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
176 default: arith_error (float_error_fn_name, float_error_arg); \
180 #define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0)
181 #define IN_FLOAT2(d, name, num, num2) (in_float = 1, (d), in_float = 0)
184 /* Convert float to Lisp_Int if it fits, else signal a range error
185 using the given arguments. */
186 #define FLOAT_TO_INT(x, i, name, num) \
189 if ((x) >= (((EMACS_INT) 1) << (VALBITS-1)) || \
190 (x) <= - (((EMACS_INT) 1) << (VALBITS-1)) - 1) \
191 range_error (name, num); \
192 XSETINT (i, (EMACS_INT)(x)); \
195 #define FLOAT_TO_INT2(x, i, name, num1, num2) \
198 if ((x) >= (((EMACS_INT) 1) << (VALBITS-1)) || \
199 (x) <= - (((EMACS_INT) 1) << (VALBITS-1)) - 1) \
200 range_error2 (name, num1, num2); \
201 XSETINT (i, (EMACS_INT)(x)); \
205 #define arith_error(op,arg) \
206 Fsignal (Qarith_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
207 #define range_error(op,arg) \
208 Fsignal (Qrange_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
209 #define range_error2(op,a1,a2) \
210 Fsignal (Qrange_error, Fcons (build_string ((op)), \
211 Fcons ((a1), Fcons ((a2), Qnil))))
212 #define domain_error(op,arg) \
213 Fsignal (Qdomain_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
214 #define domain_error2(op,a1,a2) \
215 Fsignal (Qdomain_error, Fcons (build_string ((op)), \
216 Fcons ((a1), Fcons ((a2), Qnil))))
218 /* Extract a Lisp number as a `double', or signal an error. */
224 CHECK_NUMBER_OR_FLOAT (num
, 0);
227 return XFLOAT (num
)->data
;
228 return (double) XINT (num
);
231 /* Trig functions. */
233 DEFUN ("acos", Facos
, Sacos
, 1, 1, 0,
234 "Return the inverse cosine of ARG.")
236 register Lisp_Object arg
;
238 double d
= extract_float (arg
);
239 #ifdef FLOAT_CHECK_DOMAIN
240 if (d
> 1.0 || d
< -1.0)
241 domain_error ("acos", arg
);
243 IN_FLOAT (d
= acos (d
), "acos", arg
);
244 return make_float (d
);
247 DEFUN ("asin", Fasin
, Sasin
, 1, 1, 0,
248 "Return the inverse sine of ARG.")
250 register Lisp_Object arg
;
252 double d
= extract_float (arg
);
253 #ifdef FLOAT_CHECK_DOMAIN
254 if (d
> 1.0 || d
< -1.0)
255 domain_error ("asin", arg
);
257 IN_FLOAT (d
= asin (d
), "asin", arg
);
258 return make_float (d
);
261 DEFUN ("atan", Fatan
, Satan
, 1, 1, 0,
262 "Return the inverse tangent of ARG.")
264 register Lisp_Object arg
;
266 double d
= extract_float (arg
);
267 IN_FLOAT (d
= atan (d
), "atan", arg
);
268 return make_float (d
);
271 DEFUN ("cos", Fcos
, Scos
, 1, 1, 0,
272 "Return the cosine of ARG.")
274 register Lisp_Object arg
;
276 double d
= extract_float (arg
);
277 IN_FLOAT (d
= cos (d
), "cos", arg
);
278 return make_float (d
);
281 DEFUN ("sin", Fsin
, Ssin
, 1, 1, 0,
282 "Return the sine of ARG.")
284 register Lisp_Object arg
;
286 double d
= extract_float (arg
);
287 IN_FLOAT (d
= sin (d
), "sin", arg
);
288 return make_float (d
);
291 DEFUN ("tan", Ftan
, Stan
, 1, 1, 0,
292 "Return the tangent of ARG.")
294 register Lisp_Object arg
;
296 double d
= extract_float (arg
);
298 #ifdef FLOAT_CHECK_DOMAIN
300 domain_error ("tan", arg
);
302 IN_FLOAT (d
= sin (d
) / c
, "tan", arg
);
303 return make_float (d
);
306 #if 0 /* Leave these out unless we find there's a reason for them. */
308 DEFUN ("bessel-j0", Fbessel_j0
, Sbessel_j0
, 1, 1, 0,
309 "Return the bessel function j0 of ARG.")
311 register Lisp_Object arg
;
313 double d
= extract_float (arg
);
314 IN_FLOAT (d
= j0 (d
), "bessel-j0", arg
);
315 return make_float (d
);
318 DEFUN ("bessel-j1", Fbessel_j1
, Sbessel_j1
, 1, 1, 0,
319 "Return the bessel function j1 of ARG.")
321 register Lisp_Object arg
;
323 double d
= extract_float (arg
);
324 IN_FLOAT (d
= j1 (d
), "bessel-j1", arg
);
325 return make_float (d
);
328 DEFUN ("bessel-jn", Fbessel_jn
, Sbessel_jn
, 2, 2, 0,
329 "Return the order N bessel function output jn of ARG.\n\
330 The first arg (the order) is truncated to an integer.")
332 register Lisp_Object n
, arg
;
334 int i1
= extract_float (n
);
335 double f2
= extract_float (arg
);
337 IN_FLOAT (f2
= jn (i1
, f2
), "bessel-jn", n
);
338 return make_float (f2
);
341 DEFUN ("bessel-y0", Fbessel_y0
, Sbessel_y0
, 1, 1, 0,
342 "Return the bessel function y0 of ARG.")
344 register Lisp_Object arg
;
346 double d
= extract_float (arg
);
347 IN_FLOAT (d
= y0 (d
), "bessel-y0", arg
);
348 return make_float (d
);
351 DEFUN ("bessel-y1", Fbessel_y1
, Sbessel_y1
, 1, 1, 0,
352 "Return the bessel function y1 of ARG.")
354 register Lisp_Object arg
;
356 double d
= extract_float (arg
);
357 IN_FLOAT (d
= y1 (d
), "bessel-y0", arg
);
358 return make_float (d
);
361 DEFUN ("bessel-yn", Fbessel_yn
, Sbessel_yn
, 2, 2, 0,
362 "Return the order N bessel function output yn of ARG.\n\
363 The first arg (the order) is truncated to an integer.")
365 register Lisp_Object n
, arg
;
367 int i1
= extract_float (n
);
368 double f2
= extract_float (arg
);
370 IN_FLOAT (f2
= yn (i1
, f2
), "bessel-yn", n
);
371 return make_float (f2
);
376 #if 0 /* Leave these out unless we see they are worth having. */
378 DEFUN ("erf", Ferf
, Serf
, 1, 1, 0,
379 "Return the mathematical error function of ARG.")
381 register Lisp_Object arg
;
383 double d
= extract_float (arg
);
384 IN_FLOAT (d
= erf (d
), "erf", arg
);
385 return make_float (d
);
388 DEFUN ("erfc", Ferfc
, Serfc
, 1, 1, 0,
389 "Return the complementary error function of ARG.")
391 register Lisp_Object arg
;
393 double d
= extract_float (arg
);
394 IN_FLOAT (d
= erfc (d
), "erfc", arg
);
395 return make_float (d
);
398 DEFUN ("log-gamma", Flog_gamma
, Slog_gamma
, 1, 1, 0,
399 "Return the log gamma of ARG.")
401 register Lisp_Object arg
;
403 double d
= extract_float (arg
);
404 IN_FLOAT (d
= lgamma (d
), "log-gamma", arg
);
405 return make_float (d
);
408 DEFUN ("cube-root", Fcube_root
, Scube_root
, 1, 1, 0,
409 "Return the cube root of ARG.")
411 register Lisp_Object arg
;
413 double d
= extract_float (arg
);
415 IN_FLOAT (d
= cbrt (d
), "cube-root", arg
);
418 IN_FLOAT (d
= pow (d
, 1.0/3.0), "cube-root", arg
);
420 IN_FLOAT (d
= -pow (-d
, 1.0/3.0), "cube-root", arg
);
422 return make_float (d
);
427 DEFUN ("exp", Fexp
, Sexp
, 1, 1, 0,
428 "Return the exponential base e of ARG.")
430 register Lisp_Object arg
;
432 double d
= extract_float (arg
);
433 #ifdef FLOAT_CHECK_DOMAIN
434 if (d
> 709.7827) /* Assume IEEE doubles here */
435 range_error ("exp", arg
);
437 return make_float (0.0);
440 IN_FLOAT (d
= exp (d
), "exp", arg
);
441 return make_float (d
);
444 DEFUN ("expt", Fexpt
, Sexpt
, 2, 2, 0,
445 "Return the exponential ARG1 ** ARG2.")
447 register Lisp_Object arg1
, arg2
;
451 CHECK_NUMBER_OR_FLOAT (arg1
, 0);
452 CHECK_NUMBER_OR_FLOAT (arg2
, 0);
453 if (INTEGERP (arg1
) /* common lisp spec */
454 && INTEGERP (arg2
)) /* don't promote, if both are ints */
455 { /* this can be improved by pre-calculating */
456 EMACS_INT acc
, x
, y
; /* some binary powers of x then accumulating */
468 acc
= (y
& 1) ? -1 : 1;
479 y
= (unsigned)y
>> 1;
485 f1
= FLOATP (arg1
) ? XFLOAT (arg1
)->data
: XINT (arg1
);
486 f2
= FLOATP (arg2
) ? XFLOAT (arg2
)->data
: XINT (arg2
);
487 /* Really should check for overflow, too */
488 if (f1
== 0.0 && f2
== 0.0)
490 #ifdef FLOAT_CHECK_DOMAIN
491 else if ((f1
== 0.0 && f2
< 0.0) || (f1
< 0 && f2
!= floor(f2
)))
492 domain_error2 ("expt", arg1
, arg2
);
494 IN_FLOAT2 (f1
= pow (f1
, f2
), "expt", arg1
, arg2
);
495 return make_float (f1
);
498 DEFUN ("log", Flog
, Slog
, 1, 2, 0,
499 "Return the natural logarithm of ARG.\n\
500 If second optional argument BASE is given, return log ARG using that base.")
502 register Lisp_Object arg
, base
;
504 double d
= extract_float (arg
);
506 #ifdef FLOAT_CHECK_DOMAIN
508 domain_error2 ("log", arg
, base
);
511 IN_FLOAT (d
= log (d
), "log", arg
);
514 double b
= extract_float (base
);
516 #ifdef FLOAT_CHECK_DOMAIN
517 if (b
<= 0.0 || b
== 1.0)
518 domain_error2 ("log", arg
, base
);
521 IN_FLOAT2 (d
= log10 (d
), "log", arg
, base
);
523 IN_FLOAT2 (d
= log (d
) / log (b
), "log", arg
, base
);
525 return make_float (d
);
528 DEFUN ("log10", Flog10
, Slog10
, 1, 1, 0,
529 "Return the logarithm base 10 of ARG.")
531 register Lisp_Object arg
;
533 double d
= extract_float (arg
);
534 #ifdef FLOAT_CHECK_DOMAIN
536 domain_error ("log10", arg
);
538 IN_FLOAT (d
= log10 (d
), "log10", arg
);
539 return make_float (d
);
542 DEFUN ("sqrt", Fsqrt
, Ssqrt
, 1, 1, 0,
543 "Return the square root of ARG.")
545 register Lisp_Object arg
;
547 double d
= extract_float (arg
);
548 #ifdef FLOAT_CHECK_DOMAIN
550 domain_error ("sqrt", arg
);
552 IN_FLOAT (d
= sqrt (d
), "sqrt", arg
);
553 return make_float (d
);
556 #if 0 /* Not clearly worth adding. */
558 DEFUN ("acosh", Facosh
, Sacosh
, 1, 1, 0,
559 "Return the inverse hyperbolic cosine of ARG.")
561 register Lisp_Object arg
;
563 double d
= extract_float (arg
);
564 #ifdef FLOAT_CHECK_DOMAIN
566 domain_error ("acosh", arg
);
568 #ifdef HAVE_INVERSE_HYPERBOLIC
569 IN_FLOAT (d
= acosh (d
), "acosh", arg
);
571 IN_FLOAT (d
= log (d
+ sqrt (d
*d
- 1.0)), "acosh", arg
);
573 return make_float (d
);
576 DEFUN ("asinh", Fasinh
, Sasinh
, 1, 1, 0,
577 "Return the inverse hyperbolic sine of ARG.")
579 register Lisp_Object arg
;
581 double d
= extract_float (arg
);
582 #ifdef HAVE_INVERSE_HYPERBOLIC
583 IN_FLOAT (d
= asinh (d
), "asinh", arg
);
585 IN_FLOAT (d
= log (d
+ sqrt (d
*d
+ 1.0)), "asinh", arg
);
587 return make_float (d
);
590 DEFUN ("atanh", Fatanh
, Satanh
, 1, 1, 0,
591 "Return the inverse hyperbolic tangent of ARG.")
593 register Lisp_Object arg
;
595 double d
= extract_float (arg
);
596 #ifdef FLOAT_CHECK_DOMAIN
597 if (d
>= 1.0 || d
<= -1.0)
598 domain_error ("atanh", arg
);
600 #ifdef HAVE_INVERSE_HYPERBOLIC
601 IN_FLOAT (d
= atanh (d
), "atanh", arg
);
603 IN_FLOAT (d
= 0.5 * log ((1.0 + d
) / (1.0 - d
)), "atanh", arg
);
605 return make_float (d
);
608 DEFUN ("cosh", Fcosh
, Scosh
, 1, 1, 0,
609 "Return the hyperbolic cosine of ARG.")
611 register Lisp_Object arg
;
613 double d
= extract_float (arg
);
614 #ifdef FLOAT_CHECK_DOMAIN
615 if (d
> 710.0 || d
< -710.0)
616 range_error ("cosh", arg
);
618 IN_FLOAT (d
= cosh (d
), "cosh", arg
);
619 return make_float (d
);
622 DEFUN ("sinh", Fsinh
, Ssinh
, 1, 1, 0,
623 "Return the hyperbolic sine of ARG.")
625 register Lisp_Object arg
;
627 double d
= extract_float (arg
);
628 #ifdef FLOAT_CHECK_DOMAIN
629 if (d
> 710.0 || d
< -710.0)
630 range_error ("sinh", arg
);
632 IN_FLOAT (d
= sinh (d
), "sinh", arg
);
633 return make_float (d
);
636 DEFUN ("tanh", Ftanh
, Stanh
, 1, 1, 0,
637 "Return the hyperbolic tangent of ARG.")
639 register Lisp_Object arg
;
641 double d
= extract_float (arg
);
642 IN_FLOAT (d
= tanh (d
), "tanh", arg
);
643 return make_float (d
);
647 DEFUN ("abs", Fabs
, Sabs
, 1, 1, 0,
648 "Return the absolute value of ARG.")
650 register Lisp_Object arg
;
652 CHECK_NUMBER_OR_FLOAT (arg
, 0);
655 IN_FLOAT (arg
= make_float (fabs (XFLOAT (arg
)->data
)), "abs", arg
);
656 else if (XINT (arg
) < 0)
657 XSETINT (arg
, - XINT (arg
));
662 DEFUN ("float", Ffloat
, Sfloat
, 1, 1, 0,
663 "Return the floating point number equal to ARG.")
665 register Lisp_Object arg
;
667 CHECK_NUMBER_OR_FLOAT (arg
, 0);
670 return make_float ((double) XINT (arg
));
671 else /* give 'em the same float back */
675 DEFUN ("logb", Flogb
, Slogb
, 1, 1, 0,
676 "Returns largest integer <= the base 2 log of the magnitude of ARG.\n\
677 This is the same as the exponent of a float.")
683 double f
= extract_float (arg
);
686 value
= -(VALMASK
>> 1);
690 IN_FLOAT (value
= logb (f
), "logb", arg
);
694 IN_FLOAT (frexp (f
, &ivalue
), "logb", arg
);
704 for (i
= 1, d
= 0.5; d
* d
>= f
; i
+= i
)
711 for (i
= 1, d
= 2.0; d
* d
<= f
; i
+= i
)
719 XSETINT (val
, value
);
723 #endif /* LISP_FLOAT_TYPE */
726 /* the rounding functions */
729 rounding_driver (arg
, divisor
, double_round
, int_round2
, name
)
730 register Lisp_Object arg
, divisor
;
731 double (*double_round
) ();
732 EMACS_INT (*int_round2
) ();
735 CHECK_NUMBER_OR_FLOAT (arg
, 0);
737 if (! NILP (divisor
))
741 CHECK_NUMBER_OR_FLOAT (divisor
, 1);
743 #ifdef LISP_FLOAT_TYPE
744 if (FLOATP (arg
) || FLOATP (divisor
))
748 f1
= FLOATP (arg
) ? XFLOAT (arg
)->data
: XINT (arg
);
749 f2
= (FLOATP (divisor
) ? XFLOAT (divisor
)->data
: XINT (divisor
));
750 if (! IEEE_FLOATING_POINT
&& f2
== 0)
751 Fsignal (Qarith_error
, Qnil
);
753 IN_FLOAT2 (f1
= (*double_round
) (f1
/ f2
), name
, arg
, divisor
);
754 FLOAT_TO_INT2 (f1
, arg
, name
, arg
, divisor
);
763 Fsignal (Qarith_error
, Qnil
);
765 XSETINT (arg
, (*int_round2
) (i1
, i2
));
769 #ifdef LISP_FLOAT_TYPE
774 IN_FLOAT (d
= (*double_round
) (XFLOAT (arg
)->data
), name
, arg
);
775 FLOAT_TO_INT (d
, arg
, name
, arg
);
782 /* With C's /, the result is implementation-defined if either operand
783 is negative, so take care with negative operands in the following
784 integer functions. */
791 ? (i1
< 0 ? ((-1 - i1
) / -i2
) + 1 : - (i1
/ -i2
))
792 : (i1
<= 0 ? - (-i1
/ i2
) : ((i1
- 1) / i2
) + 1));
800 ? (i1
<= 0 ? -i1
/ -i2
: -1 - ((i1
- 1) / -i2
))
801 : (i1
< 0 ? -1 - ((-1 - i1
) / i2
) : i1
/ i2
));
809 ? (i1
< 0 ? -i1
/ -i2
: - (i1
/ -i2
))
810 : (i1
< 0 ? - (-i1
/ i2
) : i1
/ i2
));
817 /* The C language's division operator gives us one remainder R, but
818 we want the remainder R1 on the other side of 0 if R1 is closer
819 to 0 than R is; because we want to round to even, we also want R1
820 if R and R1 are the same distance from 0 and if C's quotient is
822 EMACS_INT q
= i1
/ i2
;
823 EMACS_INT r
= i1
% i2
;
824 EMACS_INT abs_r
= r
< 0 ? -r
: r
;
825 EMACS_INT abs_r1
= (i2
< 0 ? -i2
: i2
) - abs_r
;
826 return q
+ (abs_r
+ (q
& 1) <= abs_r1
? 0 : (i2
^ r
) < 0 ? -1 : 1);
829 /* The code uses emacs_rint, so that it works to undefine HAVE_RINT
830 if `rint' exists but does not work right. */
832 #define emacs_rint rint
838 return floor (d
+ 0.5);
849 DEFUN ("ceiling", Fceiling
, Sceiling
, 1, 2, 0,
850 "Return the smallest integer no less than ARG. (Round toward +inf.)\n\
851 With optional DIVISOR, return the smallest integer no less than ARG/DIVISOR.")
853 Lisp_Object arg
, divisor
;
855 return rounding_driver (arg
, divisor
, ceil
, ceiling2
, "ceiling");
858 DEFUN ("floor", Ffloor
, Sfloor
, 1, 2, 0,
859 "Return the largest integer no greater than ARG. (Round towards -inf.)\n\
860 With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR.")
862 Lisp_Object arg
, divisor
;
864 return rounding_driver (arg
, divisor
, floor
, floor2
, "floor");
867 DEFUN ("round", Fround
, Sround
, 1, 2, 0,
868 "Return the nearest integer to ARG.\n\
869 With optional DIVISOR, return the nearest integer to ARG/DIVISOR.")
871 Lisp_Object arg
, divisor
;
873 return rounding_driver (arg
, divisor
, emacs_rint
, round2
, "round");
876 DEFUN ("truncate", Ftruncate
, Struncate
, 1, 2, 0,
877 "Truncate a floating point number to an int.\n\
878 Rounds ARG toward zero.\n\
879 With optional DIVISOR, truncate ARG/DIVISOR.")
881 Lisp_Object arg
, divisor
;
883 return rounding_driver (arg
, divisor
, double_identity
, truncate2
,
887 #ifdef LISP_FLOAT_TYPE
891 register Lisp_Object x
, y
;
895 f1
= FLOATP (x
) ? XFLOAT (x
)->data
: XINT (x
);
896 f2
= FLOATP (y
) ? XFLOAT (y
)->data
: XINT (y
);
898 if (! IEEE_FLOATING_POINT
&& f2
== 0)
899 Fsignal (Qarith_error
, Qnil
);
901 /* If the "remainder" comes out with the wrong sign, fix it. */
902 IN_FLOAT2 ((f1
= fmod (f1
, f2
),
903 f1
= (f2
< 0 ? f1
> 0 : f1
< 0) ? f1
+ f2
: f1
),
905 return make_float (f1
);
908 /* It's not clear these are worth adding. */
910 DEFUN ("fceiling", Ffceiling
, Sfceiling
, 1, 1, 0,
911 "Return the smallest integer no less than ARG, as a float.\n\
912 \(Round toward +inf.\)")
914 register Lisp_Object arg
;
916 double d
= extract_float (arg
);
917 IN_FLOAT (d
= ceil (d
), "fceiling", arg
);
918 return make_float (d
);
921 DEFUN ("ffloor", Fffloor
, Sffloor
, 1, 1, 0,
922 "Return the largest integer no greater than ARG, as a float.\n\
923 \(Round towards -inf.\)")
925 register Lisp_Object arg
;
927 double d
= extract_float (arg
);
928 IN_FLOAT (d
= floor (d
), "ffloor", arg
);
929 return make_float (d
);
932 DEFUN ("fround", Ffround
, Sfround
, 1, 1, 0,
933 "Return the nearest integer to ARG, as a float.")
935 register Lisp_Object arg
;
937 double d
= extract_float (arg
);
938 IN_FLOAT (d
= emacs_rint (d
), "fround", arg
);
939 return make_float (d
);
942 DEFUN ("ftruncate", Fftruncate
, Sftruncate
, 1, 1, 0,
943 "Truncate a floating point number to an integral float value.\n\
944 Rounds the value toward zero.")
946 register Lisp_Object arg
;
948 double d
= extract_float (arg
);
950 IN_FLOAT (d
= floor (d
), "ftruncate", arg
);
952 IN_FLOAT (d
= ceil (d
), "ftruncate", arg
);
953 return make_float (d
);
956 #ifdef FLOAT_CATCH_SIGILL
962 fatal_error_signal (signo
);
967 #else /* not BSD4_1 */
968 sigsetmask (SIGEMPTYMASK
);
969 #endif /* not BSD4_1 */
971 /* Must reestablish handler each time it is called. */
972 signal (SIGILL
, float_error
);
973 #endif /* BSD_SYSTEM */
977 Fsignal (Qarith_error
, Fcons (float_error_arg
, Qnil
));
980 /* Another idea was to replace the library function `infnan'
981 where SIGILL is signaled. */
983 #endif /* FLOAT_CATCH_SIGILL */
992 /* Not called from emacs-lisp float routines; do the default thing. */
994 if (!strcmp (x
->name
, "pow"))
998 = Fcons (build_string (x
->name
),
999 Fcons (make_float (x
->arg1
),
1000 ((!strcmp (x
->name
, "log") || !strcmp (x
->name
, "pow"))
1001 ? Fcons (make_float (x
->arg2
), Qnil
)
1005 case DOMAIN
: Fsignal (Qdomain_error
, args
); break;
1006 case SING
: Fsignal (Qsingularity_error
, args
); break;
1007 case OVERFLOW
: Fsignal (Qoverflow_error
, args
); break;
1008 case UNDERFLOW
: Fsignal (Qunderflow_error
, args
); break;
1009 default: Fsignal (Qarith_error
, args
); break;
1011 return (1); /* don't set errno or print a message */
1013 #endif /* HAVE_MATHERR */
1017 #ifdef FLOAT_CATCH_SIGILL
1018 signal (SIGILL
, float_error
);
1023 #else /* not LISP_FLOAT_TYPE */
1028 #endif /* not LISP_FLOAT_TYPE */
1032 #ifdef LISP_FLOAT_TYPE
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 #endif /* LISP_FLOAT_TYPE */
1071 defsubr (&Sceiling
);
1074 defsubr (&Struncate
);