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