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