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