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