src/floatfns.c

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