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 not greater than the base 2 log of the magnitude of ARG.\n\
 619 This is the same as the exponent of a float.")
 620      (arg)
 621      Lisp_Object arg;
 622 {
 623 #ifdef USG
 624   error ("SYSV apparently doesn't have a logb function; what to do?");
 625 #else
 626   Lisp_Object val;
 627   int value;
 628   double f = extract_float (arg);
 629
 630   IN_FLOAT (value = logb (f), "logb", arg);
 631   XSET (val, Lisp_Int, value);
 632   return val;
 633 #endif
 634 }
 635
 636 /* the rounding functions  */
 637
 638 DEFUN ("ceiling", Fceiling, Sceiling, 1, 1, 0,
 639   "Return the smallest integer no less than ARG.  (Round toward +inf.)")
 640   (arg)
 641      register Lisp_Object arg;
 642 {
 643   CHECK_NUMBER_OR_FLOAT (arg, 0);
 644
 645   if (XTYPE (arg) == Lisp_Float)
 646     IN_FLOAT (XSET (arg, Lisp_Int, ceil (XFLOAT (arg)->data)), "celing", arg);
 647
 648   return arg;
 649 }
 650
 651 DEFUN ("floor", Ffloor, Sfloor, 1, 1, 0,
 652   "Return the largest integer no greater than ARG.  (Round towards -inf.)")
 653   (arg)
 654      register Lisp_Object arg;
 655 {
 656   CHECK_NUMBER_OR_FLOAT (arg, 0);
 657
 658   if (XTYPE (arg) == Lisp_Float)
 659     IN_FLOAT (XSET (arg, Lisp_Int, floor (XFLOAT (arg)->data)), "floor", arg);
 660
 661   return arg;
 662 }
 663
 664 DEFUN ("round", Fround, Sround, 1, 1, 0,
 665   "Return the nearest integer to ARG.")
 666   (arg)
 667      register Lisp_Object arg;
 668 {
 669   CHECK_NUMBER_OR_FLOAT (arg, 0);
 670
 671   if (XTYPE (arg) == Lisp_Float)
 672     /* Screw the prevailing rounding mode.  */
 673     IN_FLOAT (XSET (arg, Lisp_Int, rint (XFLOAT (arg)->data)), "round", arg);
 674
 675   return arg;
 676 }
 677
 678 DEFUN ("truncate", Ftruncate, Struncate, 1, 1, 0,
 679        "Truncate a floating point number to an int.\n\
 680 Rounds the value toward zero.")
 681   (arg)
 682      register Lisp_Object arg;
 683 {
 684   CHECK_NUMBER_OR_FLOAT (arg, 0);
 685
 686   if (XTYPE (arg) == Lisp_Float)
 687     XSET (arg, Lisp_Int, (int) XFLOAT (arg)->data);
 688
 689   return arg;
 690 }
 691 \f
 692 #if 0
 693 /* It's not clear these are worth adding.  */
 694
 695 DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0,
 696   "Return the smallest integer no less than ARG, as a float.\n\
 697 \(Round toward +inf.\)")
 698   (arg)
 699      register Lisp_Object arg;
 700 {
 701   double d = extract_float (arg);
 702   IN_FLOAT (d = ceil (d), "fceiling", arg);
 703   return make_float (d);
 704 }
 705
 706 DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0,
 707   "Return the largest integer no greater than ARG, as a float.\n\
 708 \(Round towards -inf.\)")
 709   (arg)
 710      register Lisp_Object arg;
 711 {
 712   double d = extract_float (arg);
 713   IN_FLOAT (d = floor (d), "ffloor", arg);
 714   return make_float (d);
 715 }
 716
 717 DEFUN ("fround", Ffround, Sfround, 1, 1, 0,
 718   "Return the nearest integer to ARG, as a float.")
 719   (arg)
 720      register Lisp_Object arg;
 721 {
 722   double d = extract_float (arg);
 723   IN_FLOAT (d = rint (XFLOAT (arg)->data), "fround", arg);
 724   return make_float (d);
 725 }
 726
 727 DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0,
 728        "Truncate a floating point number to an integral float value.\n\
 729 Rounds the value toward zero.")
 730   (arg)
 731      register Lisp_Object arg;
 732 {
 733   double d = extract_float (arg);
 734   if (d >= 0.0)
 735     IN_FLOAT (d = floor (d), "ftruncate", arg);
 736   else
 737     IN_FLOAT (d = ceil (d), arg);
 738   return make_float (d);
 739 }
 740 #endif
 741 \f
 742 #ifdef FLOAT_CATCH_SIGILL
 743 static SIGTYPE
 744 float_error (signo)
 745      int signo;
 746 {
 747   if (! in_float)
 748     fatal_error_signal (signo);
 749
 750 #ifdef BSD
 751 #ifdef BSD4_1
 752   sigrelse (SIGILL);
 753 #else /* not BSD4_1 */
 754   sigsetmask (SIGEMPTYMASK);
 755 #endif /* not BSD4_1 */
 756 #else
 757   /* Must reestablish handler each time it is called.  */
 758   signal (SIGILL, float_error);
 759 #endif /* BSD */
 760
 761   in_float = 0;
 762
 763   Fsignal (Qarith_error, Fcons (float_error_arg, Qnil));
 764 }
 765
 766 /* Another idea was to replace the library function `infnan'
 767    where SIGILL is signaled.  */
 768
 769 #endif /* FLOAT_CATCH_SIGILL */
 770
 771 #ifdef HAVE_MATHERR
 772 int
 773 matherr (x)
 774      struct exception *x;
 775 {
 776   Lisp_Object args;
 777   if (! in_float)
 778     /* Not called from emacs-lisp float routines; do the default thing. */
 779     return 0;
 780   if (!strcmp (x->name, "pow"))
 781     x->name = "expt";
 782
 783   args
 784     = Fcons (build_string (x->name),
 785              Fcons (make_float (x->arg1),
 786                     ((!strcmp (x->name, "log") || !strcmp (x->name, "pow"))
 787                      ? Fcons (make_float (x->arg2), Qnil)
 788                      : Qnil)));
 789   switch (x->type)
 790     {
 791     case DOMAIN:        Fsignal (Qdomain_error, args);          break;
 792     case SING:          Fsignal (Qsingularity_error, args);     break;
 793     case OVERFLOW:      Fsignal (Qoverflow_error, args);        break;
 794     case UNDERFLOW:     Fsignal (Qunderflow_error, args);       break;
 795     default:            Fsignal (Qarith_error, args);           break;
 796     }
 797   return (1);   /* don't set errno or print a message */
 798 }
 799 #endif /* HAVE_MATHERR */
 800
 801 init_floatfns ()
 802 {
 803 #ifdef FLOAT_CATCH_SIGILL
 804   signal (SIGILL, float_error);
 805 #endif
 806   in_float = 0;
 807 }
 808
 809 syms_of_floatfns ()
 810 {
 811   defsubr (&Sacos);
 812   defsubr (&Sasin);
 813   defsubr (&Satan);
 814   defsubr (&Scos);
 815   defsubr (&Ssin);
 816   defsubr (&Stan);
 817 #if 0
 818   defsubr (&Sacosh);
 819   defsubr (&Sasinh);
 820   defsubr (&Satanh);
 821   defsubr (&Scosh);
 822   defsubr (&Ssinh);
 823   defsubr (&Stanh);
 824   defsubr (&Sbessel_y0);
 825   defsubr (&Sbessel_y1);
 826   defsubr (&Sbessel_yn);
 827   defsubr (&Sbessel_j0);
 828   defsubr (&Sbessel_j1);
 829   defsubr (&Sbessel_jn);
 830   defsubr (&Serf);
 831   defsubr (&Serfc);
 832   defsubr (&Slog_gamma);
 833   defsubr (&Scube_root);
 834   defsubr (&Sfceiling);
 835   defsubr (&Sffloor);
 836   defsubr (&Sfround);
 837   defsubr (&Sftruncate);
 838 #endif
 839   defsubr (&Sexp);
 840   defsubr (&Sexpt);
 841   defsubr (&Slog);
 842   defsubr (&Slog10);
 843   defsubr (&Ssqrt);
 844
 845   defsubr (&Sabs);
 846   defsubr (&Sfloat);
 847   defsubr (&Slogb);
 848   defsubr (&Sceiling);
 849   defsubr (&Sfloor);
 850   defsubr (&Sround);
 851   defsubr (&Struncate);
 852 }
 853
 854 #else /* not LISP_FLOAT_TYPE */
 855
 856 init_floatfns ()
 857 {}
 858
 859 syms_of_floatfns ()
 860 {}
 861
 862 #endif /* not LISP_FLOAT_TYPE */