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 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 #include "syssignal.h"
53 #ifdef LISP_FLOAT_TYPE
55 /* Work around a problem that happens because math.h on hpux 7
56 defines two static variables--which, in Emacs, are not really static,
57 because `static' is defined as nothing. The problem is that they are
58 defined both here and in lread.c.
59 These macros prevent the name conflict. */
60 #if defined (HPUX) && !defined (HPUX8)
61 #define _MAXLDBL floatfns_maxldbl
62 #define _NMAXLDBL floatfns_nmaxldbl
67 /* This declaration is omitted on some systems, like Ultrix. */
68 #if !defined (HPUX) && defined (HAVE_LOGB) && !defined (logb)
69 extern double logb ();
70 #endif /* not HPUX and HAVE_LOGB and no logb macro */
72 #if defined(DOMAIN) && defined(SING) && defined(OVERFLOW)
73 /* If those are defined, then this is probably a `matherr' machine. */
84 # ifdef FLOAT_CHECK_ERRNO
85 # undef FLOAT_CHECK_ERRNO
87 # ifdef FLOAT_CHECK_DOMAIN
88 # undef FLOAT_CHECK_DOMAIN
92 #ifndef NO_FLOAT_CHECK_ERRNO
93 #define FLOAT_CHECK_ERRNO
96 #ifdef FLOAT_CHECK_ERRNO
102 /* Avoid traps on VMS from sinh and cosh.
103 All the other functions set errno instead. */
108 #define cosh(x) ((exp(x)+exp(-x))*0.5)
109 #define sinh(x) ((exp(x)-exp(-x))*0.5)
113 #define rint(x) (floor((x)+0.5))
116 static SIGTYPE
float_error ();
118 /* Nonzero while executing in floating point.
119 This tells float_error what to do. */
123 /* If an argument is out of range for a mathematical function,
124 here is the actual argument value to use in the error message.
125 These variables are used only across the floating point library call
126 so there is no need to staticpro them. */
128 static Lisp_Object float_error_arg
, float_error_arg2
;
130 static char *float_error_fn_name
;
132 /* Evaluate the floating point expression D, recording NUM
133 as the original argument for error messages.
134 D is normally an assignment expression.
135 Handle errors which may result in signals or may set errno.
137 Note that float_error may be declared to return void, so you can't
138 just cast the zero after the colon to (SIGTYPE) to make the types
141 #ifdef FLOAT_CHECK_ERRNO
142 #define IN_FLOAT(d, name, num) \
144 float_error_arg = num; \
145 float_error_fn_name = name; \
146 in_float = 1; errno = 0; (d); in_float = 0; \
149 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
150 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
151 default: arith_error (float_error_fn_name, float_error_arg); \
154 #define IN_FLOAT2(d, name, num, num2) \
156 float_error_arg = num; \
157 float_error_arg2 = num2; \
158 float_error_fn_name = name; \
159 in_float = 1; errno = 0; (d); in_float = 0; \
162 case EDOM: domain_error (float_error_fn_name, float_error_arg); \
163 case ERANGE: range_error (float_error_fn_name, float_error_arg); \
164 default: arith_error (float_error_fn_name, float_error_arg); \
168 #define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0)
169 #define IN_FLOAT2(d, name, num, num2) (in_float = 1, (d), in_float = 0)
172 /* Convert float to Lisp_Int if it fits, else signal a range error
173 using the given arguments. */
174 #define FLOAT_TO_INT(x, i, name, num) \
177 if ((x) >= (((EMACS_INT) 1) << (VALBITS-1)) || \
178 (x) <= - (((EMACS_INT) 1) << (VALBITS-1)) - 1) \
179 range_error (name, num); \
180 XSETINT (i, (EMACS_INT)(x)); \
183 #define FLOAT_TO_INT2(x, i, name, num1, num2) \
186 if ((x) >= (((EMACS_INT) 1) << (VALBITS-1)) || \
187 (x) <= - (((EMACS_INT) 1) << (VALBITS-1)) - 1) \
188 range_error2 (name, num1, num2); \
189 XSETINT (i, (EMACS_INT)(x)); \
193 #define arith_error(op,arg) \
194 Fsignal (Qarith_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
195 #define range_error(op,arg) \
196 Fsignal (Qrange_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
197 #define range_error2(op,a1,a2) \
198 Fsignal (Qrange_error, Fcons (build_string ((op)), \
199 Fcons ((a1), Fcons ((a2), Qnil))))
200 #define domain_error(op,arg) \
201 Fsignal (Qdomain_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
202 #define domain_error2(op,a1,a2) \
203 Fsignal (Qdomain_error, Fcons (build_string ((op)), \
204 Fcons ((a1), Fcons ((a2), Qnil))))
206 /* Extract a Lisp number as a `double', or signal an error. */
212 CHECK_NUMBER_OR_FLOAT (num
, 0);
215 return XFLOAT (num
)->data
;
216 return (double) XINT (num
);
219 /* Trig functions. */
221 DEFUN ("acos", Facos
, Sacos
, 1, 1, 0,
222 "Return the inverse cosine 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 ("acos", arg
);
231 IN_FLOAT (d
= acos (d
), "acos", arg
);
232 return make_float (d
);
235 DEFUN ("asin", Fasin
, Sasin
, 1, 1, 0,
236 "Return the inverse sine of ARG.")
238 register Lisp_Object arg
;
240 double d
= extract_float (arg
);
241 #ifdef FLOAT_CHECK_DOMAIN
242 if (d
> 1.0 || d
< -1.0)
243 domain_error ("asin", arg
);
245 IN_FLOAT (d
= asin (d
), "asin", arg
);
246 return make_float (d
);
249 DEFUN ("atan", Fatan
, Satan
, 1, 1, 0,
250 "Return the inverse tangent of ARG.")
252 register Lisp_Object arg
;
254 double d
= extract_float (arg
);
255 IN_FLOAT (d
= atan (d
), "atan", arg
);
256 return make_float (d
);
259 DEFUN ("cos", Fcos
, Scos
, 1, 1, 0,
260 "Return the cosine of ARG.")
262 register Lisp_Object arg
;
264 double d
= extract_float (arg
);
265 IN_FLOAT (d
= cos (d
), "cos", arg
);
266 return make_float (d
);
269 DEFUN ("sin", Fsin
, Ssin
, 1, 1, 0,
270 "Return the sine of ARG.")
272 register Lisp_Object arg
;
274 double d
= extract_float (arg
);
275 IN_FLOAT (d
= sin (d
), "sin", arg
);
276 return make_float (d
);
279 DEFUN ("tan", Ftan
, Stan
, 1, 1, 0,
280 "Return the tangent of ARG.")
282 register Lisp_Object arg
;
284 double d
= extract_float (arg
);
286 #ifdef FLOAT_CHECK_DOMAIN
288 domain_error ("tan", arg
);
290 IN_FLOAT (d
= sin (d
) / c
, "tan", arg
);
291 return make_float (d
);
294 #if 0 /* Leave these out unless we find there's a reason for them. */
296 DEFUN ("bessel-j0", Fbessel_j0
, Sbessel_j0
, 1, 1, 0,
297 "Return the bessel function j0 of ARG.")
299 register Lisp_Object arg
;
301 double d
= extract_float (arg
);
302 IN_FLOAT (d
= j0 (d
), "bessel-j0", arg
);
303 return make_float (d
);
306 DEFUN ("bessel-j1", Fbessel_j1
, Sbessel_j1
, 1, 1, 0,
307 "Return the bessel function j1 of ARG.")
309 register Lisp_Object arg
;
311 double d
= extract_float (arg
);
312 IN_FLOAT (d
= j1 (d
), "bessel-j1", arg
);
313 return make_float (d
);
316 DEFUN ("bessel-jn", Fbessel_jn
, Sbessel_jn
, 2, 2, 0,
317 "Return the order N bessel function output jn of ARG.\n\
318 The first arg (the order) is truncated to an integer.")
320 register Lisp_Object n
, arg
;
322 int i1
= extract_float (n
);
323 double f2
= extract_float (arg
);
325 IN_FLOAT (f2
= jn (i1
, f2
), "bessel-jn", n
);
326 return make_float (f2
);
329 DEFUN ("bessel-y0", Fbessel_y0
, Sbessel_y0
, 1, 1, 0,
330 "Return the bessel function y0 of ARG.")
332 register Lisp_Object arg
;
334 double d
= extract_float (arg
);
335 IN_FLOAT (d
= y0 (d
), "bessel-y0", arg
);
336 return make_float (d
);
339 DEFUN ("bessel-y1", Fbessel_y1
, Sbessel_y1
, 1, 1, 0,
340 "Return the bessel function y1 of ARG.")
342 register Lisp_Object arg
;
344 double d
= extract_float (arg
);
345 IN_FLOAT (d
= y1 (d
), "bessel-y0", arg
);
346 return make_float (d
);
349 DEFUN ("bessel-yn", Fbessel_yn
, Sbessel_yn
, 2, 2, 0,
350 "Return the order N bessel function output yn of ARG.\n\
351 The first arg (the order) is truncated to an integer.")
353 register Lisp_Object n
, arg
;
355 int i1
= extract_float (n
);
356 double f2
= extract_float (arg
);
358 IN_FLOAT (f2
= yn (i1
, f2
), "bessel-yn", n
);
359 return make_float (f2
);
364 #if 0 /* Leave these out unless we see they are worth having. */
366 DEFUN ("erf", Ferf
, Serf
, 1, 1, 0,
367 "Return the mathematical error function of ARG.")
369 register Lisp_Object arg
;
371 double d
= extract_float (arg
);
372 IN_FLOAT (d
= erf (d
), "erf", arg
);
373 return make_float (d
);
376 DEFUN ("erfc", Ferfc
, Serfc
, 1, 1, 0,
377 "Return the complementary error function of ARG.")
379 register Lisp_Object arg
;
381 double d
= extract_float (arg
);
382 IN_FLOAT (d
= erfc (d
), "erfc", arg
);
383 return make_float (d
);
386 DEFUN ("log-gamma", Flog_gamma
, Slog_gamma
, 1, 1, 0,
387 "Return the log gamma of ARG.")
389 register Lisp_Object arg
;
391 double d
= extract_float (arg
);
392 IN_FLOAT (d
= lgamma (d
), "log-gamma", arg
);
393 return make_float (d
);
396 DEFUN ("cube-root", Fcube_root
, Scube_root
, 1, 1, 0,
397 "Return the cube root of ARG.")
399 register Lisp_Object arg
;
401 double d
= extract_float (arg
);
403 IN_FLOAT (d
= cbrt (d
), "cube-root", arg
);
406 IN_FLOAT (d
= pow (d
, 1.0/3.0), "cube-root", arg
);
408 IN_FLOAT (d
= -pow (-d
, 1.0/3.0), "cube-root", arg
);
410 return make_float (d
);
415 DEFUN ("exp", Fexp
, Sexp
, 1, 1, 0,
416 "Return the exponential base e of ARG.")
418 register Lisp_Object arg
;
420 double d
= extract_float (arg
);
421 #ifdef FLOAT_CHECK_DOMAIN
422 if (d
> 709.7827) /* Assume IEEE doubles here */
423 range_error ("exp", arg
);
425 return make_float (0.0);
428 IN_FLOAT (d
= exp (d
), "exp", arg
);
429 return make_float (d
);
432 DEFUN ("expt", Fexpt
, Sexpt
, 2, 2, 0,
433 "Return the exponential ARG1 ** ARG2.")
435 register Lisp_Object arg1
, arg2
;
439 CHECK_NUMBER_OR_FLOAT (arg1
, 0);
440 CHECK_NUMBER_OR_FLOAT (arg2
, 0);
441 if (INTEGERP (arg1
) /* common lisp spec */
442 && INTEGERP (arg2
)) /* don't promote, if both are ints */
443 { /* this can be improved by pre-calculating */
444 EMACS_INT acc
, x
, y
; /* some binary powers of x then accumulating */
456 acc
= (y
& 1) ? -1 : 1;
467 y
= (unsigned)y
>> 1;
473 f1
= FLOATP (arg1
) ? XFLOAT (arg1
)->data
: XINT (arg1
);
474 f2
= FLOATP (arg2
) ? XFLOAT (arg2
)->data
: XINT (arg2
);
475 /* Really should check for overflow, too */
476 if (f1
== 0.0 && f2
== 0.0)
478 #ifdef FLOAT_CHECK_DOMAIN
479 else if ((f1
== 0.0 && f2
< 0.0) || (f1
< 0 && f2
!= floor(f2
)))
480 domain_error2 ("expt", arg1
, arg2
);
482 IN_FLOAT2 (f1
= pow (f1
, f2
), "expt", arg1
, arg2
);
483 return make_float (f1
);
486 DEFUN ("log", Flog
, Slog
, 1, 2, 0,
487 "Return the natural logarithm of ARG.\n\
488 If second optional argument BASE is given, return log ARG using that base.")
490 register Lisp_Object arg
, base
;
492 double d
= extract_float (arg
);
494 #ifdef FLOAT_CHECK_DOMAIN
496 domain_error2 ("log", arg
, base
);
499 IN_FLOAT (d
= log (d
), "log", arg
);
502 double b
= extract_float (base
);
504 #ifdef FLOAT_CHECK_DOMAIN
505 if (b
<= 0.0 || b
== 1.0)
506 domain_error2 ("log", arg
, base
);
509 IN_FLOAT2 (d
= log10 (d
), "log", arg
, base
);
511 IN_FLOAT2 (d
= log (d
) / log (b
), "log", arg
, base
);
513 return make_float (d
);
516 DEFUN ("log10", Flog10
, Slog10
, 1, 1, 0,
517 "Return the logarithm base 10 of ARG.")
519 register Lisp_Object arg
;
521 double d
= extract_float (arg
);
522 #ifdef FLOAT_CHECK_DOMAIN
524 domain_error ("log10", arg
);
526 IN_FLOAT (d
= log10 (d
), "log10", arg
);
527 return make_float (d
);
530 DEFUN ("sqrt", Fsqrt
, Ssqrt
, 1, 1, 0,
531 "Return the square root of ARG.")
533 register Lisp_Object arg
;
535 double d
= extract_float (arg
);
536 #ifdef FLOAT_CHECK_DOMAIN
538 domain_error ("sqrt", arg
);
540 IN_FLOAT (d
= sqrt (d
), "sqrt", arg
);
541 return make_float (d
);
544 #if 0 /* Not clearly worth adding. */
546 DEFUN ("acosh", Facosh
, Sacosh
, 1, 1, 0,
547 "Return the inverse hyperbolic cosine of ARG.")
549 register Lisp_Object arg
;
551 double d
= extract_float (arg
);
552 #ifdef FLOAT_CHECK_DOMAIN
554 domain_error ("acosh", arg
);
556 #ifdef HAVE_INVERSE_HYPERBOLIC
557 IN_FLOAT (d
= acosh (d
), "acosh", arg
);
559 IN_FLOAT (d
= log (d
+ sqrt (d
*d
- 1.0)), "acosh", arg
);
561 return make_float (d
);
564 DEFUN ("asinh", Fasinh
, Sasinh
, 1, 1, 0,
565 "Return the inverse hyperbolic sine of ARG.")
567 register Lisp_Object arg
;
569 double d
= extract_float (arg
);
570 #ifdef HAVE_INVERSE_HYPERBOLIC
571 IN_FLOAT (d
= asinh (d
), "asinh", arg
);
573 IN_FLOAT (d
= log (d
+ sqrt (d
*d
+ 1.0)), "asinh", arg
);
575 return make_float (d
);
578 DEFUN ("atanh", Fatanh
, Satanh
, 1, 1, 0,
579 "Return the inverse hyperbolic tangent of ARG.")
581 register Lisp_Object arg
;
583 double d
= extract_float (arg
);
584 #ifdef FLOAT_CHECK_DOMAIN
585 if (d
>= 1.0 || d
<= -1.0)
586 domain_error ("atanh", arg
);
588 #ifdef HAVE_INVERSE_HYPERBOLIC
589 IN_FLOAT (d
= atanh (d
), "atanh", arg
);
591 IN_FLOAT (d
= 0.5 * log ((1.0 + d
) / (1.0 - d
)), "atanh", arg
);
593 return make_float (d
);
596 DEFUN ("cosh", Fcosh
, Scosh
, 1, 1, 0,
597 "Return the hyperbolic cosine of ARG.")
599 register Lisp_Object arg
;
601 double d
= extract_float (arg
);
602 #ifdef FLOAT_CHECK_DOMAIN
603 if (d
> 710.0 || d
< -710.0)
604 range_error ("cosh", arg
);
606 IN_FLOAT (d
= cosh (d
), "cosh", arg
);
607 return make_float (d
);
610 DEFUN ("sinh", Fsinh
, Ssinh
, 1, 1, 0,
611 "Return the hyperbolic sine of ARG.")
613 register Lisp_Object arg
;
615 double d
= extract_float (arg
);
616 #ifdef FLOAT_CHECK_DOMAIN
617 if (d
> 710.0 || d
< -710.0)
618 range_error ("sinh", arg
);
620 IN_FLOAT (d
= sinh (d
), "sinh", arg
);
621 return make_float (d
);
624 DEFUN ("tanh", Ftanh
, Stanh
, 1, 1, 0,
625 "Return the hyperbolic tangent of ARG.")
627 register Lisp_Object arg
;
629 double d
= extract_float (arg
);
630 IN_FLOAT (d
= tanh (d
), "tanh", arg
);
631 return make_float (d
);
635 DEFUN ("abs", Fabs
, Sabs
, 1, 1, 0,
636 "Return the absolute value of ARG.")
638 register Lisp_Object arg
;
640 CHECK_NUMBER_OR_FLOAT (arg
, 0);
643 IN_FLOAT (arg
= make_float (fabs (XFLOAT (arg
)->data
)), "abs", arg
);
644 else if (XINT (arg
) < 0)
645 XSETINT (arg
, - XINT (arg
));
650 DEFUN ("float", Ffloat
, Sfloat
, 1, 1, 0,
651 "Return the floating point number equal to ARG.")
653 register Lisp_Object arg
;
655 CHECK_NUMBER_OR_FLOAT (arg
, 0);
658 return make_float ((double) XINT (arg
));
659 else /* give 'em the same float back */
663 DEFUN ("logb", Flogb
, Slogb
, 1, 1, 0,
664 "Returns largest integer <= the base 2 log of the magnitude of ARG.\n\
665 This is the same as the exponent of a float.")
671 double f
= extract_float (arg
);
674 value
= -(VALMASK
>> 1);
678 IN_FLOAT (value
= logb (f
), "logb", arg
);
682 IN_FLOAT (frexp (f
, &ivalue
), "logb", arg
);
692 for (i
= 1, d
= 0.5; d
* d
>= f
; i
+= i
)
699 for (i
= 1, d
= 2.0; d
* d
<= f
; i
+= i
)
707 XSETINT (val
, value
);
711 /* the rounding functions */
713 DEFUN ("ceiling", Fceiling
, Sceiling
, 1, 1, 0,
714 "Return the smallest integer no less than ARG. (Round toward +inf.)")
716 register Lisp_Object arg
;
718 CHECK_NUMBER_OR_FLOAT (arg
, 0);
724 IN_FLOAT (d
= ceil (XFLOAT (arg
)->data
), "ceiling", arg
);
725 FLOAT_TO_INT (d
, arg
, "ceiling", arg
);
731 #endif /* LISP_FLOAT_TYPE */
734 DEFUN ("floor", Ffloor
, Sfloor
, 1, 2, 0,
735 "Return the largest integer no greater than ARG. (Round towards -inf.)\n\
736 With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR.")
738 register Lisp_Object arg
, divisor
;
740 CHECK_NUMBER_OR_FLOAT (arg
, 0);
742 if (! NILP (divisor
))
746 CHECK_NUMBER_OR_FLOAT (divisor
, 1);
748 #ifdef LISP_FLOAT_TYPE
749 if (FLOATP (arg
) || FLOATP (divisor
))
753 f1
= FLOATP (arg
) ? XFLOAT (arg
)->data
: XINT (arg
);
754 f2
= (FLOATP (divisor
) ? XFLOAT (divisor
)->data
: XINT (divisor
));
756 Fsignal (Qarith_error
, Qnil
);
758 IN_FLOAT2 (f1
= floor (f1
/ f2
), "floor", arg
, divisor
);
759 FLOAT_TO_INT2 (f1
, arg
, "floor", arg
, divisor
);
768 Fsignal (Qarith_error
, Qnil
);
770 /* With C's /, the result is implementation-defined if either operand
771 is negative, so use only nonnegative operands. */
773 ? (i1
<= 0 ? -i1
/ -i2
: -1 - ((i1
- 1) / -i2
))
774 : (i1
< 0 ? -1 - ((-1 - i1
) / i2
) : i1
/ i2
));
780 #ifdef LISP_FLOAT_TYPE
784 IN_FLOAT (d
= floor (XFLOAT (arg
)->data
), "floor", arg
);
785 FLOAT_TO_INT (d
, arg
, "floor", arg
);
792 #ifdef LISP_FLOAT_TYPE
794 DEFUN ("round", Fround
, Sround
, 1, 1, 0,
795 "Return the nearest integer to ARG.")
797 register Lisp_Object arg
;
799 CHECK_NUMBER_OR_FLOAT (arg
, 0);
805 /* Screw the prevailing rounding mode. */
806 IN_FLOAT (d
= rint (XFLOAT (arg
)->data
), "round", arg
);
807 FLOAT_TO_INT (d
, arg
, "round", arg
);
813 DEFUN ("truncate", Ftruncate
, Struncate
, 1, 1, 0,
814 "Truncate a floating point number to an int.\n\
815 Rounds the value toward zero.")
817 register Lisp_Object arg
;
819 CHECK_NUMBER_OR_FLOAT (arg
, 0);
825 d
= XFLOAT (arg
)->data
;
826 FLOAT_TO_INT (d
, arg
, "truncate", arg
);
832 /* It's not clear these are worth adding. */
834 DEFUN ("fceiling", Ffceiling
, Sfceiling
, 1, 1, 0,
835 "Return the smallest integer no less than ARG, as a float.\n\
836 \(Round toward +inf.\)")
838 register Lisp_Object arg
;
840 double d
= extract_float (arg
);
841 IN_FLOAT (d
= ceil (d
), "fceiling", arg
);
842 return make_float (d
);
845 DEFUN ("ffloor", Fffloor
, Sffloor
, 1, 1, 0,
846 "Return the largest integer no greater than ARG, as a float.\n\
847 \(Round towards -inf.\)")
849 register Lisp_Object arg
;
851 double d
= extract_float (arg
);
852 IN_FLOAT (d
= floor (d
), "ffloor", arg
);
853 return make_float (d
);
856 DEFUN ("fround", Ffround
, Sfround
, 1, 1, 0,
857 "Return the nearest integer to ARG, as a float.")
859 register Lisp_Object arg
;
861 double d
= extract_float (arg
);
862 IN_FLOAT (d
= rint (d
), "fround", arg
);
863 return make_float (d
);
866 DEFUN ("ftruncate", Fftruncate
, Sftruncate
, 1, 1, 0,
867 "Truncate a floating point number to an integral float value.\n\
868 Rounds the value toward zero.")
870 register Lisp_Object arg
;
872 double d
= extract_float (arg
);
874 IN_FLOAT (d
= floor (d
), "ftruncate", arg
);
876 IN_FLOAT (d
= ceil (d
), "ftruncate", arg
);
877 return make_float (d
);
880 #ifdef FLOAT_CATCH_SIGILL
886 fatal_error_signal (signo
);
891 #else /* not BSD4_1 */
892 sigsetmask (SIGEMPTYMASK
);
893 #endif /* not BSD4_1 */
895 /* Must reestablish handler each time it is called. */
896 signal (SIGILL
, float_error
);
897 #endif /* BSD_SYSTEM */
901 Fsignal (Qarith_error
, Fcons (float_error_arg
, Qnil
));
904 /* Another idea was to replace the library function `infnan'
905 where SIGILL is signaled. */
907 #endif /* FLOAT_CATCH_SIGILL */
916 /* Not called from emacs-lisp float routines; do the default thing. */
918 if (!strcmp (x
->name
, "pow"))
922 = Fcons (build_string (x
->name
),
923 Fcons (make_float (x
->arg1
),
924 ((!strcmp (x
->name
, "log") || !strcmp (x
->name
, "pow"))
925 ? Fcons (make_float (x
->arg2
), Qnil
)
929 case DOMAIN
: Fsignal (Qdomain_error
, args
); break;
930 case SING
: Fsignal (Qsingularity_error
, args
); break;
931 case OVERFLOW
: Fsignal (Qoverflow_error
, args
); break;
932 case UNDERFLOW
: Fsignal (Qunderflow_error
, args
); break;
933 default: Fsignal (Qarith_error
, args
); break;
935 return (1); /* don't set errno or print a message */
937 #endif /* HAVE_MATHERR */
941 #ifdef FLOAT_CATCH_SIGILL
942 signal (SIGILL
, float_error
);
947 #else /* not LISP_FLOAT_TYPE */
952 #endif /* not LISP_FLOAT_TYPE */
956 #ifdef LISP_FLOAT_TYPE
970 defsubr (&Sbessel_y0
);
971 defsubr (&Sbessel_y1
);
972 defsubr (&Sbessel_yn
);
973 defsubr (&Sbessel_j0
);
974 defsubr (&Sbessel_j1
);
975 defsubr (&Sbessel_jn
);
978 defsubr (&Slog_gamma
);
979 defsubr (&Scube_root
);
981 defsubr (&Sfceiling
);
984 defsubr (&Sftruncate
);
996 defsubr (&Struncate
);
997 #endif /* LISP_FLOAT_TYPE */