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