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