#include <config.h>
#include <signal.h>
#include "lisp.h"
#include "syssignal.h"
#if STDC_HEADERS
#include <float.h>
#endif
#ifndef IEEE_FLOATING_POINT
#if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
&& FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
#define IEEE_FLOATING_POINT 1
#else
#define IEEE_FLOATING_POINT 0
#endif
#endif
#if defined (HPUX) && !defined (HPUX8)
#define _MAXLDBL floatfns_maxldbl
#define _NMAXLDBL floatfns_nmaxldbl
#endif
#include <math.h>
#if !defined (HPUX) && defined (HAVE_LOGB) && !defined (logb)
extern double logb ();
#endif
#if defined(DOMAIN) && defined(SING) && defined(OVERFLOW)
# ifndef HAVE_MATHERR
# define HAVE_MATHERR
# endif
#endif
#ifdef NO_MATHERR
#undef HAVE_MATHERR
#endif
#ifdef HAVE_MATHERR
# ifdef FLOAT_CHECK_ERRNO
# undef FLOAT_CHECK_ERRNO
# endif
# ifdef FLOAT_CHECK_DOMAIN
# undef FLOAT_CHECK_DOMAIN
# endif
#endif
#ifndef NO_FLOAT_CHECK_ERRNO
#define FLOAT_CHECK_ERRNO
#endif
#ifdef FLOAT_CHECK_ERRNO
# include <errno.h>
#ifndef USE_CRT_DLL
extern int errno;
#endif
#endif
#ifdef VMS
#undef cosh
#undef sinh
#define cosh(x) ((exp(x)+exp(-x))*0.5)
#define sinh(x) ((exp(x)-exp(-x))*0.5)
#endif
static SIGTYPE float_error ();
static int in_float;
static Lisp_Object float_error_arg, float_error_arg2;
static char *float_error_fn_name;
#ifdef FLOAT_CHECK_ERRNO
#define IN_FLOAT(d, name, num) \
do { \
float_error_arg = num; \
float_error_fn_name = name; \
in_float = 1; errno = 0; (d); in_float = 0; \
switch (errno) { \
case 0: break; \
case EDOM: domain_error (float_error_fn_name, float_error_arg); \
case ERANGE: range_error (float_error_fn_name, float_error_arg); \
default: arith_error (float_error_fn_name, float_error_arg); \
} \
} while (0)
#define IN_FLOAT2(d, name, num, num2) \
do { \
float_error_arg = num; \
float_error_arg2 = num2; \
float_error_fn_name = name; \
in_float = 1; errno = 0; (d); in_float = 0; \
switch (errno) { \
case 0: break; \
case EDOM: domain_error (float_error_fn_name, float_error_arg); \
case ERANGE: range_error (float_error_fn_name, float_error_arg); \
default: arith_error (float_error_fn_name, float_error_arg); \
} \
} while (0)
#else
#define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0)
#define IN_FLOAT2(d, name, num, num2) (in_float = 1, (d), in_float = 0)
#endif
#define FLOAT_TO_INT(x, i, name, num) \
do \
{ \
if ((x) >= (((EMACS_INT) 1) << (VALBITS-1)) || \
(x) <= - (((EMACS_INT) 1) << (VALBITS-1)) - 1) \
range_error (name, num); \
XSETINT (i, (EMACS_INT)(x)); \
} \
while (0)
#define FLOAT_TO_INT2(x, i, name, num1, num2) \
do \
{ \
if ((x) >= (((EMACS_INT) 1) << (VALBITS-1)) || \
(x) <= - (((EMACS_INT) 1) << (VALBITS-1)) - 1) \
range_error2 (name, num1, num2); \
XSETINT (i, (EMACS_INT)(x)); \
} \
while (0)
#define arith_error(op,arg) \
Fsignal (Qarith_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
#define range_error(op,arg) \
Fsignal (Qrange_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
#define range_error2(op,a1,a2) \
Fsignal (Qrange_error, Fcons (build_string ((op)), \
Fcons ((a1), Fcons ((a2), Qnil))))
#define domain_error(op,arg) \
Fsignal (Qdomain_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
#define domain_error2(op,a1,a2) \
Fsignal (Qdomain_error, Fcons (build_string ((op)), \
Fcons ((a1), Fcons ((a2), Qnil))))
double
extract_float (num)
Lisp_Object num;
{
CHECK_NUMBER_OR_FLOAT (num, 0);
if (FLOATP (num))
return XFLOAT_DATA (num);
return (double) XINT (num);
}
DEFUN ("acos", Facos, Sacos, 1, 1, 0,
"Return the inverse cosine of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
if (d > 1.0 || d < -1.0)
domain_error ("acos", arg);
#endif
IN_FLOAT (d = acos (d), "acos", arg);
return make_float (d);
}
DEFUN ("asin", Fasin, Sasin, 1, 1, 0,
"Return the inverse sine of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
if (d > 1.0 || d < -1.0)
domain_error ("asin", arg);
#endif
IN_FLOAT (d = asin (d), "asin", arg);
return make_float (d);
}
DEFUN ("atan", Fatan, Satan, 1, 1, 0,
"Return the inverse tangent of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
IN_FLOAT (d = atan (d), "atan", arg);
return make_float (d);
}
DEFUN ("cos", Fcos, Scos, 1, 1, 0,
"Return the cosine of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
IN_FLOAT (d = cos (d), "cos", arg);
return make_float (d);
}
DEFUN ("sin", Fsin, Ssin, 1, 1, 0,
"Return the sine of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
IN_FLOAT (d = sin (d), "sin", arg);
return make_float (d);
}
DEFUN ("tan", Ftan, Stan, 1, 1, 0,
"Return the tangent of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
double c = cos (d);
#ifdef FLOAT_CHECK_DOMAIN
if (c == 0.0)
domain_error ("tan", arg);
#endif
IN_FLOAT (d = sin (d) / c, "tan", arg);
return make_float (d);
}
#if 0
DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0,
"Return the bessel function j0 of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
IN_FLOAT (d = j0 (d), "bessel-j0", arg);
return make_float (d);
}
DEFUN ("bessel-j1", Fbessel_j1, Sbessel_j1, 1, 1, 0,
"Return the bessel function j1 of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
IN_FLOAT (d = j1 (d), "bessel-j1", arg);
return make_float (d);
}
DEFUN ("bessel-jn", Fbessel_jn, Sbessel_jn, 2, 2, 0,
"Return the order N bessel function output jn of ARG.\n\
The first arg (the order) is truncated to an integer.")
(n, arg)
register Lisp_Object n, arg;
{
int i1 = extract_float (n);
double f2 = extract_float (arg);
IN_FLOAT (f2 = jn (i1, f2), "bessel-jn", n);
return make_float (f2);
}
DEFUN ("bessel-y0", Fbessel_y0, Sbessel_y0, 1, 1, 0,
"Return the bessel function y0 of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
IN_FLOAT (d = y0 (d), "bessel-y0", arg);
return make_float (d);
}
DEFUN ("bessel-y1", Fbessel_y1, Sbessel_y1, 1, 1, 0,
"Return the bessel function y1 of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
IN_FLOAT (d = y1 (d), "bessel-y0", arg);
return make_float (d);
}
DEFUN ("bessel-yn", Fbessel_yn, Sbessel_yn, 2, 2, 0,
"Return the order N bessel function output yn of ARG.\n\
The first arg (the order) is truncated to an integer.")
(n, arg)
register Lisp_Object n, arg;
{
int i1 = extract_float (n);
double f2 = extract_float (arg);
IN_FLOAT (f2 = yn (i1, f2), "bessel-yn", n);
return make_float (f2);
}
#endif
#if 0
DEFUN ("erf", Ferf, Serf, 1, 1, 0,
"Return the mathematical error function of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
IN_FLOAT (d = erf (d), "erf", arg);
return make_float (d);
}
DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0,
"Return the complementary error function of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
IN_FLOAT (d = erfc (d), "erfc", arg);
return make_float (d);
}
DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0,
"Return the log gamma of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
IN_FLOAT (d = lgamma (d), "log-gamma", arg);
return make_float (d);
}
DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0,
"Return the cube root of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
#ifdef HAVE_CBRT
IN_FLOAT (d = cbrt (d), "cube-root", arg);
#else
if (d >= 0.0)
IN_FLOAT (d = pow (d, 1.0/3.0), "cube-root", arg);
else
IN_FLOAT (d = -pow (-d, 1.0/3.0), "cube-root", arg);
#endif
return make_float (d);
}
#endif
DEFUN ("exp", Fexp, Sexp, 1, 1, 0,
"Return the exponential base e of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
if (d > 709.7827)
range_error ("exp", arg);
else if (d < -709.0)
return make_float (0.0);
else
#endif
IN_FLOAT (d = exp (d), "exp", arg);
return make_float (d);
}
DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
"Return the exponential ARG1 ** ARG2.")
(arg1, arg2)
register Lisp_Object arg1, arg2;
{
double f1, f2;
CHECK_NUMBER_OR_FLOAT (arg1, 0);
CHECK_NUMBER_OR_FLOAT (arg2, 0);
if (INTEGERP (arg1)
&& INTEGERP (arg2))
{
EMACS_INT acc, x, y;
Lisp_Object val;
x = XINT (arg1);
y = XINT (arg2);
acc = 1;
if (y < 0)
{
if (x == 1)
acc = 1;
else if (x == -1)
acc = (y & 1) ? -1 : 1;
else
acc = 0;
}
else
{
while (y > 0)
{
if (y & 1)
acc *= x;
x *= x;
y = (unsigned)y >> 1;
}
}
XSETINT (val, acc);
return val;
}
f1 = FLOATP (arg1) ? XFLOAT_DATA (arg1) : XINT (arg1);
f2 = FLOATP (arg2) ? XFLOAT_DATA (arg2) : XINT (arg2);
if (f1 == 0.0 && f2 == 0.0)
f1 = 1.0;
#ifdef FLOAT_CHECK_DOMAIN
else if ((f1 == 0.0 && f2 < 0.0) || (f1 < 0 && f2 != floor(f2)))
domain_error2 ("expt", arg1, arg2);
#endif
IN_FLOAT2 (f1 = pow (f1, f2), "expt", arg1, arg2);
return make_float (f1);
}
DEFUN ("log", Flog, Slog, 1, 2, 0,
"Return the natural logarithm of ARG.\n\
If second optional argument BASE is given, return log ARG using that base.")
(arg, base)
register Lisp_Object arg, base;
{
double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
if (d <= 0.0)
domain_error2 ("log", arg, base);
#endif
if (NILP (base))
IN_FLOAT (d = log (d), "log", arg);
else
{
double b = extract_float (base);
#ifdef FLOAT_CHECK_DOMAIN
if (b <= 0.0 || b == 1.0)
domain_error2 ("log", arg, base);
#endif
if (b == 10.0)
IN_FLOAT2 (d = log10 (d), "log", arg, base);
else
IN_FLOAT2 (d = log (d) / log (b), "log", arg, base);
}
return make_float (d);
}
DEFUN ("log10", Flog10, Slog10, 1, 1, 0,
"Return the logarithm base 10 of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
if (d <= 0.0)
domain_error ("log10", arg);
#endif
IN_FLOAT (d = log10 (d), "log10", arg);
return make_float (d);
}
DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
"Return the square root of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
if (d < 0.0)
domain_error ("sqrt", arg);
#endif
IN_FLOAT (d = sqrt (d), "sqrt", arg);
return make_float (d);
}
#if 0
DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0,
"Return the inverse hyperbolic cosine of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
if (d < 1.0)
domain_error ("acosh", arg);
#endif
#ifdef HAVE_INVERSE_HYPERBOLIC
IN_FLOAT (d = acosh (d), "acosh", arg);
#else
IN_FLOAT (d = log (d + sqrt (d*d - 1.0)), "acosh", arg);
#endif
return make_float (d);
}
DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0,
"Return the inverse hyperbolic sine of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
#ifdef HAVE_INVERSE_HYPERBOLIC
IN_FLOAT (d = asinh (d), "asinh", arg);
#else
IN_FLOAT (d = log (d + sqrt (d*d + 1.0)), "asinh", arg);
#endif
return make_float (d);
}
DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0,
"Return the inverse hyperbolic tangent of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
if (d >= 1.0 || d <= -1.0)
domain_error ("atanh", arg);
#endif
#ifdef HAVE_INVERSE_HYPERBOLIC
IN_FLOAT (d = atanh (d), "atanh", arg);
#else
IN_FLOAT (d = 0.5 * log ((1.0 + d) / (1.0 - d)), "atanh", arg);
#endif
return make_float (d);
}
DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0,
"Return the hyperbolic cosine of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
if (d > 710.0 || d < -710.0)
range_error ("cosh", arg);
#endif
IN_FLOAT (d = cosh (d), "cosh", arg);
return make_float (d);
}
DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0,
"Return the hyperbolic sine of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
if (d > 710.0 || d < -710.0)
range_error ("sinh", arg);
#endif
IN_FLOAT (d = sinh (d), "sinh", arg);
return make_float (d);
}
DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0,
"Return the hyperbolic tangent of ARG.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
IN_FLOAT (d = tanh (d), "tanh", arg);
return make_float (d);
}
#endif
DEFUN ("abs", Fabs, Sabs, 1, 1, 0,
"Return the absolute value of ARG.")
(arg)
register Lisp_Object arg;
{
CHECK_NUMBER_OR_FLOAT (arg, 0);
if (FLOATP (arg))
IN_FLOAT (arg = make_float (fabs (XFLOAT_DATA (arg))), "abs", arg);
else if (XINT (arg) < 0)
XSETINT (arg, - XINT (arg));
return arg;
}
DEFUN ("float", Ffloat, Sfloat, 1, 1, 0,
"Return the floating point number equal to ARG.")
(arg)
register Lisp_Object arg;
{
CHECK_NUMBER_OR_FLOAT (arg, 0);
if (INTEGERP (arg))
return make_float ((double) XINT (arg));
else
return arg;
}
DEFUN ("logb", Flogb, Slogb, 1, 1, 0,
"Returns largest integer <= the base 2 log of the magnitude of ARG.\n\
This is the same as the exponent of a float.")
(arg)
Lisp_Object arg;
{
Lisp_Object val;
EMACS_INT value;
double f = extract_float (arg);
if (f == 0.0)
value = -(VALMASK >> 1);
else
{
#ifdef HAVE_LOGB
IN_FLOAT (value = logb (f), "logb", arg);
#else
#ifdef HAVE_FREXP
int ivalue;
IN_FLOAT (frexp (f, &ivalue), "logb", arg);
value = ivalue - 1;
#else
int i;
double d;
if (f < 0.0)
f = -f;
value = -1;
while (f < 0.5)
{
for (i = 1, d = 0.5; d * d >= f; i += i)
d *= d;
f /= d;
value -= i;
}
while (f >= 1.0)
{
for (i = 1, d = 2.0; d * d <= f; i += i)
d *= d;
f /= d;
value += i;
}
#endif
#endif
}
XSETINT (val, value);
return val;
}
static Lisp_Object
rounding_driver (arg, divisor, double_round, int_round2, name)
register Lisp_Object arg, divisor;
double (*double_round) ();
EMACS_INT (*int_round2) ();
char *name;
{
CHECK_NUMBER_OR_FLOAT (arg, 0);
if (! NILP (divisor))
{
EMACS_INT i1, i2;
CHECK_NUMBER_OR_FLOAT (divisor, 1);
if (FLOATP (arg) || FLOATP (divisor))
{
double f1, f2;
f1 = FLOATP (arg) ? XFLOAT_DATA (arg) : XINT (arg);
f2 = (FLOATP (divisor) ? XFLOAT_DATA (divisor) : XINT (divisor));
if (! IEEE_FLOATING_POINT && f2 == 0)
Fsignal (Qarith_error, Qnil);
IN_FLOAT2 (f1 = (*double_round) (f1 / f2), name, arg, divisor);
FLOAT_TO_INT2 (f1, arg, name, arg, divisor);
return arg;
}
i1 = XINT (arg);
i2 = XINT (divisor);
if (i2 == 0)
Fsignal (Qarith_error, Qnil);
XSETINT (arg, (*int_round2) (i1, i2));
return arg;
}
if (FLOATP (arg))
{
double d;
IN_FLOAT (d = (*double_round) (XFLOAT_DATA (arg)), name, arg);
FLOAT_TO_INT (d, arg, name, arg);
}
return arg;
}
static EMACS_INT
ceiling2 (i1, i2)
EMACS_INT i1, i2;
{
return (i2 < 0
? (i1 < 0 ? ((-1 - i1) / -i2) + 1 : - (i1 / -i2))
: (i1 <= 0 ? - (-i1 / i2) : ((i1 - 1) / i2) + 1));
}
static EMACS_INT
floor2 (i1, i2)
EMACS_INT i1, i2;
{
return (i2 < 0
? (i1 <= 0 ? -i1 / -i2 : -1 - ((i1 - 1) / -i2))
: (i1 < 0 ? -1 - ((-1 - i1) / i2) : i1 / i2));
}
static EMACS_INT
truncate2 (i1, i2)
EMACS_INT i1, i2;
{
return (i2 < 0
? (i1 < 0 ? -i1 / -i2 : - (i1 / -i2))
: (i1 < 0 ? - (-i1 / i2) : i1 / i2));
}
static EMACS_INT
round2 (i1, i2)
EMACS_INT i1, i2;
{
EMACS_INT q = i1 / i2;
EMACS_INT r = i1 % i2;
EMACS_INT abs_r = r < 0 ? -r : r;
EMACS_INT abs_r1 = (i2 < 0 ? -i2 : i2) - abs_r;
return q + (abs_r + (q & 1) <= abs_r1 ? 0 : (i2 ^ r) < 0 ? -1 : 1);
}
#ifdef HAVE_RINT
#define emacs_rint rint
#else
static double
emacs_rint (d)
double d;
{
return floor (d + 0.5);
}
#endif
static double
double_identity (d)
double d;
{
return d;
}
DEFUN ("ceiling", Fceiling, Sceiling, 1, 2, 0,
"Return the smallest integer no less than ARG. (Round toward +inf.)\n\
With optional DIVISOR, return the smallest integer no less than ARG/DIVISOR.")
(arg, divisor)
Lisp_Object arg, divisor;
{
return rounding_driver (arg, divisor, ceil, ceiling2, "ceiling");
}
DEFUN ("floor", Ffloor, Sfloor, 1, 2, 0,
"Return the largest integer no greater than ARG. (Round towards -inf.)\n\
With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR.")
(arg, divisor)
Lisp_Object arg, divisor;
{
return rounding_driver (arg, divisor, floor, floor2, "floor");
}
DEFUN ("round", Fround, Sround, 1, 2, 0,
"Return the nearest integer to ARG.\n\
With optional DIVISOR, return the nearest integer to ARG/DIVISOR.\n\
\n\
Rounding a value equidistant between two integers may choose the\n\
integer closer to zero, or it may prefer an even integer, depending on\n\
your machine. For example, \(round 2.5\) can return 3 on some\n\
systems, but 2 on others.")
(arg, divisor)
Lisp_Object arg, divisor;
{
return rounding_driver (arg, divisor, emacs_rint, round2, "round");
}
DEFUN ("truncate", Ftruncate, Struncate, 1, 2, 0,
"Truncate a floating point number to an int.\n\
Rounds ARG toward zero.\n\
With optional DIVISOR, truncate ARG/DIVISOR.")
(arg, divisor)
Lisp_Object arg, divisor;
{
return rounding_driver (arg, divisor, double_identity, truncate2,
"truncate");
}
Lisp_Object
fmod_float (x, y)
register Lisp_Object x, y;
{
double f1, f2;
f1 = FLOATP (x) ? XFLOAT_DATA (x) : XINT (x);
f2 = FLOATP (y) ? XFLOAT_DATA (y) : XINT (y);
if (! IEEE_FLOATING_POINT && f2 == 0)
Fsignal (Qarith_error, Qnil);
IN_FLOAT2 ((f1 = fmod (f1, f2),
f1 = (f2 < 0 ? f1 > 0 : f1 < 0) ? f1 + f2 : f1),
"mod", x, y);
return make_float (f1);
}
DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0,
"Return the smallest integer no less than ARG, as a float.\n\
\(Round toward +inf.\)")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
IN_FLOAT (d = ceil (d), "fceiling", arg);
return make_float (d);
}
DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0,
"Return the largest integer no greater than ARG, as a float.\n\
\(Round towards -inf.\)")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
IN_FLOAT (d = floor (d), "ffloor", arg);
return make_float (d);
}
DEFUN ("fround", Ffround, Sfround, 1, 1, 0,
"Return the nearest integer to ARG, as a float.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
IN_FLOAT (d = emacs_rint (d), "fround", arg);
return make_float (d);
}
DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0,
"Truncate a floating point number to an integral float value.\n\
Rounds the value toward zero.")
(arg)
register Lisp_Object arg;
{
double d = extract_float (arg);
if (d >= 0.0)
IN_FLOAT (d = floor (d), "ftruncate", arg);
else
IN_FLOAT (d = ceil (d), "ftruncate", arg);
return make_float (d);
}
#ifdef FLOAT_CATCH_SIGILL
static SIGTYPE
float_error (signo)
int signo;
{
if (! in_float)
fatal_error_signal (signo);
#ifdef BSD_SYSTEM
#ifdef BSD4_1
sigrelse (SIGILL);
#else
sigsetmask (SIGEMPTYMASK);
#endif
#else
signal (SIGILL, float_error);
#endif
in_float = 0;
Fsignal (Qarith_error, Fcons (float_error_arg, Qnil));
}
#endif
#ifdef HAVE_MATHERR
#ifdef __APPLE_CC__
__private_extern__
#endif
int
matherr (x)
struct exception *x;
{
Lisp_Object args;
if (! in_float)
return 0;
if (!strcmp (x->name, "pow"))
x->name = "expt";
args
= Fcons (build_string (x->name),
Fcons (make_float (x->arg1),
((!strcmp (x->name, "log") || !strcmp (x->name, "pow"))
? Fcons (make_float (x->arg2), Qnil)
: Qnil)));
switch (x->type)
{
case DOMAIN: Fsignal (Qdomain_error, args); break;
case SING: Fsignal (Qsingularity_error, args); break;
case OVERFLOW: Fsignal (Qoverflow_error, args); break;
case UNDERFLOW: Fsignal (Qunderflow_error, args); break;
default: Fsignal (Qarith_error, args); break;
}
return (1);
}
#endif
void
init_floatfns ()
{
#ifdef FLOAT_CATCH_SIGILL
signal (SIGILL, float_error);
#endif
in_float = 0;
}
void
syms_of_floatfns ()
{
defsubr (&Sacos);
defsubr (&Sasin);
defsubr (&Satan);
defsubr (&Scos);
defsubr (&Ssin);
defsubr (&Stan);
#if 0
defsubr (&Sacosh);
defsubr (&Sasinh);
defsubr (&Satanh);
defsubr (&Scosh);
defsubr (&Ssinh);
defsubr (&Stanh);
defsubr (&Sbessel_y0);
defsubr (&Sbessel_y1);
defsubr (&Sbessel_yn);
defsubr (&Sbessel_j0);
defsubr (&Sbessel_j1);
defsubr (&Sbessel_jn);
defsubr (&Serf);
defsubr (&Serfc);
defsubr (&Slog_gamma);
defsubr (&Scube_root);
#endif
defsubr (&Sfceiling);
defsubr (&Sffloor);
defsubr (&Sfround);
defsubr (&Sftruncate);
defsubr (&Sexp);
defsubr (&Sexpt);
defsubr (&Slog);
defsubr (&Slog10);
defsubr (&Ssqrt);
defsubr (&Sabs);
defsubr (&Sfloat);
defsubr (&Slogb);
defsubr (&Sceiling);
defsubr (&Sfloor);
defsubr (&Sround);
defsubr (&Struncate);
}