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, 675 Mass Ave, Cambridge, MA 02139, USA. */
21 /* ANSI C requires only these float functions:
22 acos, asin, atan, atan2, ceil, cos, cosh, exp, fabs, floor, fmod,
23 frexp, ldexp, log, log10, modf, pow, sin, sinh, sqrt, tan, tanh.
25 Define HAVE_INVERSE_HYPERBOLIC if you have acosh, asinh, and atanh.
26 Define HAVE_CBRT if you have cbrt.
27 Define HAVE_RINT if you have rint.
28 If you don't define these, then the appropriate routines will be simulated.
30 Define HAVE_MATHERR if on a system supporting the SysV matherr callback.
31 (This should happen automatically.)
33 Define FLOAT_CHECK_ERRNO if the float library routines set errno.
34 This has no effect if HAVE_MATHERR is defined.
36 Define FLOAT_CATCH_SIGILL if the float library routines signal SIGILL.
37 (What systems actually do this? Please let us know.)
39 Define FLOAT_CHECK_DOMAIN if the float library doesn't handle errors by
40 either setting errno, or signalling SIGFPE/SIGILL. Otherwise, domain and
41 range checking will happen before calling the float routines. This has
42 no effect if HAVE_MATHERR is defined (since matherr will be called when
43 a domain error occurs.)
50 #include "syssignal.h"
52 Lisp_Object Qarith_error
;
54 #ifdef LISP_FLOAT_TYPE
57 /* These are redefined (correctly, but differently) in values.h. */
63 /* Work around a problem that happens because math.h on hpux 7
64 defines two static variables--which, in Emacs, are not really static,
65 because `static' is defined as nothing. The problem is that they are
66 defined both here and in lread.c.
67 These macros prevent the name conflict. */
68 #if defined (HPUX) && !defined (HPUX8)
69 #define _MAXLDBL floatfns_maxldbl
70 #define _NMAXLDBL floatfns_nmaxldbl
75 /* This declaration is omitted on some systems, like Ultrix. */
76 #if !defined (HPUX) && defined (HAVE_LOGB) && !defined (logb)
77 extern double logb ();
78 #endif /* not HPUX and HAVE_LOGB and no logb macro */
80 #if defined(DOMAIN) && defined(SING) && defined(OVERFLOW)
81 /* If those are defined, then this is probably a `matherr' machine. */
92 # ifdef FLOAT_CHECK_ERRNO
93 # undef FLOAT_CHECK_ERRNO
95 # ifdef FLOAT_CHECK_DOMAIN
96 # undef FLOAT_CHECK_DOMAIN
100 #ifndef NO_FLOAT_CHECK_ERRNO
101 #define FLOAT_CHECK_ERRNO
104 #ifdef FLOAT_CHECK_ERRNO
110 /* Avoid traps on VMS from sinh and cosh.
111 All the other functions set errno instead. */
116 #define cosh(x) ((exp(x)+exp(-x))*0.5)
117 #define sinh(x) ((exp(x)-exp(-x))*0.5)
121 #define rint(x) (floor((x)+0.5))
124 static SIGTYPE
float_error ();
126 /* Nonzero while executing in floating point.
127 This tells float_error what to do. */
131 /* If an argument is out of range for a mathematical function,
132 here is the actual argument value to use in the error message. */
134 static Lisp_Object float_error_arg
, float_error_arg2
;
136 static char *float_error_fn_name
;
138 /* Evaluate the floating point expression D, recording NUM
139 as the original argument for error messages.
140 D is normally an assignment expression.
141 Handle errors which may result in signals or may set errno.
143 Note that float_error may be declared to return void, so you can't
144 just cast the zero after the colon to (SIGTYPE) to make the types
147 #ifdef FLOAT_CHECK_ERRNO
148 #define IN_FLOAT(d, name, num) \
150 float_error_arg = num; \
151 float_error_fn_name = name; \
152 in_float = 1; errno = 0; (d); in_float = 0; \
155 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
156 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
157 default: arith_error (float_error_fn_name, float_error_arg); \
160 #define IN_FLOAT2(d, name, num, num2) \
162 float_error_arg = num; \
163 float_error_arg2 = num2; \
164 float_error_fn_name = name; \
165 in_float = 1; errno = 0; (d); in_float = 0; \
168 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
169 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
170 default: arith_error (float_error_fn_name, float_error_arg); \
174 #define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0)
175 #define IN_FLOAT2(d, name, num, num2) (in_float = 1, (d), in_float = 0)
178 /* Convert float to Lisp_Int if it fits, else signal a range error
179 using the given arguments. */
180 #define FLOAT_TO_INT(x, i, name, num) \
183 if ((x) >= (1 << (VALBITS-1)) || (x) <= - (1 << (VALBITS-1)) - 1) \
184 range_error (name, num); \
185 XSET (i, Lisp_Int, (int)(x)); \
188 #define FLOAT_TO_INT2(x, i, name, num1, num2) \
191 if ((x) >= (1 << (VALBITS-1)) || (x) <= - (1 << (VALBITS-1)) - 1) \
192 range_error2 (name, num1, num2); \
193 XSET (i, Lisp_Int, (int)(x)); \
197 #define arith_error(op,arg) \
198 Fsignal (Qarith_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
199 #define range_error(op,arg) \
200 Fsignal (Qrange_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
201 #define range_error2(op,a1,a2) \
202 Fsignal (Qrange_error, Fcons (build_string ((op)), \
203 Fcons ((a1), Fcons ((a2), Qnil))))
204 #define domain_error(op,arg) \
205 Fsignal (Qdomain_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
206 #define domain_error2(op,a1,a2) \
207 Fsignal (Qdomain_error, Fcons (build_string ((op)), \
208 Fcons ((a1), Fcons ((a2), Qnil))))
210 /* Extract a Lisp number as a `double', or signal an error. */
216 CHECK_NUMBER_OR_FLOAT (num
, 0);
218 if (XTYPE (num
) == Lisp_Float
)
219 return XFLOAT (num
)->data
;
220 return (double) XINT (num
);
223 /* Trig functions. */
225 DEFUN ("acos", Facos
, Sacos
, 1, 1, 0,
226 "Return the inverse cosine of ARG.")
228 register Lisp_Object arg
;
230 double d
= extract_float (arg
);
231 #ifdef FLOAT_CHECK_DOMAIN
232 if (d
> 1.0 || d
< -1.0)
233 domain_error ("acos", arg
);
235 IN_FLOAT (d
= acos (d
), "acos", arg
);
236 return make_float (d
);
239 DEFUN ("asin", Fasin
, Sasin
, 1, 1, 0,
240 "Return the inverse sine of ARG.")
242 register Lisp_Object arg
;
244 double d
= extract_float (arg
);
245 #ifdef FLOAT_CHECK_DOMAIN
246 if (d
> 1.0 || d
< -1.0)
247 domain_error ("asin", arg
);
249 IN_FLOAT (d
= asin (d
), "asin", arg
);
250 return make_float (d
);
253 DEFUN ("atan", Fatan
, Satan
, 1, 1, 0,
254 "Return the inverse tangent of ARG.")
256 register Lisp_Object arg
;
258 double d
= extract_float (arg
);
259 IN_FLOAT (d
= atan (d
), "atan", arg
);
260 return make_float (d
);
263 DEFUN ("cos", Fcos
, Scos
, 1, 1, 0,
264 "Return the cosine of ARG.")
266 register Lisp_Object arg
;
268 double d
= extract_float (arg
);
269 IN_FLOAT (d
= cos (d
), "cos", arg
);
270 return make_float (d
);
273 DEFUN ("sin", Fsin
, Ssin
, 1, 1, 0,
274 "Return the sine of ARG.")
276 register Lisp_Object arg
;
278 double d
= extract_float (arg
);
279 IN_FLOAT (d
= sin (d
), "sin", arg
);
280 return make_float (d
);
283 DEFUN ("tan", Ftan
, Stan
, 1, 1, 0,
284 "Return the tangent of ARG.")
286 register Lisp_Object arg
;
288 double d
= extract_float (arg
);
290 #ifdef FLOAT_CHECK_DOMAIN
292 domain_error ("tan", arg
);
294 IN_FLOAT (d
= sin (d
) / c
, "tan", arg
);
295 return make_float (d
);
298 #if 0 /* Leave these out unless we find there's a reason for them. */
300 DEFUN ("bessel-j0", Fbessel_j0
, Sbessel_j0
, 1, 1, 0,
301 "Return the bessel function j0 of ARG.")
303 register Lisp_Object arg
;
305 double d
= extract_float (arg
);
306 IN_FLOAT (d
= j0 (d
), "bessel-j0", arg
);
307 return make_float (d
);
310 DEFUN ("bessel-j1", Fbessel_j1
, Sbessel_j1
, 1, 1, 0,
311 "Return the bessel function j1 of ARG.")
313 register Lisp_Object arg
;
315 double d
= extract_float (arg
);
316 IN_FLOAT (d
= j1 (d
), "bessel-j1", arg
);
317 return make_float (d
);
320 DEFUN ("bessel-jn", Fbessel_jn
, Sbessel_jn
, 2, 2, 0,
321 "Return the order N bessel function output jn of ARG.\n\
322 The first arg (the order) is truncated to an integer.")
324 register Lisp_Object arg1
, arg2
;
326 int i1
= extract_float (arg1
);
327 double f2
= extract_float (arg2
);
329 IN_FLOAT (f2
= jn (i1
, f2
), "bessel-jn", arg1
);
330 return make_float (f2
);
333 DEFUN ("bessel-y0", Fbessel_y0
, Sbessel_y0
, 1, 1, 0,
334 "Return the bessel function y0 of ARG.")
336 register Lisp_Object arg
;
338 double d
= extract_float (arg
);
339 IN_FLOAT (d
= y0 (d
), "bessel-y0", arg
);
340 return make_float (d
);
343 DEFUN ("bessel-y1", Fbessel_y1
, Sbessel_y1
, 1, 1, 0,
344 "Return the bessel function y1 of ARG.")
346 register Lisp_Object arg
;
348 double d
= extract_float (arg
);
349 IN_FLOAT (d
= y1 (d
), "bessel-y0", arg
);
350 return make_float (d
);
353 DEFUN ("bessel-yn", Fbessel_yn
, Sbessel_yn
, 2, 2, 0,
354 "Return the order N bessel function output yn of ARG.\n\
355 The first arg (the order) is truncated to an integer.")
357 register Lisp_Object arg1
, arg2
;
359 int i1
= extract_float (arg1
);
360 double f2
= extract_float (arg2
);
362 IN_FLOAT (f2
= yn (i1
, f2
), "bessel-yn", arg1
);
363 return make_float (f2
);
368 #if 0 /* Leave these out unless we see they are worth having. */
370 DEFUN ("erf", Ferf
, Serf
, 1, 1, 0,
371 "Return the mathematical error function of ARG.")
373 register Lisp_Object arg
;
375 double d
= extract_float (arg
);
376 IN_FLOAT (d
= erf (d
), "erf", arg
);
377 return make_float (d
);
380 DEFUN ("erfc", Ferfc
, Serfc
, 1, 1, 0,
381 "Return the complementary error function of ARG.")
383 register Lisp_Object arg
;
385 double d
= extract_float (arg
);
386 IN_FLOAT (d
= erfc (d
), "erfc", arg
);
387 return make_float (d
);
390 DEFUN ("log-gamma", Flog_gamma
, Slog_gamma
, 1, 1, 0,
391 "Return the log gamma of ARG.")
393 register Lisp_Object arg
;
395 double d
= extract_float (arg
);
396 IN_FLOAT (d
= lgamma (d
), "log-gamma", arg
);
397 return make_float (d
);
400 DEFUN ("cube-root", Fcube_root
, Scube_root
, 1, 1, 0,
401 "Return the cube root of ARG.")
403 register Lisp_Object arg
;
405 double d
= extract_float (arg
);
407 IN_FLOAT (d
= cbrt (d
), "cube-root", arg
);
410 IN_FLOAT (d
= pow (d
, 1.0/3.0), "cube-root", arg
);
412 IN_FLOAT (d
= -pow (-d
, 1.0/3.0), "cube-root", arg
);
414 return make_float (d
);
419 DEFUN ("exp", Fexp
, Sexp
, 1, 1, 0,
420 "Return the exponential base e of ARG.")
422 register Lisp_Object arg
;
424 double d
= extract_float (arg
);
425 #ifdef FLOAT_CHECK_DOMAIN
426 if (d
> 709.7827) /* Assume IEEE doubles here */
427 range_error ("exp", arg
);
429 return make_float (0.0);
432 IN_FLOAT (d
= exp (d
), "exp", arg
);
433 return make_float (d
);
436 DEFUN ("expt", Fexpt
, Sexpt
, 2, 2, 0,
437 "Return the exponential X ** Y.")
439 register Lisp_Object arg1
, arg2
;
443 CHECK_NUMBER_OR_FLOAT (arg1
, 0);
444 CHECK_NUMBER_OR_FLOAT (arg2
, 0);
445 if (XTYPE (arg1
) == Lisp_Int
/* common lisp spec */
446 && XTYPE (arg2
) == Lisp_Int
) /* don't promote, if both are ints */
447 { /* this can be improved by pre-calculating */
448 int acc
, x
, y
; /* some binary powers of x then accumulating */
460 acc
= (y
& 1) ? -1 : 1;
471 y
= (unsigned)y
>> 1;
474 XSET (val
, Lisp_Int
, acc
);
477 f1
= (XTYPE (arg1
) == Lisp_Float
) ? XFLOAT (arg1
)->data
: XINT (arg1
);
478 f2
= (XTYPE (arg2
) == Lisp_Float
) ? XFLOAT (arg2
)->data
: XINT (arg2
);
479 /* Really should check for overflow, too */
480 if (f1
== 0.0 && f2
== 0.0)
482 #ifdef FLOAT_CHECK_DOMAIN
483 else if ((f1
== 0.0 && f2
< 0.0) || (f1
< 0 && f2
!= floor(f2
)))
484 domain_error2 ("expt", arg1
, arg2
);
486 IN_FLOAT2 (f1
= pow (f1
, f2
), "expt", arg1
, arg2
);
487 return make_float (f1
);
490 DEFUN ("log", Flog
, Slog
, 1, 2, 0,
491 "Return the natural logarithm of ARG.\n\
492 If second optional argument BASE is given, return log ARG using that base.")
494 register Lisp_Object arg
, base
;
496 double d
= extract_float (arg
);
498 #ifdef FLOAT_CHECK_DOMAIN
500 domain_error2 ("log", arg
, base
);
503 IN_FLOAT (d
= log (d
), "log", arg
);
506 double b
= extract_float (base
);
508 #ifdef FLOAT_CHECK_DOMAIN
509 if (b
<= 0.0 || b
== 1.0)
510 domain_error2 ("log", arg
, base
);
513 IN_FLOAT2 (d
= log10 (d
), "log", arg
, base
);
515 IN_FLOAT2 (d
= log (d
) / log (b
), "log", arg
, base
);
517 return make_float (d
);
520 DEFUN ("log10", Flog10
, Slog10
, 1, 1, 0,
521 "Return the logarithm base 10 of ARG.")
523 register Lisp_Object arg
;
525 double d
= extract_float (arg
);
526 #ifdef FLOAT_CHECK_DOMAIN
528 domain_error ("log10", arg
);
530 IN_FLOAT (d
= log10 (d
), "log10", arg
);
531 return make_float (d
);
534 DEFUN ("sqrt", Fsqrt
, Ssqrt
, 1, 1, 0,
535 "Return the square root of ARG.")
537 register Lisp_Object arg
;
539 double d
= extract_float (arg
);
540 #ifdef FLOAT_CHECK_DOMAIN
542 domain_error ("sqrt", arg
);
544 IN_FLOAT (d
= sqrt (d
), "sqrt", arg
);
545 return make_float (d
);
548 #if 0 /* Not clearly worth adding. */
550 DEFUN ("acosh", Facosh
, Sacosh
, 1, 1, 0,
551 "Return the inverse hyperbolic cosine of ARG.")
553 register Lisp_Object arg
;
555 double d
= extract_float (arg
);
556 #ifdef FLOAT_CHECK_DOMAIN
558 domain_error ("acosh", arg
);
560 #ifdef HAVE_INVERSE_HYPERBOLIC
561 IN_FLOAT (d
= acosh (d
), "acosh", arg
);
563 IN_FLOAT (d
= log (d
+ sqrt (d
*d
- 1.0)), "acosh", arg
);
565 return make_float (d
);
568 DEFUN ("asinh", Fasinh
, Sasinh
, 1, 1, 0,
569 "Return the inverse hyperbolic sine of ARG.")
571 register Lisp_Object arg
;
573 double d
= extract_float (arg
);
574 #ifdef HAVE_INVERSE_HYPERBOLIC
575 IN_FLOAT (d
= asinh (d
), "asinh", arg
);
577 IN_FLOAT (d
= log (d
+ sqrt (d
*d
+ 1.0)), "asinh", arg
);
579 return make_float (d
);
582 DEFUN ("atanh", Fatanh
, Satanh
, 1, 1, 0,
583 "Return the inverse hyperbolic tangent of ARG.")
585 register Lisp_Object arg
;
587 double d
= extract_float (arg
);
588 #ifdef FLOAT_CHECK_DOMAIN
589 if (d
>= 1.0 || d
<= -1.0)
590 domain_error ("atanh", arg
);
592 #ifdef HAVE_INVERSE_HYPERBOLIC
593 IN_FLOAT (d
= atanh (d
), "atanh", arg
);
595 IN_FLOAT (d
= 0.5 * log ((1.0 + d
) / (1.0 - d
)), "atanh", arg
);
597 return make_float (d
);
600 DEFUN ("cosh", Fcosh
, Scosh
, 1, 1, 0,
601 "Return the hyperbolic cosine of ARG.")
603 register Lisp_Object arg
;
605 double d
= extract_float (arg
);
606 #ifdef FLOAT_CHECK_DOMAIN
607 if (d
> 710.0 || d
< -710.0)
608 range_error ("cosh", arg
);
610 IN_FLOAT (d
= cosh (d
), "cosh", arg
);
611 return make_float (d
);
614 DEFUN ("sinh", Fsinh
, Ssinh
, 1, 1, 0,
615 "Return the hyperbolic sine of ARG.")
617 register Lisp_Object arg
;
619 double d
= extract_float (arg
);
620 #ifdef FLOAT_CHECK_DOMAIN
621 if (d
> 710.0 || d
< -710.0)
622 range_error ("sinh", arg
);
624 IN_FLOAT (d
= sinh (d
), "sinh", arg
);
625 return make_float (d
);
628 DEFUN ("tanh", Ftanh
, Stanh
, 1, 1, 0,
629 "Return the hyperbolic tangent of ARG.")
631 register Lisp_Object arg
;
633 double d
= extract_float (arg
);
634 IN_FLOAT (d
= tanh (d
), "tanh", arg
);
635 return make_float (d
);
639 DEFUN ("abs", Fabs
, Sabs
, 1, 1, 0,
640 "Return the absolute value of ARG.")
642 register Lisp_Object arg
;
644 CHECK_NUMBER_OR_FLOAT (arg
, 0);
646 if (XTYPE (arg
) == Lisp_Float
)
647 IN_FLOAT (arg
= make_float (fabs (XFLOAT (arg
)->data
)), "abs", arg
);
648 else if (XINT (arg
) < 0)
649 XSETINT (arg
, - XFASTINT (arg
));
654 DEFUN ("float", Ffloat
, Sfloat
, 1, 1, 0,
655 "Return the floating point number equal to ARG.")
657 register Lisp_Object arg
;
659 CHECK_NUMBER_OR_FLOAT (arg
, 0);
661 if (XTYPE (arg
) == Lisp_Int
)
662 return make_float ((double) XINT (arg
));
663 else /* give 'em the same float back */
667 DEFUN ("logb", Flogb
, Slogb
, 1, 1, 0,
668 "Returns largest integer <= the base 2 log of the magnitude of ARG.\n\
669 This is the same as the exponent of a float.")
675 double f
= extract_float (arg
);
678 value
= -(VALMASK
>> 1);
682 IN_FLOAT (value
= logb (f
), "logb", arg
);
685 IN_FLOAT (frexp (f
, &value
), "logb", arg
);
695 for (i
= 1, d
= 0.5; d
* d
>= f
; i
+= i
)
702 for (i
= 1, d
= 2.0; d
* d
<= f
; i
+= i
)
710 XSET (val
, Lisp_Int
, value
);
714 /* the rounding functions */
716 DEFUN ("ceiling", Fceiling
, Sceiling
, 1, 1, 0,
717 "Return the smallest integer no less than ARG. (Round toward +inf.)")
719 register Lisp_Object arg
;
721 CHECK_NUMBER_OR_FLOAT (arg
, 0);
723 if (XTYPE (arg
) == Lisp_Float
)
727 IN_FLOAT (d
= ceil (XFLOAT (arg
)->data
), "ceiling", arg
);
728 FLOAT_TO_INT (d
, arg
, "ceiling", arg
);
734 #endif /* LISP_FLOAT_TYPE */
737 DEFUN ("floor", Ffloor
, Sfloor
, 1, 2, 0,
738 "Return the largest integer no greater than ARG. (Round towards -inf.)\n\
739 With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR.")
741 register Lisp_Object arg
, divisor
;
743 CHECK_NUMBER_OR_FLOAT (arg
, 0);
745 if (! NILP (divisor
))
749 CHECK_NUMBER_OR_FLOAT (divisor
, 1);
751 #ifdef LISP_FLOAT_TYPE
752 if (XTYPE (arg
) == Lisp_Float
|| XTYPE (divisor
) == Lisp_Float
)
756 f1
= XTYPE (arg
) == Lisp_Float
? XFLOAT (arg
)->data
: XINT (arg
);
757 f2
= (XTYPE (divisor
) == Lisp_Float
758 ? XFLOAT (divisor
)->data
: XINT (divisor
));
760 Fsignal (Qarith_error
, Qnil
);
762 IN_FLOAT2 (f1
= floor (f1
/ f2
), "floor", arg
, divisor
);
763 FLOAT_TO_INT2 (f1
, arg
, "floor", arg
, divisor
);
772 Fsignal (Qarith_error
, Qnil
);
774 /* With C's /, the result is implementation-defined if either operand
775 is negative, so use only nonnegative operands. */
777 ? (i1
<= 0 ? -i1
/ -i2
: -1 - ((i1
- 1) / -i2
))
778 : (i1
< 0 ? -1 - ((-1 - i1
) / i2
) : i1
/ i2
));
780 XSET (arg
, Lisp_Int
, i1
);
784 #ifdef LISP_FLOAT_TYPE
785 if (XTYPE (arg
) == Lisp_Float
)
788 IN_FLOAT (d
= floor (XFLOAT (arg
)->data
), "floor", arg
);
789 FLOAT_TO_INT (d
, arg
, "floor", arg
);
796 #ifdef LISP_FLOAT_TYPE
798 DEFUN ("round", Fround
, Sround
, 1, 1, 0,
799 "Return the nearest integer to ARG.")
801 register Lisp_Object arg
;
803 CHECK_NUMBER_OR_FLOAT (arg
, 0);
805 if (XTYPE (arg
) == Lisp_Float
)
809 /* Screw the prevailing rounding mode. */
810 IN_FLOAT (d
= rint (XFLOAT (arg
)->data
), "round", arg
);
811 FLOAT_TO_INT (d
, arg
, "round", arg
);
817 DEFUN ("truncate", Ftruncate
, Struncate
, 1, 1, 0,
818 "Truncate a floating point number to an int.\n\
819 Rounds the value toward zero.")
821 register Lisp_Object arg
;
823 CHECK_NUMBER_OR_FLOAT (arg
, 0);
825 if (XTYPE (arg
) == Lisp_Float
)
829 d
= XFLOAT (arg
)->data
;
830 FLOAT_TO_INT (d
, arg
, "truncate", arg
);
836 /* It's not clear these are worth adding. */
838 DEFUN ("fceiling", Ffceiling
, Sfceiling
, 1, 1, 0,
839 "Return the smallest integer no less than ARG, as a float.\n\
840 \(Round toward +inf.\)")
842 register Lisp_Object arg
;
844 double d
= extract_float (arg
);
845 IN_FLOAT (d
= ceil (d
), "fceiling", arg
);
846 return make_float (d
);
849 DEFUN ("ffloor", Fffloor
, Sffloor
, 1, 1, 0,
850 "Return the largest integer no greater than ARG, as a float.\n\
851 \(Round towards -inf.\)")
853 register Lisp_Object arg
;
855 double d
= extract_float (arg
);
856 IN_FLOAT (d
= floor (d
), "ffloor", arg
);
857 return make_float (d
);
860 DEFUN ("fround", Ffround
, Sfround
, 1, 1, 0,
861 "Return the nearest integer to ARG, as a float.")
863 register Lisp_Object arg
;
865 double d
= extract_float (arg
);
866 IN_FLOAT (d
= rint (d
), "fround", arg
);
867 return make_float (d
);
870 DEFUN ("ftruncate", Fftruncate
, Sftruncate
, 1, 1, 0,
871 "Truncate a floating point number to an integral float value.\n\
872 Rounds the value toward zero.")
874 register Lisp_Object arg
;
876 double d
= extract_float (arg
);
878 IN_FLOAT (d
= floor (d
), "ftruncate", arg
);
880 IN_FLOAT (d
= ceil (d
), "ftruncate", arg
);
881 return make_float (d
);
884 #ifdef FLOAT_CATCH_SIGILL
890 fatal_error_signal (signo
);
895 #else /* not BSD4_1 */
896 sigsetmask (SIGEMPTYMASK
);
897 #endif /* not BSD4_1 */
899 /* Must reestablish handler each time it is called. */
900 signal (SIGILL
, float_error
);
905 Fsignal (Qarith_error
, Fcons (float_error_arg
, Qnil
));
908 /* Another idea was to replace the library function `infnan'
909 where SIGILL is signaled. */
911 #endif /* FLOAT_CATCH_SIGILL */
920 /* Not called from emacs-lisp float routines; do the default thing. */
922 if (!strcmp (x
->name
, "pow"))
926 = Fcons (build_string (x
->name
),
927 Fcons (make_float (x
->arg1
),
928 ((!strcmp (x
->name
, "log") || !strcmp (x
->name
, "pow"))
929 ? Fcons (make_float (x
->arg2
), Qnil
)
933 case DOMAIN
: Fsignal (Qdomain_error
, args
); break;
934 case SING
: Fsignal (Qsingularity_error
, args
); break;
935 case OVERFLOW
: Fsignal (Qoverflow_error
, args
); break;
936 case UNDERFLOW
: Fsignal (Qunderflow_error
, args
); break;
937 default: Fsignal (Qarith_error
, args
); break;
939 return (1); /* don't set errno or print a message */
941 #endif /* HAVE_MATHERR */
945 #ifdef FLOAT_CATCH_SIGILL
946 signal (SIGILL
, float_error
);
951 #else /* not LISP_FLOAT_TYPE */
956 #endif /* not LISP_FLOAT_TYPE */
960 #ifdef LISP_FLOAT_TYPE
974 defsubr (&Sbessel_y0
);
975 defsubr (&Sbessel_y1
);
976 defsubr (&Sbessel_yn
);
977 defsubr (&Sbessel_j0
);
978 defsubr (&Sbessel_j1
);
979 defsubr (&Sbessel_jn
);
982 defsubr (&Slog_gamma
);
983 defsubr (&Scube_root
);
985 defsubr (&Sfceiling
);
988 defsubr (&Sftruncate
);
1000 defsubr (&Struncate
);
1001 #endif /* LISP_FLOAT_TYPE */