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