src/floatfns.c

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