code.delx.au - gnu-emacs/blob - 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       /* these, thereby saving some time. -wsr */
 410       x = XINT (arg1);
 411       y = XINT (arg2);
 412       acc = 1;
 413
 414       if (y < 0)
 415         {
 416           if (x == 1)
 417             acc = 1;
 418           else if (x == -1)
 419             acc = (y & 1) ? -1 : 1;
 420           else
 421             acc = 0;
 422         }
 423       else
 424         {
 425           for (; y > 0; y--)
 426           while (y > 0)
 427             {
 428               if (y & 1)
 429                 acc *= x;
 430               x *= x;
 431               y = (unsigned)y >> 1;
 432             }
 433         }
 434       XSET (x, Lisp_Int, acc);
 435       return x;
 436     }
 437   f1 = (XTYPE (arg1) == Lisp_Float) ? XFLOAT (arg1)->data : XINT (arg1);
 438   f2 = (XTYPE (arg2) == Lisp_Float) ? XFLOAT (arg2)->data : XINT (arg2);
 439   /* Really should check for overflow, too */
 440   if (f1 == 0.0 && f2 == 0.0)
 441     f1 = 1.0;
 442 #ifdef FLOAT_CHECK_DOMAIN
 443   else if ((f1 == 0.0 && f2 < 0.0) || (f1 < 0 && f2 != floor(f2)))
 444     domain_error2 ("expt", arg1, arg2);
 445 #endif
 446   IN_FLOAT (f1 = pow (f1, f2), "expt", arg1);
 447   return make_float (f1);
 448 }
 449
 450 DEFUN ("log", Flog, Slog, 1, 2, 0,
 451   "Return the natural logarithm of ARG.\n\
 452 If second optional argument BASE is given, return log ARG using that base.")
 453   (arg, base)
 454      register Lisp_Object arg, base;
 455 {
 456   double d = extract_float (arg);
 457
 458 #ifdef FLOAT_CHECK_DOMAIN
 459   if (d <= 0.0)
 460     domain_error2 ("log", arg, base);
 461 #endif
 462   if (NILP (base))
 463     IN_FLOAT (d = log (d), "log", arg);
 464   else
 465     {
 466       double b = extract_float (base);
 467
 468 #ifdef FLOAT_CHECK_DOMAIN
 469       if (b <= 0.0 || b == 1.0)
 470         domain_error2 ("log", arg, base);
 471 #endif
 472       if (b == 10.0)
 473         IN_FLOAT2 (d = log10 (d), "log", arg, base);
 474       else
 475         IN_FLOAT2 (d = log (d) / log (b), "log", arg, base);
 476     }
 477   return make_float (d);
 478 }
 479
 480 DEFUN ("log10", Flog10, Slog10, 1, 1, 0,
 481   "Return the logarithm base 10 of ARG.")
 482   (arg)
 483      register Lisp_Object arg;
 484 {
 485   double d = extract_float (arg);
 486 #ifdef FLOAT_CHECK_DOMAIN
 487   if (d <= 0.0)
 488     domain_error ("log10", arg);
 489 #endif
 490   IN_FLOAT (d = log10 (d), "log10", arg);
 491   return make_float (d);
 492 }
 493
 494 DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
 495   "Return the square root of ARG.")
 496   (arg)
 497      register Lisp_Object arg;
 498 {
 499   double d = extract_float (arg);
 500 #ifdef FLOAT_CHECK_DOMAIN
 501   if (d < 0.0)
 502     domain_error ("sqrt", arg);
 503 #endif
 504   IN_FLOAT (d = sqrt (d), "sqrt", arg);
 505   return make_float (d);
 506 }
 507 \f
 508 #if 0 /* Not clearly worth adding.  */
 509
 510 DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0,
 511   "Return the inverse hyperbolic cosine of ARG.")
 512   (arg)
 513      register Lisp_Object arg;
 514 {
 515   double d = extract_float (arg);
 516 #ifdef FLOAT_CHECK_DOMAIN
 517   if (d < 1.0)
 518     domain_error ("acosh", arg);
 519 #endif
 520 #ifdef HAVE_INVERSE_HYPERBOLIC
 521   IN_FLOAT (d = acosh (d), "acosh", arg);
 522 #else
 523   IN_FLOAT (d = log (d + sqrt (d*d - 1.0)), "acosh", arg);
 524 #endif
 525   return make_float (d);
 526 }
 527
 528 DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0,
 529   "Return the inverse hyperbolic sine of ARG.")
 530   (arg)
 531      register Lisp_Object arg;
 532 {
 533   double d = extract_float (arg);
 534 #ifdef HAVE_INVERSE_HYPERBOLIC
 535   IN_FLOAT (d = asinh (d), "asinh", arg);
 536 #else
 537   IN_FLOAT (d = log (d + sqrt (d*d + 1.0)), "asinh", arg);
 538 #endif
 539   return make_float (d);
 540 }
 541
 542 DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0,
 543   "Return the inverse hyperbolic tangent of ARG.")
 544   (arg)
 545      register Lisp_Object arg;
 546 {
 547   double d = extract_float (arg);
 548 #ifdef FLOAT_CHECK_DOMAIN
 549   if (d >= 1.0 || d <= -1.0)
 550     domain_error ("atanh", arg);
 551 #endif
 552 #ifdef HAVE_INVERSE_HYPERBOLIC
 553   IN_FLOAT (d = atanh (d), "atanh", arg);
 554 #else
 555   IN_FLOAT (d = 0.5 * log ((1.0 + d) / (1.0 - d)), "atanh", arg);
 556 #endif
 557   return make_float (d);
 558 }
 559
 560 DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0,
 561   "Return the hyperbolic cosine of ARG.")
 562   (arg)
 563      register Lisp_Object arg;
 564 {
 565   double d = extract_float (arg);
 566 #ifdef FLOAT_CHECK_DOMAIN
 567   if (d > 710.0 || d < -710.0)
 568     range_error ("cosh", arg);
 569 #endif
 570   IN_FLOAT (d = cosh (d), "cosh", arg);
 571   return make_float (d);
 572 }
 573
 574 DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0,
 575   "Return the hyperbolic sine of ARG.")
 576   (arg)
 577      register Lisp_Object arg;
 578 {
 579   double d = extract_float (arg);
 580 #ifdef FLOAT_CHECK_DOMAIN
 581   if (d > 710.0 || d < -710.0)
 582     range_error ("sinh", arg);
 583 #endif
 584   IN_FLOAT (d = sinh (d), "sinh", arg);
 585   return make_float (d);
 586 }
 587
 588 DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0,
 589   "Return the hyperbolic tangent of ARG.")
 590   (arg)
 591      register Lisp_Object arg;
 592 {
 593   double d = extract_float (arg);
 594   IN_FLOAT (d = tanh (d), "tanh", arg);
 595   return make_float (d);
 596 }
 597 #endif
 598 \f
 599 DEFUN ("abs", Fabs, Sabs, 1, 1, 0,
 600   "Return the absolute value of ARG.")
 601   (arg)
 602      register Lisp_Object arg;
 603 {
 604   CHECK_NUMBER_OR_FLOAT (arg, 0);
 605
 606   if (XTYPE (arg) == Lisp_Float)
 607     IN_FLOAT (arg = make_float (fabs (XFLOAT (arg)->data)), "abs", arg);
 608   else if (XINT (arg) < 0)
 609     XSETINT (arg, - XFASTINT (arg));
 610
 611   return arg;
 612 }
 613
 614 DEFUN ("float", Ffloat, Sfloat, 1, 1, 0,
 615   "Return the floating point number equal to ARG.")
 616   (arg)
 617      register Lisp_Object arg;
 618 {
 619   CHECK_NUMBER_OR_FLOAT (arg, 0);
 620
 621   if (XTYPE (arg) == Lisp_Int)
 622     return make_float ((double) XINT (arg));
 623   else                          /* give 'em the same float back */
 624     return arg;
 625 }
 626
 627 DEFUN ("logb", Flogb, Slogb, 1, 1, 0,
 628   "Returns the integer not greater than the base 2 log of the magnitude of ARG.\n\
 629 This is the same as the exponent of a float.")
 630      (arg)
 631      Lisp_Object arg;
 632 {
 633   Lisp_Object val;
 634   int value;
 635   double f = extract_float (arg);
 636
 637 #ifdef USG
 638   {
 639     int exp;
 640
 641     IN_FLOAT (frexp (f, &exp), "logb", arg);
 642     XSET (val, Lisp_Int, exp-1);
 643   }
 644 #else
 645   IN_FLOAT (value = logb (f), "logb", arg);
 646   XSET (val, Lisp_Int, value);
 647 #endif
 648
 649   return val;
 650 }
 651
 652 /* the rounding functions  */
 653
 654 DEFUN ("ceiling", Fceiling, Sceiling, 1, 1, 0,
 655   "Return the smallest integer no less than ARG.  (Round toward +inf.)")
 656   (arg)
 657      register Lisp_Object arg;
 658 {
 659   CHECK_NUMBER_OR_FLOAT (arg, 0);
 660
 661   if (XTYPE (arg) == Lisp_Float)
 662     IN_FLOAT (XSET (arg, Lisp_Int, ceil (XFLOAT (arg)->data)), "ceiling", arg);
 663
 664   return arg;
 665 }
 666
 667 DEFUN ("floor", Ffloor, Sfloor, 1, 1, 0,
 668   "Return the largest integer no greater than ARG.  (Round towards -inf.)")
 669   (arg)
 670      register Lisp_Object arg;
 671 {
 672   CHECK_NUMBER_OR_FLOAT (arg, 0);
 673
 674   if (XTYPE (arg) == Lisp_Float)
 675     IN_FLOAT (XSET (arg, Lisp_Int, floor (XFLOAT (arg)->data)), "floor", arg);
 676
 677   return arg;
 678 }
 679
 680 DEFUN ("round", Fround, Sround, 1, 1, 0,
 681   "Return the nearest integer to ARG.")
 682   (arg)
 683      register Lisp_Object arg;
 684 {
 685   CHECK_NUMBER_OR_FLOAT (arg, 0);
 686
 687   if (XTYPE (arg) == Lisp_Float)
 688     /* Screw the prevailing rounding mode.  */
 689     IN_FLOAT (XSET (arg, Lisp_Int, rint (XFLOAT (arg)->data)), "round", arg);
 690
 691   return arg;
 692 }
 693
 694 DEFUN ("truncate", Ftruncate, Struncate, 1, 1, 0,
 695        "Truncate a floating point number to an int.\n\
 696 Rounds the value toward zero.")
 697   (arg)
 698      register Lisp_Object arg;
 699 {
 700   CHECK_NUMBER_OR_FLOAT (arg, 0);
 701
 702   if (XTYPE (arg) == Lisp_Float)
 703     XSET (arg, Lisp_Int, (int) XFLOAT (arg)->data);
 704
 705   return arg;
 706 }
 707 \f
 708 #if 0
 709 /* It's not clear these are worth adding.  */
 710
 711 DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0,
 712   "Return the smallest integer no less than ARG, as a float.\n\
 713 \(Round toward +inf.\)")
 714   (arg)
 715      register Lisp_Object arg;
 716 {
 717   double d = extract_float (arg);
 718   IN_FLOAT (d = ceil (d), "fceiling", arg);
 719   return make_float (d);
 720 }
 721
 722 DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0,
 723   "Return the largest integer no greater than ARG, as a float.\n\
 724 \(Round towards -inf.\)")
 725   (arg)
 726      register Lisp_Object arg;
 727 {
 728   double d = extract_float (arg);
 729   IN_FLOAT (d = floor (d), "ffloor", arg);
 730   return make_float (d);
 731 }
 732
 733 DEFUN ("fround", Ffround, Sfround, 1, 1, 0,
 734   "Return the nearest integer to ARG, as a float.")
 735   (arg)
 736      register Lisp_Object arg;
 737 {
 738   double d = extract_float (arg);
 739   IN_FLOAT (d = rint (XFLOAT (arg)->data), "fround", arg);
 740   return make_float (d);
 741 }
 742
 743 DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0,
 744        "Truncate a floating point number to an integral float value.\n\
 745 Rounds the value toward zero.")
 746   (arg)
 747      register Lisp_Object arg;
 748 {
 749   double d = extract_float (arg);
 750   if (d >= 0.0)
 751     IN_FLOAT (d = floor (d), "ftruncate", arg);
 752   else
 753     IN_FLOAT (d = ceil (d), arg);
 754   return make_float (d);
 755 }
 756 #endif
 757 \f
 758 #ifdef FLOAT_CATCH_SIGILL
 759 static SIGTYPE
 760 float_error (signo)
 761      int signo;
 762 {
 763   if (! in_float)
 764     fatal_error_signal (signo);
 765
 766 #ifdef BSD
 767 #ifdef BSD4_1
 768   sigrelse (SIGILL);
 769 #else /* not BSD4_1 */
 770   sigsetmask (SIGEMPTYMASK);
 771 #endif /* not BSD4_1 */
 772 #else
 773   /* Must reestablish handler each time it is called.  */
 774   signal (SIGILL, float_error);
 775 #endif /* BSD */
 776
 777   in_float = 0;
 778
 779   Fsignal (Qarith_error, Fcons (float_error_arg, Qnil));
 780 }
 781
 782 /* Another idea was to replace the library function `infnan'
 783    where SIGILL is signaled.  */
 784
 785 #endif /* FLOAT_CATCH_SIGILL */
 786
 787 #ifdef HAVE_MATHERR
 788 int
 789 matherr (x)
 790      struct exception *x;
 791 {
 792   Lisp_Object args;
 793   if (! in_float)
 794     /* Not called from emacs-lisp float routines; do the default thing. */
 795     return 0;
 796   if (!strcmp (x->name, "pow"))
 797     x->name = "expt";
 798
 799   args
 800     = Fcons (build_string (x->name),
 801              Fcons (make_float (x->arg1),
 802                     ((!strcmp (x->name, "log") || !strcmp (x->name, "pow"))
 803                      ? Fcons (make_float (x->arg2), Qnil)
 804                      : Qnil)));
 805   switch (x->type)
 806     {
 807     case DOMAIN:        Fsignal (Qdomain_error, args);          break;
 808     case SING:          Fsignal (Qsingularity_error, args);     break;
 809     case OVERFLOW:      Fsignal (Qoverflow_error, args);        break;
 810     case UNDERFLOW:     Fsignal (Qunderflow_error, args);       break;
 811     default:            Fsignal (Qarith_error, args);           break;
 812     }
 813   return (1);   /* don't set errno or print a message */
 814 }
 815 #endif /* HAVE_MATHERR */
 816
 817 init_floatfns ()
 818 {
 819 #ifdef FLOAT_CATCH_SIGILL
 820   signal (SIGILL, float_error);
 821 #endif
 822   in_float = 0;
 823 }
 824
 825 syms_of_floatfns ()
 826 {
 827   defsubr (&Sacos);
 828   defsubr (&Sasin);
 829   defsubr (&Satan);
 830   defsubr (&Scos);
 831   defsubr (&Ssin);
 832   defsubr (&Stan);
 833 #if 0
 834   defsubr (&Sacosh);
 835   defsubr (&Sasinh);
 836   defsubr (&Satanh);
 837   defsubr (&Scosh);
 838   defsubr (&Ssinh);
 839   defsubr (&Stanh);
 840   defsubr (&Sbessel_y0);
 841   defsubr (&Sbessel_y1);
 842   defsubr (&Sbessel_yn);
 843   defsubr (&Sbessel_j0);
 844   defsubr (&Sbessel_j1);
 845   defsubr (&Sbessel_jn);
 846   defsubr (&Serf);
 847   defsubr (&Serfc);
 848   defsubr (&Slog_gamma);
 849   defsubr (&Scube_root);
 850   defsubr (&Sfceiling);
 851   defsubr (&Sffloor);
 852   defsubr (&Sfround);
 853   defsubr (&Sftruncate);
 854 #endif
 855   defsubr (&Sexp);
 856   defsubr (&Sexpt);
 857   defsubr (&Slog);
 858   defsubr (&Slog10);
 859   defsubr (&Ssqrt);
 860
 861   defsubr (&Sabs);
 862   defsubr (&Sfloat);
 863   defsubr (&Slogb);
 864   defsubr (&Sceiling);
 865   defsubr (&Sfloor);
 866   defsubr (&Sround);
 867   defsubr (&Struncate);
 868 }
 869
 870 #else /* not LISP_FLOAT_TYPE */
 871
 872 init_floatfns ()
 873 {}
 874
 875 syms_of_floatfns ()
 876 {}
 877
 878 #endif /* not LISP_FLOAT_TYPE */