1 /* Primitive operations on floating point for GNU Emacs Lisp interpreter.
2 Copyright (C) 1988, 1993 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
56 #if 0 /* That is untrue--XINT is used below, and it uses INTBITS.
57 What in the world is values.h, anyway? */
59 /* These are redefined in <values.h> and not used here */
66 /* Work around a problem that happens because math.h on hpux 7
67 defines two static variables--which, in Emacs, are not really static,
68 because `static' is defined as nothing. The problem is that they are
69 defined both here and in lread.c.
70 These macros prevent the name conflict. */
71 #if defined (HPUX) && !defined (HPUX8)
72 #define _MAXLDBL floatfns_maxldbl
73 #define _NMAXLDBL floatfns_nmaxldbl
78 /* This declaration is omitted on some systems, like Ultrix. */
79 #if !defined (hpux) && defined (HAVE_LOGB)
80 extern double logb ();
81 #endif /* !hpux && HAVE_LOGB */
84 #if defined(DOMAIN) && defined(SING) && defined(OVERFLOW)
85 /* If those are defined, then this is probably a `matherr' machine. */
97 # ifdef FLOAT_CHECK_ERRNO
98 # undef FLOAT_CHECK_ERRNO
100 # ifdef FLOAT_CHECK_DOMAIN
101 # undef FLOAT_CHECK_DOMAIN
105 #ifndef NO_FLOAT_CHECK_ERRNO
106 #define FLOAT_CHECK_ERRNO
109 #ifdef FLOAT_CHECK_ERRNO
115 /* Avoid traps on VMS from sinh and cosh.
116 All the other functions set errno instead. */
121 #define cosh(x) ((exp(x)+exp(-x))*0.5)
122 #define sinh(x) ((exp(x)-exp(-x))*0.5)
126 #define rint(x) (floor((x)+0.5))
129 static SIGTYPE
float_error ();
131 /* Nonzero while executing in floating point.
132 This tells float_error what to do. */
136 /* If an argument is out of range for a mathematical function,
137 here is the actual argument value to use in the error message. */
139 static Lisp_Object float_error_arg
, float_error_arg2
;
141 static char *float_error_fn_name
;
143 /* Evaluate the floating point expression D, recording NUM
144 as the original argument for error messages.
145 D is normally an assignment expression.
146 Handle errors which may result in signals or may set errno.
148 Note that float_error may be declared to return void, so you can't
149 just cast the zero after the colon to (SIGTYPE) to make the types
152 #ifdef FLOAT_CHECK_ERRNO
153 #define IN_FLOAT(d, name, num) \
155 float_error_arg = num; \
156 float_error_fn_name = name; \
157 in_float = 1; errno = 0; (d); in_float = 0; \
160 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
161 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
162 default: arith_error (float_error_fn_name, float_error_arg); \
165 #define IN_FLOAT2(d, name, num, num2) \
167 float_error_arg = num; \
168 float_error_arg2 = num2; \
169 float_error_fn_name = name; \
170 in_float = 1; errno = 0; (d); in_float = 0; \
173 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
174 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
175 default: arith_error (float_error_fn_name, float_error_arg); \
179 #define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0)
180 #define IN_FLOAT2(d, name, num, num2) (in_float = 1, (d), in_float = 0)
183 #define arith_error(op,arg) \
184 Fsignal (Qarith_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
185 #define range_error(op,arg) \
186 Fsignal (Qrange_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
187 #define domain_error(op,arg) \
188 Fsignal (Qdomain_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
189 #define domain_error2(op,a1,a2) \
190 Fsignal (Qdomain_error, Fcons (build_string ((op)), Fcons ((a1), Fcons ((a2), Qnil))))
192 /* Extract a Lisp number as a `double', or signal an error. */
198 CHECK_NUMBER_OR_FLOAT (num
, 0);
200 if (XTYPE (num
) == Lisp_Float
)
201 return XFLOAT (num
)->data
;
202 return (double) XINT (num
);
205 /* Trig functions. */
207 DEFUN ("acos", Facos
, Sacos
, 1, 1, 0,
208 "Return the inverse cosine of ARG.")
210 register Lisp_Object arg
;
212 double d
= extract_float (arg
);
213 #ifdef FLOAT_CHECK_DOMAIN
214 if (d
> 1.0 || d
< -1.0)
215 domain_error ("acos", arg
);
217 IN_FLOAT (d
= acos (d
), "acos", arg
);
218 return make_float (d
);
221 DEFUN ("asin", Fasin
, Sasin
, 1, 1, 0,
222 "Return the inverse sine of ARG.")
224 register Lisp_Object arg
;
226 double d
= extract_float (arg
);
227 #ifdef FLOAT_CHECK_DOMAIN
228 if (d
> 1.0 || d
< -1.0)
229 domain_error ("asin", arg
);
231 IN_FLOAT (d
= asin (d
), "asin", arg
);
232 return make_float (d
);
235 DEFUN ("atan", Fatan
, Satan
, 1, 1, 0,
236 "Return the inverse tangent of ARG.")
238 register Lisp_Object arg
;
240 double d
= extract_float (arg
);
241 IN_FLOAT (d
= atan (d
), "atan", arg
);
242 return make_float (d
);
245 DEFUN ("cos", Fcos
, Scos
, 1, 1, 0,
246 "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 "Return the sine of ARG.")
258 register Lisp_Object arg
;
260 double d
= extract_float (arg
);
261 IN_FLOAT (d
= sin (d
), "sin", arg
);
262 return make_float (d
);
265 DEFUN ("tan", Ftan
, Stan
, 1, 1, 0,
266 "Return the tangent of ARG.")
268 register Lisp_Object arg
;
270 double d
= extract_float (arg
);
272 #ifdef FLOAT_CHECK_DOMAIN
274 domain_error ("tan", arg
);
276 IN_FLOAT (d
= sin (d
) / c
, "tan", arg
);
277 return make_float (d
);
280 #if 0 /* Leave these out unless we find there's a reason for them. */
282 DEFUN ("bessel-j0", Fbessel_j0
, Sbessel_j0
, 1, 1, 0,
283 "Return the bessel function j0 of ARG.")
285 register Lisp_Object arg
;
287 double d
= extract_float (arg
);
288 IN_FLOAT (d
= j0 (d
), "bessel-j0", arg
);
289 return make_float (d
);
292 DEFUN ("bessel-j1", Fbessel_j1
, Sbessel_j1
, 1, 1, 0,
293 "Return the bessel function j1 of ARG.")
295 register Lisp_Object arg
;
297 double d
= extract_float (arg
);
298 IN_FLOAT (d
= j1 (d
), "bessel-j1", arg
);
299 return make_float (d
);
302 DEFUN ("bessel-jn", Fbessel_jn
, Sbessel_jn
, 2, 2, 0,
303 "Return the order N bessel function output jn of ARG.\n\
304 The first arg (the order) is truncated to an integer.")
306 register Lisp_Object arg1
, arg2
;
308 int i1
= extract_float (arg1
);
309 double f2
= extract_float (arg2
);
311 IN_FLOAT (f2
= jn (i1
, f2
), "bessel-jn", arg1
);
312 return make_float (f2
);
315 DEFUN ("bessel-y0", Fbessel_y0
, Sbessel_y0
, 1, 1, 0,
316 "Return the bessel function y0 of ARG.")
318 register Lisp_Object arg
;
320 double d
= extract_float (arg
);
321 IN_FLOAT (d
= y0 (d
), "bessel-y0", arg
);
322 return make_float (d
);
325 DEFUN ("bessel-y1", Fbessel_y1
, Sbessel_y1
, 1, 1, 0,
326 "Return the bessel function y1 of ARG.")
328 register Lisp_Object arg
;
330 double d
= extract_float (arg
);
331 IN_FLOAT (d
= y1 (d
), "bessel-y0", arg
);
332 return make_float (d
);
335 DEFUN ("bessel-yn", Fbessel_yn
, Sbessel_yn
, 2, 2, 0,
336 "Return the order N bessel function output yn of ARG.\n\
337 The first arg (the order) is truncated to an integer.")
339 register Lisp_Object arg1
, arg2
;
341 int i1
= extract_float (arg1
);
342 double f2
= extract_float (arg2
);
344 IN_FLOAT (f2
= yn (i1
, f2
), "bessel-yn", arg1
);
345 return make_float (f2
);
350 #if 0 /* Leave these out unless we see they are worth having. */
352 DEFUN ("erf", Ferf
, Serf
, 1, 1, 0,
353 "Return the mathematical error function of ARG.")
355 register Lisp_Object arg
;
357 double d
= extract_float (arg
);
358 IN_FLOAT (d
= erf (d
), "erf", arg
);
359 return make_float (d
);
362 DEFUN ("erfc", Ferfc
, Serfc
, 1, 1, 0,
363 "Return the complementary error function of ARG.")
365 register Lisp_Object arg
;
367 double d
= extract_float (arg
);
368 IN_FLOAT (d
= erfc (d
), "erfc", arg
);
369 return make_float (d
);
372 DEFUN ("log-gamma", Flog_gamma
, Slog_gamma
, 1, 1, 0,
373 "Return the log gamma of ARG.")
375 register Lisp_Object arg
;
377 double d
= extract_float (arg
);
378 IN_FLOAT (d
= lgamma (d
), "log-gamma", arg
);
379 return make_float (d
);
382 DEFUN ("cube-root", Fcube_root
, Scube_root
, 1, 1, 0,
383 "Return the cube root of ARG.")
385 register Lisp_Object arg
;
387 double d
= extract_float (arg
);
389 IN_FLOAT (d
= cbrt (d
), "cube-root", arg
);
392 IN_FLOAT (d
= pow (d
, 1.0/3.0), "cube-root", arg
);
394 IN_FLOAT (d
= -pow (-d
, 1.0/3.0), "cube-root", arg
);
396 return make_float (d
);
401 DEFUN ("exp", Fexp
, Sexp
, 1, 1, 0,
402 "Return the exponential base e of ARG.")
404 register Lisp_Object arg
;
406 double d
= extract_float (arg
);
407 #ifdef FLOAT_CHECK_DOMAIN
408 if (d
> 709.7827) /* Assume IEEE doubles here */
409 range_error ("exp", arg
);
411 return make_float (0.0);
414 IN_FLOAT (d
= exp (d
), "exp", arg
);
415 return make_float (d
);
418 DEFUN ("expt", Fexpt
, Sexpt
, 2, 2, 0,
419 "Return the exponential X ** Y.")
421 register Lisp_Object arg1
, arg2
;
425 CHECK_NUMBER_OR_FLOAT (arg1
, 0);
426 CHECK_NUMBER_OR_FLOAT (arg2
, 0);
427 if (XTYPE (arg1
) == Lisp_Int
/* common lisp spec */
428 && XTYPE (arg2
) == Lisp_Int
) /* don't promote, if both are ints */
429 { /* this can be improved by pre-calculating */
430 int acc
, x
, y
; /* some binary powers of x then accumulating */
442 acc
= (y
& 1) ? -1 : 1;
454 y
= (unsigned)y
>> 1;
457 XSET (val
, Lisp_Int
, acc
);
460 f1
= (XTYPE (arg1
) == Lisp_Float
) ? XFLOAT (arg1
)->data
: XINT (arg1
);
461 f2
= (XTYPE (arg2
) == Lisp_Float
) ? XFLOAT (arg2
)->data
: XINT (arg2
);
462 /* Really should check for overflow, too */
463 if (f1
== 0.0 && f2
== 0.0)
465 #ifdef FLOAT_CHECK_DOMAIN
466 else if ((f1
== 0.0 && f2
< 0.0) || (f1
< 0 && f2
!= floor(f2
)))
467 domain_error2 ("expt", arg1
, arg2
);
469 IN_FLOAT2 (f1
= pow (f1
, f2
), "expt", arg1
, arg2
);
470 return make_float (f1
);
473 DEFUN ("log", Flog
, Slog
, 1, 2, 0,
474 "Return the natural logarithm of ARG.\n\
475 If second optional argument BASE is given, return log ARG using that base.")
477 register Lisp_Object arg
, base
;
479 double d
= extract_float (arg
);
481 #ifdef FLOAT_CHECK_DOMAIN
483 domain_error2 ("log", arg
, base
);
486 IN_FLOAT (d
= log (d
), "log", arg
);
489 double b
= extract_float (base
);
491 #ifdef FLOAT_CHECK_DOMAIN
492 if (b
<= 0.0 || b
== 1.0)
493 domain_error2 ("log", arg
, base
);
496 IN_FLOAT2 (d
= log10 (d
), "log", arg
, base
);
498 IN_FLOAT2 (d
= log (d
) / log (b
), "log", arg
, base
);
500 return make_float (d
);
503 DEFUN ("log10", Flog10
, Slog10
, 1, 1, 0,
504 "Return the logarithm base 10 of ARG.")
506 register Lisp_Object arg
;
508 double d
= extract_float (arg
);
509 #ifdef FLOAT_CHECK_DOMAIN
511 domain_error ("log10", arg
);
513 IN_FLOAT (d
= log10 (d
), "log10", arg
);
514 return make_float (d
);
517 DEFUN ("sqrt", Fsqrt
, Ssqrt
, 1, 1, 0,
518 "Return the square root of ARG.")
520 register Lisp_Object arg
;
522 double d
= extract_float (arg
);
523 #ifdef FLOAT_CHECK_DOMAIN
525 domain_error ("sqrt", arg
);
527 IN_FLOAT (d
= sqrt (d
), "sqrt", arg
);
528 return make_float (d
);
531 #if 0 /* Not clearly worth adding. */
533 DEFUN ("acosh", Facosh
, Sacosh
, 1, 1, 0,
534 "Return the inverse hyperbolic cosine of ARG.")
536 register Lisp_Object arg
;
538 double d
= extract_float (arg
);
539 #ifdef FLOAT_CHECK_DOMAIN
541 domain_error ("acosh", arg
);
543 #ifdef HAVE_INVERSE_HYPERBOLIC
544 IN_FLOAT (d
= acosh (d
), "acosh", arg
);
546 IN_FLOAT (d
= log (d
+ sqrt (d
*d
- 1.0)), "acosh", arg
);
548 return make_float (d
);
551 DEFUN ("asinh", Fasinh
, Sasinh
, 1, 1, 0,
552 "Return the inverse hyperbolic sine of ARG.")
554 register Lisp_Object arg
;
556 double d
= extract_float (arg
);
557 #ifdef HAVE_INVERSE_HYPERBOLIC
558 IN_FLOAT (d
= asinh (d
), "asinh", arg
);
560 IN_FLOAT (d
= log (d
+ sqrt (d
*d
+ 1.0)), "asinh", arg
);
562 return make_float (d
);
565 DEFUN ("atanh", Fatanh
, Satanh
, 1, 1, 0,
566 "Return the inverse hyperbolic tangent of ARG.")
568 register Lisp_Object arg
;
570 double d
= extract_float (arg
);
571 #ifdef FLOAT_CHECK_DOMAIN
572 if (d
>= 1.0 || d
<= -1.0)
573 domain_error ("atanh", arg
);
575 #ifdef HAVE_INVERSE_HYPERBOLIC
576 IN_FLOAT (d
= atanh (d
), "atanh", arg
);
578 IN_FLOAT (d
= 0.5 * log ((1.0 + d
) / (1.0 - d
)), "atanh", arg
);
580 return make_float (d
);
583 DEFUN ("cosh", Fcosh
, Scosh
, 1, 1, 0,
584 "Return the hyperbolic cosine of ARG.")
586 register Lisp_Object arg
;
588 double d
= extract_float (arg
);
589 #ifdef FLOAT_CHECK_DOMAIN
590 if (d
> 710.0 || d
< -710.0)
591 range_error ("cosh", arg
);
593 IN_FLOAT (d
= cosh (d
), "cosh", arg
);
594 return make_float (d
);
597 DEFUN ("sinh", Fsinh
, Ssinh
, 1, 1, 0,
598 "Return the hyperbolic sine of ARG.")
600 register Lisp_Object arg
;
602 double d
= extract_float (arg
);
603 #ifdef FLOAT_CHECK_DOMAIN
604 if (d
> 710.0 || d
< -710.0)
605 range_error ("sinh", arg
);
607 IN_FLOAT (d
= sinh (d
), "sinh", arg
);
608 return make_float (d
);
611 DEFUN ("tanh", Ftanh
, Stanh
, 1, 1, 0,
612 "Return the hyperbolic tangent of ARG.")
614 register Lisp_Object arg
;
616 double d
= extract_float (arg
);
617 IN_FLOAT (d
= tanh (d
), "tanh", arg
);
618 return make_float (d
);
622 DEFUN ("abs", Fabs
, Sabs
, 1, 1, 0,
623 "Return the absolute value of ARG.")
625 register Lisp_Object arg
;
627 CHECK_NUMBER_OR_FLOAT (arg
, 0);
629 if (XTYPE (arg
) == Lisp_Float
)
630 IN_FLOAT (arg
= make_float (fabs (XFLOAT (arg
)->data
)), "abs", arg
);
631 else if (XINT (arg
) < 0)
632 XSETINT (arg
, - XFASTINT (arg
));
637 DEFUN ("float", Ffloat
, Sfloat
, 1, 1, 0,
638 "Return the floating point number equal to ARG.")
640 register Lisp_Object arg
;
642 CHECK_NUMBER_OR_FLOAT (arg
, 0);
644 if (XTYPE (arg
) == Lisp_Int
)
645 return make_float ((double) XINT (arg
));
646 else /* give 'em the same float back */
650 DEFUN ("logb", Flogb
, Slogb
, 1, 1, 0,
651 "Returns largest integer <= the base 2 log of the magnitude of ARG.\n\
652 This is the same as the exponent of a float.")
658 double f
= extract_float (arg
);
661 IN_FLOAT (value
= logb (f
), "logb", arg
);
662 XSET (val
, Lisp_Int
, value
);
668 IN_FLOAT (frexp (f
, &exp
), "logb", arg
);
669 XSET (val
, Lisp_Int
, exp
-1);
672 /* Would someone like to write code to emulate logb? */
673 error ("`logb' not implemented on this operating system");
680 /* the rounding functions */
682 DEFUN ("ceiling", Fceiling
, Sceiling
, 1, 1, 0,
683 "Return the smallest integer no less than ARG. (Round toward +inf.)")
685 register Lisp_Object arg
;
687 CHECK_NUMBER_OR_FLOAT (arg
, 0);
689 if (XTYPE (arg
) == Lisp_Float
)
690 IN_FLOAT (XSET (arg
, Lisp_Int
, ceil (XFLOAT (arg
)->data
)), "ceiling", arg
);
695 #endif /* LISP_FLOAT_TYPE */
698 DEFUN ("floor", Ffloor
, Sfloor
, 1, 2, 0,
699 "Return the largest integer no greater than ARG. (Round towards -inf.)\n\
700 With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR.")
702 register Lisp_Object arg
, divisor
;
704 CHECK_NUMBER_OR_FLOAT (arg
, 0);
706 if (! NILP (divisor
))
710 CHECK_NUMBER_OR_FLOAT (divisor
, 1);
712 #ifdef LISP_FLOAT_TYPE
713 if (XTYPE (arg
) == Lisp_Float
|| XTYPE (divisor
) == Lisp_Float
)
717 f1
= XTYPE (arg
) == Lisp_Float
? XFLOAT (arg
)->data
: XINT (arg
);
718 f2
= (XTYPE (divisor
) == Lisp_Float
719 ? XFLOAT (divisor
)->data
: XINT (divisor
));
721 Fsignal (Qarith_error
, Qnil
);
723 IN_FLOAT2 (XSET (arg
, Lisp_Int
, floor (f1
/ f2
)),
724 "floor", arg
, divisor
);
733 Fsignal (Qarith_error
, Qnil
);
735 /* With C's /, the result is implementation-defined if either operand
736 is negative, so use only nonnegative operands. */
738 ? (i1
<= 0 ? -i1
/ -i2
: -1 - ((i1
- 1) / -i2
))
739 : (i1
< 0 ? -1 - ((-1 - i1
) / i2
) : i1
/ i2
));
741 XSET (arg
, Lisp_Int
, i1
);
745 #ifdef LISP_FLOAT_TYPE
746 if (XTYPE (arg
) == Lisp_Float
)
747 IN_FLOAT (XSET (arg
, Lisp_Int
, floor (XFLOAT (arg
)->data
)), "floor", arg
);
753 #ifdef LISP_FLOAT_TYPE
755 DEFUN ("round", Fround
, Sround
, 1, 1, 0,
756 "Return the nearest integer to ARG.")
758 register Lisp_Object arg
;
760 CHECK_NUMBER_OR_FLOAT (arg
, 0);
762 if (XTYPE (arg
) == Lisp_Float
)
763 /* Screw the prevailing rounding mode. */
764 IN_FLOAT (XSET (arg
, Lisp_Int
, rint (XFLOAT (arg
)->data
)), "round", arg
);
769 DEFUN ("truncate", Ftruncate
, Struncate
, 1, 1, 0,
770 "Truncate a floating point number to an int.\n\
771 Rounds the value toward zero.")
773 register Lisp_Object arg
;
775 CHECK_NUMBER_OR_FLOAT (arg
, 0);
777 if (XTYPE (arg
) == Lisp_Float
)
778 XSET (arg
, Lisp_Int
, (int) XFLOAT (arg
)->data
);
783 /* It's not clear these are worth adding. */
785 DEFUN ("fceiling", Ffceiling
, Sfceiling
, 1, 1, 0,
786 "Return the smallest integer no less than ARG, as a float.\n\
787 \(Round toward +inf.\)")
789 register Lisp_Object arg
;
791 double d
= extract_float (arg
);
792 IN_FLOAT (d
= ceil (d
), "fceiling", arg
);
793 return make_float (d
);
796 DEFUN ("ffloor", Fffloor
, Sffloor
, 1, 1, 0,
797 "Return the largest integer no greater than ARG, as a float.\n\
798 \(Round towards -inf.\)")
800 register Lisp_Object arg
;
802 double d
= extract_float (arg
);
803 IN_FLOAT (d
= floor (d
), "ffloor", arg
);
804 return make_float (d
);
807 DEFUN ("fround", Ffround
, Sfround
, 1, 1, 0,
808 "Return the nearest integer to ARG, as a float.")
810 register Lisp_Object arg
;
812 double d
= extract_float (arg
);
813 IN_FLOAT (d
= rint (d
), "fround", arg
);
814 return make_float (d
);
817 DEFUN ("ftruncate", Fftruncate
, Sftruncate
, 1, 1, 0,
818 "Truncate a floating point number to an integral float value.\n\
819 Rounds the value toward zero.")
821 register Lisp_Object arg
;
823 double d
= extract_float (arg
);
825 IN_FLOAT (d
= floor (d
), "ftruncate", arg
);
827 IN_FLOAT (d
= ceil (d
), "ftruncate", arg
);
828 return make_float (d
);
831 #ifdef FLOAT_CATCH_SIGILL
837 fatal_error_signal (signo
);
842 #else /* not BSD4_1 */
843 sigsetmask (SIGEMPTYMASK
);
844 #endif /* not BSD4_1 */
846 /* Must reestablish handler each time it is called. */
847 signal (SIGILL
, float_error
);
852 Fsignal (Qarith_error
, Fcons (float_error_arg
, Qnil
));
855 /* Another idea was to replace the library function `infnan'
856 where SIGILL is signaled. */
858 #endif /* FLOAT_CATCH_SIGILL */
867 /* Not called from emacs-lisp float routines; do the default thing. */
869 if (!strcmp (x
->name
, "pow"))
873 = Fcons (build_string (x
->name
),
874 Fcons (make_float (x
->arg1
),
875 ((!strcmp (x
->name
, "log") || !strcmp (x
->name
, "pow"))
876 ? Fcons (make_float (x
->arg2
), Qnil
)
880 case DOMAIN
: Fsignal (Qdomain_error
, args
); break;
881 case SING
: Fsignal (Qsingularity_error
, args
); break;
882 case OVERFLOW
: Fsignal (Qoverflow_error
, args
); break;
883 case UNDERFLOW
: Fsignal (Qunderflow_error
, args
); break;
884 default: Fsignal (Qarith_error
, args
); break;
886 return (1); /* don't set errno or print a message */
888 #endif /* HAVE_MATHERR */
892 #ifdef FLOAT_CATCH_SIGILL
893 signal (SIGILL
, float_error
);
898 #else /* not LISP_FLOAT_TYPE */
903 #endif /* not LISP_FLOAT_TYPE */
907 #ifdef LISP_FLOAT_TYPE
921 defsubr (&Sbessel_y0
);
922 defsubr (&Sbessel_y1
);
923 defsubr (&Sbessel_yn
);
924 defsubr (&Sbessel_j0
);
925 defsubr (&Sbessel_j1
);
926 defsubr (&Sbessel_jn
);
929 defsubr (&Slog_gamma
);
930 defsubr (&Scube_root
);
932 defsubr (&Sfceiling
);
935 defsubr (&Sftruncate
);
947 defsubr (&Struncate
);
948 #endif /* LISP_FLOAT_TYPE */