src/floatfns.c

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