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