src/floatfns.c

   1 /* Primitive operations on floating point for GNU Emacs Lisp interpreter.
   2    Copyright (C) 1988, 1992 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   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)
   9 any later version.
  10
  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.
  15
  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.  */
  19
  20
  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.
  24
  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.
  29
  30    Define HAVE_MATHERR if on a system supporting the SysV matherr callback.
  31    (This should happen automatically.)
  32
  33    Define FLOAT_CHECK_ERRNO if the float library routines set errno.
  34    This has no effect if HAVE_MATHERR is defined.
  35
  36    Define FLOAT_CATCH_SIGILL if the float library routines signal SIGILL.
  37    (What systems actually do this?  Please let us know.)
  38
  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.)
  44  */
  45
  46 #include <signal.h>
  47
  48 #include "config.h"
  49 #include "lisp.h"
  50 #include "syssignal.h"
  51
  52 Lisp_Object Qarith_error;
  53
  54 #ifdef LISP_FLOAT_TYPE
  55
  56 #include <math.h>
  57
  58 /* These declarations are omitted on some systems, like Ultrix.  */
  59 extern double logb ();
  60
  61 #if defined(DOMAIN) && defined(SING) && defined(OVERFLOW)
  62     /* If those are defined, then this is probably a `matherr' machine. */
  63 # ifndef HAVE_MATHERR
  64 #  define HAVE_MATHERR
  65 # endif
  66 #endif
  67
  68 #ifdef HAVE_MATHERR
  69 # ifdef FLOAT_CHECK_ERRNO
  70 #  undef FLOAT_CHECK_ERRNO
  71 # endif
  72 # ifdef FLOAT_CHECK_DOMAIN
  73 #  undef FLOAT_CHECK_DOMAIN
  74 # endif
  75 #endif
  76
  77 #ifndef NO_FLOAT_CHECK_ERRNO
  78 #define FLOAT_CHECK_ERRNO
  79 #endif
  80
  81 #ifdef FLOAT_CHECK_ERRNO
  82 # include <errno.h>
  83
  84 extern int errno;
  85 #endif
  86
  87 /* Avoid traps on VMS from sinh and cosh.
  88    All the other functions set errno instead.  */
  89
  90 #ifdef VMS
  91 #undef cosh
  92 #undef sinh
  93 #define cosh(x) ((exp(x)+exp(-x))*0.5)
  94 #define sinh(x) ((exp(x)-exp(-x))*0.5)
  95 #endif /* VMS */
  96
  97 #ifndef HAVE_RINT
  98 #define rint(x) (floor((x)+0.5))
  99 #endif
 100
 101 static SIGTYPE float_error ();
 102
 103 /* Nonzero while executing in floating point.
 104    This tells float_error what to do.  */
 105
 106 static int in_float;
 107
 108 /* If an argument is out of range for a mathematical function,
 109    here is the actual argument value to use in the error message.  */
 110
 111 static Lisp_Object float_error_arg, float_error_arg2;
 112
 113 static char *float_error_fn_name;
 114
 115 /* Evaluate the floating point expression D, recording NUM
 116    as the original argument for error messages.
 117    D is normally an assignment expression.
 118    Handle errors which may result in signals or may set errno.
 119
 120    Note that float_error may be declared to return void, so you can't
 121    just cast the zero after the colon to (SIGTYPE) to make the types
 122    check properly.  */
 123
 124 #ifdef FLOAT_CHECK_ERRNO
 125 #define IN_FLOAT(d, name, num)                          \
 126   do {                                                  \
 127     float_error_arg = num;                              \
 128     float_error_fn_name = name;                         \
 129     in_float = 1; errno = 0; (d); in_float = 0;         \
 130     switch (errno) {                                    \
 131     case 0: break;                                      \
 132     case EDOM:   domain_error (float_error_fn_name, float_error_arg);   \
 133     case ERANGE: range_error (float_error_fn_name, float_error_arg);    \
 134     default:     arith_error (float_error_fn_name, float_error_arg);    \
 135     }                                                   \
 136   } while (0)
 137 #define IN_FLOAT2(d, name, num, num2)                   \
 138   do {                                                  \
 139     float_error_arg = num;                              \
 140     float_error_arg2 = num2;                            \
 141     float_error_fn_name = name;                         \
 142     in_float = 1; errno = 0; (d); in_float = 0;         \
 143     switch (errno) {                                    \
 144     case 0: break;                                      \
 145     case EDOM:   domain_error (float_error_fn_name, float_error_arg);   \
 146     case ERANGE: range_error (float_error_fn_name, float_error_arg);    \
 147     default:     arith_error (float_error_fn_name, float_error_arg);    \
 148     }                                                   \
 149   } while (0)
 150 #else
 151 #define IN_FLOAT2(d, name, num, num2) (in_float = 1, (d), in_float = 0)
 152 #endif
 153
 154 #define arith_error(op,arg) \
 155   Fsignal (Qarith_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
 156 #define range_error(op,arg) \
 157   Fsignal (Qrange_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
 158 #define domain_error(op,arg) \
 159   Fsignal (Qdomain_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
 160 #define domain_error2(op,a1,a2) \
 161   Fsignal (Qdomain_error, Fcons (build_string ((op)), Fcons ((a1), Fcons ((a2), Qnil))))
 162
 163 /* Extract a Lisp number as a `double', or signal an error.  */
 164
 165 double
 166 extract_float (num)
 167      Lisp_Object num;
 168 {
 169   CHECK_NUMBER_OR_FLOAT (num, 0);
 170
 171   if (XTYPE (num) == Lisp_Float)
 172     return XFLOAT (num)->data;
 173   return (double) XINT (num);
 174 }
 175 \f
 176 /* Trig functions.  */
 177
 178 DEFUN ("acos", Facos, Sacos, 1, 1, 0,
 179   "Return the inverse cosine of ARG.")
 180   (arg)
 181      register Lisp_Object arg;
 182 {
 183   double d = extract_float (arg);
 184 #ifdef FLOAT_CHECK_DOMAIN
 185   if (d > 1.0 || d < -1.0)
 186     domain_error ("acos", arg);
 187 #endif
 188   IN_FLOAT (d = acos (d), "acos", arg);
 189   return make_float (d);
 190 }
 191
 192 DEFUN ("asin", Fasin, Sasin, 1, 1, 0,
 193   "Return the inverse sine of ARG.")
 194   (arg)
 195      register Lisp_Object arg;
 196 {
 197   double d = extract_float (arg);
 198 #ifdef FLOAT_CHECK_DOMAIN
 199   if (d > 1.0 || d < -1.0)
 200     domain_error ("asin", arg);
 201 #endif
 202   IN_FLOAT (d = asin (d), "asin", arg);
 203   return make_float (d);
 204 }
 205
 206 DEFUN ("atan", Fatan, Satan, 1, 1, 0,
 207   "Return the inverse tangent of ARG.")
 208   (arg)
 209      register Lisp_Object arg;
 210 {
 211   double d = extract_float (arg);
 212   IN_FLOAT (d = atan (d), "atan", arg);
 213   return make_float (d);
 214 }
 215
 216 DEFUN ("cos", Fcos, Scos, 1, 1, 0,
 217   "Return the cosine of ARG.")
 218   (arg)
 219      register Lisp_Object arg;
 220 {
 221   double d = extract_float (arg);
 222   IN_FLOAT (d = cos (d), "cos", arg);
 223   return make_float (d);
 224 }
 225
 226 DEFUN ("sin", Fsin, Ssin, 1, 1, 0,
 227   "Return the sine of ARG.")
 228   (arg)
 229      register Lisp_Object arg;
 230 {
 231   double d = extract_float (arg);
 232   IN_FLOAT (d = sin (d), "sin", arg);
 233   return make_float (d);
 234 }
 235
 236 DEFUN ("tan", Ftan, Stan, 1, 1, 0,
 237   "Return the tangent of ARG.")
 238   (arg)
 239      register Lisp_Object arg;
 240 {
 241   double d = extract_float (arg);
 242   double c = cos (d);
 243 #ifdef FLOAT_CHECK_DOMAIN
 244   if (c == 0.0)
 245     domain_error ("tan", arg);
 246 #endif
 247   IN_FLOAT (d = sin (d) / c, "tan", arg);
 248   return make_float (d);
 249 }
 250 \f
 251 #if 0 /* Leave these out unless we find there's a reason for them.  */
 252
 253 DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0,
 254   "Return the bessel function j0 of ARG.")
 255   (arg)
 256      register Lisp_Object arg;
 257 {
 258   double d = extract_float (arg);
 259   IN_FLOAT (d = j0 (d), "bessel-j0", arg);
 260   return make_float (d);
 261 }
 262
 263 DEFUN ("bessel-j1", Fbessel_j1, Sbessel_j1, 1, 1, 0,
 264   "Return the bessel function j1 of ARG.")
 265   (arg)
 266      register Lisp_Object arg;
 267 {
 268   double d = extract_float (arg);
 269   IN_FLOAT (d = j1 (d), "bessel-j1", arg);
 270   return make_float (d);
 271 }
 272
 273 DEFUN ("bessel-jn", Fbessel_jn, Sbessel_jn, 2, 2, 0,
 274   "Return the order N bessel function output jn of ARG.\n\
 275 The first arg (the order) is truncated to an integer.")
 276   (arg1, arg2)
 277      register Lisp_Object arg1, arg2;
 278 {
 279   int i1 = extract_float (arg1);
 280   double f2 = extract_float (arg2);
 281
 282   IN_FLOAT (f2 = jn (i1, f2), "bessel-jn", arg1);
 283   return make_float (f2);
 284 }
 285
 286 DEFUN ("bessel-y0", Fbessel_y0, Sbessel_y0, 1, 1, 0,
 287   "Return the bessel function y0 of ARG.")
 288   (arg)
 289      register Lisp_Object arg;
 290 {
 291   double d = extract_float (arg);
 292   IN_FLOAT (d = y0 (d), "bessel-y0", arg);
 293   return make_float (d);
 294 }
 295
 296 DEFUN ("bessel-y1", Fbessel_y1, Sbessel_y1, 1, 1, 0,
 297   "Return the bessel function y1 of ARG.")
 298   (arg)
 299      register Lisp_Object arg;
 300 {
 301   double d = extract_float (arg);
 302   IN_FLOAT (d = y1 (d), "bessel-y0", arg);
 303   return make_float (d);
 304 }
 305
 306 DEFUN ("bessel-yn", Fbessel_yn, Sbessel_yn, 2, 2, 0,
 307   "Return the order N bessel function output yn of ARG.\n\
 308 The first arg (the order) is truncated to an integer.")
 309   (arg1, arg2)
 310      register Lisp_Object arg1, arg2;
 311 {
 312   int i1 = extract_float (arg1);
 313   double f2 = extract_float (arg2);
 314
 315   IN_FLOAT (f2 = yn (i1, f2), "bessel-yn", arg1);
 316   return make_float (f2);
 317 }
 318
 319 #endif
 320 \f
 321 #if 0 /* Leave these out unless we see they are worth having.  */
 322
 323 DEFUN ("erf", Ferf, Serf, 1, 1, 0,
 324   "Return the mathematical error function of ARG.")
 325   (arg)
 326      register Lisp_Object arg;
 327 {
 328   double d = extract_float (arg);
 329   IN_FLOAT (d = erf (d), "erf", arg);
 330   return make_float (d);
 331 }
 332
 333 DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0,
 334   "Return the complementary error function of ARG.")
 335   (arg)
 336      register Lisp_Object arg;
 337 {
 338   double d = extract_float (arg);
 339   IN_FLOAT (d = erfc (d), "erfc", arg);
 340   return make_float (d);
 341 }
 342
 343 DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0,
 344   "Return the log gamma of ARG.")
 345   (arg)
 346      register Lisp_Object arg;
 347 {
 348   double d = extract_float (arg);
 349   IN_FLOAT (d = lgamma (d), "log-gamma", arg);
 350   return make_float (d);
 351 }
 352
 353 DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0,
 354   "Return the cube root of ARG.")
 355   (arg)
 356      register Lisp_Object arg;
 357 {
 358   double d = extract_float (arg);
 359 #ifdef HAVE_CBRT
 360   IN_FLOAT (d = cbrt (d), "cube-root", arg);
 361 #else
 362   if (d >= 0.0)
 363     IN_FLOAT (d = pow (d, 1.0/3.0), "cube-root", arg);
 364   else
 365     IN_FLOAT (d = -pow (-d, 1.0/3.0), "cube-root", arg);
 366 #endif
 367   return make_float (d);
 368 }
 369
 370 #endif
 371 \f
 372 DEFUN ("exp", Fexp, Sexp, 1, 1, 0,
 373   "Return the exponential base e of ARG.")
 374   (arg)
 375      register Lisp_Object arg;
 376 {
 377   double d = extract_float (arg);
 378 #ifdef FLOAT_CHECK_DOMAIN
 379   if (d > 709.7827)   /* Assume IEEE doubles here */
 380     range_error ("exp", arg);
 381   else if (d < -709.0)
 382     return make_float (0.0);
 383   else
 384 #endif
 385     IN_FLOAT (d = exp (d), "exp", arg);
 386   return make_float (d);
 387 }
 388
 389 DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
 390   "Return the exponential X ** Y.")
 391   (arg1, arg2)
 392      register Lisp_Object arg1, arg2;
 393 {
 394   double f1, f2;
 395
 396   CHECK_NUMBER_OR_FLOAT (arg1, 0);
 397   CHECK_NUMBER_OR_FLOAT (arg2, 0);
 398   if ((XTYPE (arg1) == Lisp_Int) && /* common lisp spec */
 399       (XTYPE (arg2) == Lisp_Int)) /* don't promote, if both are ints */
 400     {                           /* this can be improved by pre-calculating */
 401       int acc, x, y;            /* some binary powers of x then acumulating */
 402       /* these, therby saving some time. -wsr */
 403       x = XINT (arg1);
 404       y = XINT (arg2);
 405       acc = 1;
 406
 407       if (y < 0)
 408         {
 409           if (x == 1)
 410             acc = 1;
 411           else if (x == -1)
 412             acc = (y & 1) ? -1 : 1;
 413           else
 414             acc = 0;
 415         }
 416       else
 417         {
 418           for (; y > 0; y--)
 419           while (y > 0)
 420             {
 421               if (y & 1)
 422                 acc *= x;
 423               x *= x;
 424               y = (unsigned)y >> 1;
 425             }
 426         }
 427       XSET (x, Lisp_Int, acc);
 428       return x;
 429     }
 430   f1 = (XTYPE (arg1) == Lisp_Float) ? XFLOAT (arg1)->data : XINT (arg1);
 431   f2 = (XTYPE (arg2) == Lisp_Float) ? XFLOAT (arg2)->data : XINT (arg2);
 432   /* Really should check for overflow, too */
 433   if (f1 == 0.0 && f2 == 0.0)
 434     f1 = 1.0;
 435 #ifdef FLOAT_CHECK_DOMAIN
 436   else if ((f1 == 0.0 && f2 < 0.0) || (f1 < 0 && f2 != floor(f2)))
 437     domain_error2 ("expt", arg1, arg2);
 438 #endif
 439   IN_FLOAT (f1 = pow (f1, f2), "expt", arg1);
 440   return make_float (f1);
 441 }
 442
 443 DEFUN ("log", Flog, Slog, 1, 2, 0,
 444   "Return the natural logarithm of ARG.\n\
 445 If second optional argument BASE is given, return log ARG using that base.")
 446   (arg, base)
 447      register Lisp_Object arg, base;
 448 {
 449   double d = extract_float (arg);
 450
 451 #ifdef FLOAT_CHECK_DOMAIN
 452   if (d <= 0.0)
 453     domain_error2 ("log", arg, base);
 454 #endif
 455   if (NILP (base))
 456     IN_FLOAT (d = log (d), "log", arg);
 457   else
 458     {
 459       double b = extract_float (base);
 460
 461 #ifdef FLOAT_CHECK_DOMAIN
 462       if (b <= 0.0 || b == 1.0)
 463         domain_error2 ("log", arg, base);
 464 #endif
 465       if (b == 10.0)
 466         IN_FLOAT2 (d = log10 (d), "log", arg, base);
 467       else
 468         IN_FLOAT2 (d = log (arg) / log (b), "log", arg, base);
 469     }
 470   return make_float (d);
 471 }
 472
 473 DEFUN ("log10", Flog10, Slog10, 1, 1, 0,
 474   "Return the logarithm base 10 of ARG.")
 475   (arg)
 476      register Lisp_Object arg;
 477 {
 478   double d = extract_float (arg);
 479 #ifdef FLOAT_CHECK_DOMAIN
 480   if (d <= 0.0)
 481     domain_error ("log10", arg);
 482 #endif
 483   IN_FLOAT (d = log10 (d), "log10", arg);
 484   return make_float (d);
 485 }
 486
 487 DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
 488   "Return the square root of ARG.")
 489   (arg)
 490      register Lisp_Object arg;
 491 {
 492   double d = extract_float (arg);
 493 #ifdef FLOAT_CHECK_DOMAIN
 494   if (d < 0.0)
 495     domain_error ("sqrt", arg);
 496 #endif
 497   IN_FLOAT (d = sqrt (d), "sqrt", arg);
 498   return make_float (d);
 499 }
 500 \f
 501 #if 0 /* Not clearly worth adding.  */
 502
 503 DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0,
 504   "Return the inverse hyperbolic cosine of ARG.")
 505   (arg)
 506      register Lisp_Object arg;
 507 {
 508   double d = extract_float (arg);
 509 #ifdef FLOAT_CHECK_DOMAIN
 510   if (d < 1.0)
 511     domain_error ("acosh", arg);
 512 #endif
 513 #ifdef HAVE_INVERSE_HYPERBOLIC
 514   IN_FLOAT (d = acosh (d), "acosh", arg);
 515 #else
 516   IN_FLOAT (d = log (d + sqrt (d*d - 1.0)), "acosh", arg);
 517 #endif
 518   return make_float (d);
 519 }
 520
 521 DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0,
 522   "Return the inverse hyperbolic sine of ARG.")
 523   (arg)
 524      register Lisp_Object arg;
 525 {
 526   double d = extract_float (arg);
 527 #ifdef HAVE_INVERSE_HYPERBOLIC
 528   IN_FLOAT (d = asinh (d), "asinh", arg);
 529 #else
 530   IN_FLOAT (d = log (d + sqrt (d*d + 1.0)), "asinh", arg);
 531 #endif
 532   return make_float (d);
 533 }
 534
 535 DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0,
 536   "Return the inverse hyperbolic tangent of ARG.")
 537   (arg)
 538      register Lisp_Object arg;
 539 {
 540   double d = extract_float (arg);
 541 #ifdef FLOAT_CHECK_DOMAIN
 542   if (d >= 1.0 || d <= -1.0)
 543     domain_error ("atanh", arg);
 544 #endif
 545 #ifdef HAVE_INVERSE_HYPERBOLIC
 546   IN_FLOAT (d = atanh (d), "atanh", arg);
 547 #else
 548   IN_FLOAT (d = 0.5 * log ((1.0 + d) / (1.0 - d)), "atanh", arg);
 549 #endif
 550   return make_float (d);
 551 }
 552
 553 DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0,
 554   "Return the hyperbolic cosine of ARG.")
 555   (arg)
 556      register Lisp_Object arg;
 557 {
 558   double d = extract_float (arg);
 559 #ifdef FLOAT_CHECK_DOMAIN
 560   if (d > 710.0 || d < -710.0)
 561     range_error ("cosh", arg);
 562 #endif
 563   IN_FLOAT (d = cosh (d), "cosh", arg);
 564   return make_float (d);
 565 }
 566
 567 DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0,
 568   "Return the hyperbolic sine of ARG.")
 569   (arg)
 570      register Lisp_Object arg;
 571 {
 572   double d = extract_float (arg);
 573 #ifdef FLOAT_CHECK_DOMAIN
 574   if (d > 710.0 || d < -710.0)
 575     range_error ("sinh", arg);
 576 #endif
 577   IN_FLOAT (d = sinh (d), "sinh", arg);
 578   return make_float (d);
 579 }
 580
 581 DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0,
 582   "Return the hyperbolic tangent of ARG.")
 583   (arg)
 584      register Lisp_Object arg;
 585 {
 586   double d = extract_float (arg);
 587   IN_FLOAT (d = tanh (d), "tanh", arg);
 588   return make_float (d);
 589 }
 590 #endif
 591 \f
 592 DEFUN ("abs", Fabs, Sabs, 1, 1, 0,
 593   "Return the absolute value of ARG.")
 594   (arg)
 595      register Lisp_Object arg;
 596 {
 597   CHECK_NUMBER_OR_FLOAT (arg, 0);
 598
 599   if (XTYPE (arg) == Lisp_Float)
 600     IN_FLOAT (arg = make_float (fabs (XFLOAT (arg)->data)), "abs", arg);
 601   else if (XINT (arg) < 0)
 602     XSETINT (arg, - XFASTINT (arg));
 603
 604   return arg;
 605 }
 606
 607 DEFUN ("float", Ffloat, Sfloat, 1, 1, 0,
 608   "Return the floating point number equal to ARG.")
 609   (arg)
 610      register Lisp_Object arg;
 611 {
 612   CHECK_NUMBER_OR_FLOAT (arg, 0);
 613
 614   if (XTYPE (arg) == Lisp_Int)
 615     return make_float ((double) XINT (arg));
 616   else                          /* give 'em the same float back */
 617     return arg;
 618 }
 619
 620 DEFUN ("logb", Flogb, Slogb, 1, 1, 0,
 621   "Returns the integer not greater than the base 2 log of the magnitude of ARG.\n\
 622 This is the same as the exponent of a float.")
 623      (arg)
 624      Lisp_Object arg;
 625 {
 626   Lisp_Object val;
 627   int value;
 628   double f = extract_float (arg);
 629
 630 #ifdef USG
 631   {
 632     int exp;
 633
 634     IN_FLOAT (frexp (f, &exp), "logb", arg);
 635     XSET (val, Lisp_Int, exp-1);
 636   }
 637 #else
 638   IN_FLOAT (value = logb (f), "logb", arg);
 639   XSET (val, Lisp_Int, value);
 640 #endif
 641
 642   return val;
 643 }
 644
 645 /* the rounding functions  */
 646
 647 DEFUN ("ceiling", Fceiling, Sceiling, 1, 1, 0,
 648   "Return the smallest integer no less than ARG.  (Round toward +inf.)")
 649   (arg)
 650      register Lisp_Object arg;
 651 {
 652   CHECK_NUMBER_OR_FLOAT (arg, 0);
 653
 654   if (XTYPE (arg) == Lisp_Float)
 655     IN_FLOAT (XSET (arg, Lisp_Int, ceil (XFLOAT (arg)->data)), "celing", arg);
 656
 657   return arg;
 658 }
 659
 660 DEFUN ("floor", Ffloor, Sfloor, 1, 1, 0,
 661   "Return the largest integer no greater than ARG.  (Round towards -inf.)")
 662   (arg)
 663      register Lisp_Object arg;
 664 {
 665   CHECK_NUMBER_OR_FLOAT (arg, 0);
 666
 667   if (XTYPE (arg) == Lisp_Float)
 668     IN_FLOAT (XSET (arg, Lisp_Int, floor (XFLOAT (arg)->data)), "floor", arg);
 669
 670   return arg;
 671 }
 672
 673 DEFUN ("round", Fround, Sround, 1, 1, 0,
 674   "Return the nearest integer to ARG.")
 675   (arg)
 676      register Lisp_Object arg;
 677 {
 678   CHECK_NUMBER_OR_FLOAT (arg, 0);
 679
 680   if (XTYPE (arg) == Lisp_Float)
 681     /* Screw the prevailing rounding mode.  */
 682     IN_FLOAT (XSET (arg, Lisp_Int, rint (XFLOAT (arg)->data)), "round", arg);
 683
 684   return arg;
 685 }
 686
 687 DEFUN ("truncate", Ftruncate, Struncate, 1, 1, 0,
 688        "Truncate a floating point number to an int.\n\
 689 Rounds the value toward zero.")
 690   (arg)
 691      register Lisp_Object arg;
 692 {
 693   CHECK_NUMBER_OR_FLOAT (arg, 0);
 694
 695   if (XTYPE (arg) == Lisp_Float)
 696     XSET (arg, Lisp_Int, (int) XFLOAT (arg)->data);
 697
 698   return arg;
 699 }
 700 \f
 701 #if 0
 702 /* It's not clear these are worth adding.  */
 703
 704 DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0,
 705   "Return the smallest integer no less than ARG, as a float.\n\
 706 \(Round toward +inf.\)")
 707   (arg)
 708      register Lisp_Object arg;
 709 {
 710   double d = extract_float (arg);
 711   IN_FLOAT (d = ceil (d), "fceiling", arg);
 712   return make_float (d);
 713 }
 714
 715 DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0,
 716   "Return the largest integer no greater than ARG, as a float.\n\
 717 \(Round towards -inf.\)")
 718   (arg)
 719      register Lisp_Object arg;
 720 {
 721   double d = extract_float (arg);
 722   IN_FLOAT (d = floor (d), "ffloor", arg);
 723   return make_float (d);
 724 }
 725
 726 DEFUN ("fround", Ffround, Sfround, 1, 1, 0,
 727   "Return the nearest integer to ARG, as a float.")
 728   (arg)
 729      register Lisp_Object arg;
 730 {
 731   double d = extract_float (arg);
 732   IN_FLOAT (d = rint (XFLOAT (arg)->data), "fround", arg);
 733   return make_float (d);
 734 }
 735
 736 DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0,
 737        "Truncate a floating point number to an integral float value.\n\
 738 Rounds the value toward zero.")
 739   (arg)
 740      register Lisp_Object arg;
 741 {
 742   double d = extract_float (arg);
 743   if (d >= 0.0)
 744     IN_FLOAT (d = floor (d), "ftruncate", arg);
 745   else
 746     IN_FLOAT (d = ceil (d), arg);
 747   return make_float (d);
 748 }
 749 #endif
 750 \f
 751 #ifdef FLOAT_CATCH_SIGILL
 752 static SIGTYPE
 753 float_error (signo)
 754      int signo;
 755 {
 756   if (! in_float)
 757     fatal_error_signal (signo);
 758
 759 #ifdef BSD
 760 #ifdef BSD4_1
 761   sigrelse (SIGILL);
 762 #else /* not BSD4_1 */
 763   sigsetmask (SIGEMPTYMASK);
 764 #endif /* not BSD4_1 */
 765 #else
 766   /* Must reestablish handler each time it is called.  */
 767   signal (SIGILL, float_error);
 768 #endif /* BSD */
 769
 770   in_float = 0;
 771
 772   Fsignal (Qarith_error, Fcons (float_error_arg, Qnil));
 773 }
 774
 775 /* Another idea was to replace the library function `infnan'
 776    where SIGILL is signaled.  */
 777
 778 #endif /* FLOAT_CATCH_SIGILL */
 779
 780 #ifdef HAVE_MATHERR
 781 int
 782 matherr (x)
 783      struct exception *x;
 784 {
 785   Lisp_Object args;
 786   if (! in_float)
 787     /* Not called from emacs-lisp float routines; do the default thing. */
 788     return 0;
 789   if (!strcmp (x->name, "pow"))
 790     x->name = "expt";
 791
 792   args
 793     = Fcons (build_string (x->name),
 794              Fcons (make_float (x->arg1),
 795                     ((!strcmp (x->name, "log") || !strcmp (x->name, "pow"))
 796                      ? Fcons (make_float (x->arg2), Qnil)
 797                      : Qnil)));
 798   switch (x->type)
 799     {
 800     case DOMAIN:        Fsignal (Qdomain_error, args);          break;
 801     case SING:          Fsignal (Qsingularity_error, args);     break;
 802     case OVERFLOW:      Fsignal (Qoverflow_error, args);        break;
 803     case UNDERFLOW:     Fsignal (Qunderflow_error, args);       break;
 804     default:            Fsignal (Qarith_error, args);           break;
 805     }
 806   return (1);   /* don't set errno or print a message */
 807 }
 808 #endif /* HAVE_MATHERR */
 809
 810 init_floatfns ()
 811 {
 812 #ifdef FLOAT_CATCH_SIGILL
 813   signal (SIGILL, float_error);
 814 #endif
 815   in_float = 0;
 816 }
 817
 818 syms_of_floatfns ()
 819 {
 820   defsubr (&Sacos);
 821   defsubr (&Sasin);
 822   defsubr (&Satan);
 823   defsubr (&Scos);
 824   defsubr (&Ssin);
 825   defsubr (&Stan);
 826 #if 0
 827   defsubr (&Sacosh);
 828   defsubr (&Sasinh);
 829   defsubr (&Satanh);
 830   defsubr (&Scosh);
 831   defsubr (&Ssinh);
 832   defsubr (&Stanh);
 833   defsubr (&Sbessel_y0);
 834   defsubr (&Sbessel_y1);
 835   defsubr (&Sbessel_yn);
 836   defsubr (&Sbessel_j0);
 837   defsubr (&Sbessel_j1);
 838   defsubr (&Sbessel_jn);
 839   defsubr (&Serf);
 840   defsubr (&Serfc);
 841   defsubr (&Slog_gamma);
 842   defsubr (&Scube_root);
 843   defsubr (&Sfceiling);
 844   defsubr (&Sffloor);
 845   defsubr (&Sfround);
 846   defsubr (&Sftruncate);
 847 #endif
 848   defsubr (&Sexp);
 849   defsubr (&Sexpt);
 850   defsubr (&Slog);
 851   defsubr (&Slog10);
 852   defsubr (&Ssqrt);
 853
 854   defsubr (&Sabs);
 855   defsubr (&Sfloat);
 856   defsubr (&Slogb);
 857   defsubr (&Sceiling);
 858   defsubr (&Sfloor);
 859   defsubr (&Sround);
 860   defsubr (&Struncate);
 861 }
 862
 863 #else /* not LISP_FLOAT_TYPE */
 864
 865 init_floatfns ()
 866 {}
 867
 868 syms_of_floatfns ()
 869 {}
 870
 871 #endif /* not LISP_FLOAT_TYPE */