code.delx.au - gnu-emacs/blob - src/floatfns.c

   1 /* Primitive operations on floating point for GNU Emacs Lisp interpreter.
   2    Copyright (C) 1988, 1992 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 #include <signal.h>
  22
  23 #include "config.h"
  24 #include "lisp.h"
  25 #include "syssignal.h"
  26
  27 Lisp_Object Qarith_error;
  28
  29 #ifdef LISP_FLOAT_TYPE
  30
  31 #include <math.h>
  32 #include <errno.h>
  33
  34 extern int errno;
  35
  36 /* Avoid traps on VMS from sinh and cosh.
  37    All the other functions set errno instead.  */
  38
  39 #ifdef VMS
  40 #undef cosh
  41 #undef sinh
  42 #define cosh(x) ((exp(x)+exp(-x))*0.5)
  43 #define sinh(x) ((exp(x)-exp(-x))*0.5)
  44 #endif /* VMS */
  45
  46 static SIGTYPE float_error ();
  47
  48 /* Nonzero while executing in floating point.
  49    This tells float_error what to do.  */
  50
  51 static int in_float;
  52
  53 /* If an argument is out of range for a mathematical function,
  54    here is the actual argument value to use in the error message.  */
  55
  56 static Lisp_Object float_error_arg;
  57
  58 /* Evaluate the floating point expression D, recording NUM
  59    as the original argument for error messages.
  60    D is normally an assignment expression.
  61    Handle errors which may result in signals or may set errno.
  62
  63    Note that float_error may be declared to return void, so you can't
  64    just cast the zero after the colon to (SIGTYPE) to make the types
  65    check properly.  */
  66
  67 #define IN_FLOAT(D, NUM) \
  68 (in_float = 1, errno = 0, float_error_arg = NUM, (D),                   \
  69  (errno == ERANGE || errno == EDOM ? (float_error (),0) : 0),           \
  70  in_float = 0)
  71
  72 /* Extract a Lisp number as a `double', or signal an error.  */
  73
  74 double
  75 extract_float (num)
  76      Lisp_Object num;
  77 {
  78   CHECK_NUMBER_OR_FLOAT (num, 0);
  79
  80   if (XTYPE (num) == Lisp_Float)
  81     return XFLOAT (num)->data;
  82   return (double) XINT (num);
  83 }
  84 \f
  85 /* Trig functions.  */
  86
  87 DEFUN ("acos", Facos, Sacos, 1, 1, 0,
  88   "Return the inverse cosine of ARG.")
  89   (num)
  90      register Lisp_Object num;
  91 {
  92   double d = extract_float (num);
  93   IN_FLOAT (d = acos (d), num);
  94   return make_float (d);
  95 }
  96
  97 DEFUN ("asin", Fasin, Sasin, 1, 1, 0,
  98   "Return the inverse sine of ARG.")
  99   (num)
 100      register Lisp_Object num;
 101 {
 102   double d = extract_float (num);
 103   IN_FLOAT (d = asin (d), num);
 104   return make_float (d);
 105 }
 106
 107 DEFUN ("atan", Fatan, Satan, 1, 1, 0,
 108   "Return the inverse tangent of ARG.")
 109   (num)
 110      register Lisp_Object num;
 111 {
 112   double d = extract_float (num);
 113   IN_FLOAT (d = atan (d), num);
 114   return make_float (d);
 115 }
 116
 117 DEFUN ("cos", Fcos, Scos, 1, 1, 0,
 118   "Return the cosine of ARG.")
 119   (num)
 120      register Lisp_Object num;
 121 {
 122   double d = extract_float (num);
 123   IN_FLOAT (d = cos (d), num);
 124   return make_float (d);
 125 }
 126
 127 DEFUN ("sin", Fsin, Ssin, 1, 1, 0,
 128   "Return the sine of ARG.")
 129   (num)
 130      register Lisp_Object num;
 131 {
 132   double d = extract_float (num);
 133   IN_FLOAT (d = sin (d), num);
 134   return make_float (d);
 135 }
 136
 137 DEFUN ("tan", Ftan, Stan, 1, 1, 0,
 138   "Return the tangent of ARG.")
 139   (num)
 140      register Lisp_Object num;
 141 {
 142   double d = extract_float (num);
 143   IN_FLOAT (d = tan (d), num);
 144   return make_float (d);
 145 }
 146 \f
 147 #if 0 /* Leave these out unless we find there's a reason for them.  */
 148
 149 DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0,
 150   "Return the bessel function j0 of ARG.")
 151   (num)
 152      register Lisp_Object num;
 153 {
 154   double d = extract_float (num);
 155   IN_FLOAT (d = j0 (d), num);
 156   return make_float (d);
 157 }
 158
 159 DEFUN ("bessel-j1", Fbessel_j1, Sbessel_j1, 1, 1, 0,
 160   "Return the bessel function j1 of ARG.")
 161   (num)
 162      register Lisp_Object num;
 163 {
 164   double d = extract_float (num);
 165   IN_FLOAT (d = j1 (d), num);
 166   return make_float (d);
 167 }
 168
 169 DEFUN ("bessel-jn", Fbessel_jn, Sbessel_jn, 2, 2, 0,
 170   "Return the order N bessel function output jn of ARG.\n\
 171 The first arg (the order) is truncated to an integer.")
 172   (num1, num2)
 173      register Lisp_Object num1, num2;
 174 {
 175   int i1 = extract_float (num1);
 176   double f2 = extract_float (num2);
 177
 178   IN_FLOAT (f2 = jn (i1, f2), num1);
 179   return make_float (f2);
 180 }
 181
 182 DEFUN ("bessel-y0", Fbessel_y0, Sbessel_y0, 1, 1, 0,
 183   "Return the bessel function y0 of ARG.")
 184   (num)
 185      register Lisp_Object num;
 186 {
 187   double d = extract_float (num);
 188   IN_FLOAT (d = y0 (d), num);
 189   return make_float (d);
 190 }
 191
 192 DEFUN ("bessel-y1", Fbessel_y1, Sbessel_y1, 1, 1, 0,
 193   "Return the bessel function y1 of ARG.")
 194   (num)
 195      register Lisp_Object num;
 196 {
 197   double d = extract_float (num);
 198   IN_FLOAT (d = y1 (d), num);
 199   return make_float (d);
 200 }
 201
 202 DEFUN ("bessel-yn", Fbessel_yn, Sbessel_yn, 2, 2, 0,
 203   "Return the order N bessel function output yn of ARG.\n\
 204 The first arg (the order) is truncated to an integer.")
 205   (num1, num2)
 206      register Lisp_Object num1, num2;
 207 {
 208   int i1 = extract_float (num1);
 209   double f2 = extract_float (num2);
 210
 211   IN_FLOAT (f2 = yn (i1, f2), num1);
 212   return make_float (f2);
 213 }
 214
 215 #endif
 216 \f
 217 #if 0 /* Leave these out unless we see they are worth having.  */
 218
 219 DEFUN ("erf", Ferf, Serf, 1, 1, 0,
 220   "Return the mathematical error function of ARG.")
 221   (num)
 222      register Lisp_Object num;
 223 {
 224   double d = extract_float (num);
 225   IN_FLOAT (d = erf (d), num);
 226   return make_float (d);
 227 }
 228
 229 DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0,
 230   "Return the complementary error function of ARG.")
 231   (num)
 232      register Lisp_Object num;
 233 {
 234   double d = extract_float (num);
 235   IN_FLOAT (d = erfc (d), num);
 236   return make_float (d);
 237 }
 238
 239 DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0,
 240   "Return the log gamma of ARG.")
 241   (num)
 242      register Lisp_Object num;
 243 {
 244   double d = extract_float (num);
 245   IN_FLOAT (d = lgamma (d), num);
 246   return make_float (d);
 247 }
 248
 249 DEFUN ("cbrt", Fcbrt, Scbrt, 1, 1, 0,
 250   "Return the cube root of ARG.")
 251   (num)
 252      register Lisp_Object num;
 253 {
 254   double d = extract_float (num);
 255   IN_FLOAT (d = cbrt (d), num);
 256   return make_float (d);
 257 }
 258
 259 #endif
 260 \f
 261 DEFUN ("exp", Fexp, Sexp, 1, 1, 0,
 262   "Return the exponential base e of ARG.")
 263   (num)
 264      register Lisp_Object num;
 265 {
 266   double d = extract_float (num);
 267   IN_FLOAT (d = exp (d), num);
 268   return make_float (d);
 269 }
 270
 271 DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
 272   "Return the exponential X ** Y.")
 273   (num1, num2)
 274      register Lisp_Object num1, num2;
 275 {
 276   double f1, f2;
 277
 278   CHECK_NUMBER_OR_FLOAT (num1, 0);
 279   CHECK_NUMBER_OR_FLOAT (num2, 0);
 280   if ((XTYPE (num1) == Lisp_Int) && /* common lisp spec */
 281       (XTYPE (num2) == Lisp_Int)) /* don't promote, if both are ints */
 282     {                           /* this can be improved by pre-calculating */
 283       int acc, x, y;            /* some binary powers of x then acumulating */
 284       /* these, therby saving some time. -wsr */
 285       x = XINT (num1);
 286       y = XINT (num2);
 287       acc = 1;
 288
 289       if (y < 0)
 290         {
 291           for (; y < 0; y++)
 292             acc /= x;
 293         }
 294       else
 295         {
 296           for (; y > 0; y--)
 297             acc *= x;
 298         }
 299       XFASTINT (x) = acc;
 300       return x;
 301     }
 302   f1 = (XTYPE (num1) == Lisp_Float) ? XFLOAT (num1)->data : XINT (num1);
 303   f2 = (XTYPE (num2) == Lisp_Float) ? XFLOAT (num2)->data : XINT (num2);
 304   IN_FLOAT (f1 = pow (f1, f2), num1);
 305   return make_float (f1);
 306 }
 307
 308 DEFUN ("log", Flog, Slog, 1, 2, 0,
 309   "Return the natural logarithm of NUM.\n\
 310 If second optional argument BASE is given, return log NUM using that base.")
 311   (num, base)
 312      register Lisp_Object num, base;
 313 {
 314   double d = extract_float (num);
 315
 316   if (NILP (base))
 317     IN_FLOAT (d = log (d), num);
 318   else
 319     {
 320       double b = extract_float (base);
 321
 322       IN_FLOAT (d = log (num) / log (b), num);
 323     }
 324   return make_float (d);
 325 }
 326
 327 DEFUN ("log10", Flog10, Slog10, 1, 1, 0,
 328   "Return the logarithm base 10 of ARG.")
 329   (num)
 330      register Lisp_Object num;
 331 {
 332   double d = extract_float (num);
 333   IN_FLOAT (d = log10 (d), num);
 334   return make_float (d);
 335 }
 336
 337 DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
 338   "Return the square root of ARG.")
 339   (num)
 340      register Lisp_Object num;
 341 {
 342   double d = extract_float (num);
 343   IN_FLOAT (d = sqrt (d), num);
 344   return make_float (d);
 345 }
 346 \f
 347 #if 0 /* Not clearly worth adding.  */
 348
 349 DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0,
 350   "Return the inverse hyperbolic cosine of ARG.")
 351   (num)
 352      register Lisp_Object num;
 353 {
 354   double d = extract_float (num);
 355   IN_FLOAT (d = acosh (d), num);
 356   return make_float (d);
 357 }
 358
 359 DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0,
 360   "Return the inverse hyperbolic sine of ARG.")
 361   (num)
 362      register Lisp_Object num;
 363 {
 364   double d = extract_float (num);
 365   IN_FLOAT (d = asinh (d), num);
 366   return make_float (d);
 367 }
 368
 369 DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0,
 370   "Return the inverse hyperbolic tangent of ARG.")
 371   (num)
 372      register Lisp_Object num;
 373 {
 374   double d = extract_float (num);
 375   IN_FLOAT (d = atanh (d), num);
 376   return make_float (d);
 377 }
 378
 379 DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0,
 380   "Return the hyperbolic cosine of ARG.")
 381   (num)
 382      register Lisp_Object num;
 383 {
 384   double d = extract_float (num);
 385   IN_FLOAT (d = cosh (d), num);
 386   return make_float (d);
 387 }
 388
 389 DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0,
 390   "Return the hyperbolic sine of ARG.")
 391   (num)
 392      register Lisp_Object num;
 393 {
 394   double d = extract_float (num);
 395   IN_FLOAT (d = sinh (d), num);
 396   return make_float (d);
 397 }
 398
 399 DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0,
 400   "Return the hyperbolic tangent of ARG.")
 401   (num)
 402      register Lisp_Object num;
 403 {
 404   double d = extract_float (num);
 405   IN_FLOAT (d = tanh (d), num);
 406   return make_float (d);
 407 }
 408 #endif
 409 \f
 410 DEFUN ("abs", Fabs, Sabs, 1, 1, 0,
 411   "Return the absolute value of ARG.")
 412   (num)
 413      register Lisp_Object num;
 414 {
 415   CHECK_NUMBER_OR_FLOAT (num, 0);
 416
 417   if (XTYPE (num) == Lisp_Float)
 418     IN_FLOAT (num = make_float (fabs (XFLOAT (num)->data)), num);
 419   else if (XINT (num) < 0)
 420     XSETINT (num, - XFASTINT (num));
 421
 422   return num;
 423 }
 424
 425 DEFUN ("float", Ffloat, Sfloat, 1, 1, 0,
 426   "Return the floating point number equal to ARG.")
 427   (num)
 428      register Lisp_Object num;
 429 {
 430   CHECK_NUMBER_OR_FLOAT (num, 0);
 431
 432   if (XTYPE (num) == Lisp_Int)
 433     return make_float ((double) XINT (num));
 434   else                          /* give 'em the same float back */
 435     return num;
 436 }
 437
 438 DEFUN ("logb", Flogb, Slogb, 1, 1, 0,
 439   "Returns the integer that is the base 2 log of ARG.\n\
 440 This is the same as the exponent of a float.")
 441      (num)
 442 Lisp_Object num;
 443 {
 444   /* System V apparently doesn't have a `logb' function.  It might be
 445      better to use it on systems that have it, but Ultrix (at least)
 446      doesn't declare it properly in <math.h>; does anyone really care? */
 447   return Flog (num, make_number (2));
 448 }
 449
 450 /* the rounding functions  */
 451
 452 DEFUN ("ceiling", Fceiling, Sceiling, 1, 1, 0,
 453   "Return the smallest integer no less than ARG.  (Round toward +inf.)")
 454   (num)
 455      register Lisp_Object num;
 456 {
 457   CHECK_NUMBER_OR_FLOAT (num, 0);
 458
 459   if (XTYPE (num) == Lisp_Float)
 460     IN_FLOAT (XSET (num, Lisp_Int, ceil (XFLOAT (num)->data)), num);
 461
 462   return num;
 463 }
 464
 465 DEFUN ("floor", Ffloor, Sfloor, 1, 1, 0,
 466   "Return the largest integer no greater than ARG.  (Round towards -inf.)")
 467   (num)
 468      register Lisp_Object num;
 469 {
 470   CHECK_NUMBER_OR_FLOAT (num, 0);
 471
 472   if (XTYPE (num) == Lisp_Float)
 473     IN_FLOAT (XSET (num, Lisp_Int, floor (XFLOAT (num)->data)), num);
 474
 475   return num;
 476 }
 477
 478 DEFUN ("round", Fround, Sround, 1, 1, 0,
 479   "Return the nearest integer to ARG.")
 480   (num)
 481      register Lisp_Object num;
 482 {
 483   CHECK_NUMBER_OR_FLOAT (num, 0);
 484
 485   if (XTYPE (num) == Lisp_Float)
 486     {
 487       /* Screw the prevailing rounding mode.  */
 488       IN_FLOAT (XSET (num, Lisp_Int, floor (XFLOAT (num)->data + 0.5)), num);
 489
 490       /* It used to be that on non-USG systems we'd use the `rint'
 491          function.  But that seems not to be declared properly in
 492          <math.h> on Ultrix, I don't want to declare it myself because
 493          that might conflict with <math.h> on other systems, and I
 494          don't see what's wrong with the code above anyway.  */
 495     }
 496
 497   return num;
 498 }
 499
 500 DEFUN ("truncate", Ftruncate, Struncate, 1, 1, 0,
 501        "Truncate a floating point number to an int.\n\
 502 Rounds the value toward zero.")
 503   (num)
 504      register Lisp_Object num;
 505 {
 506   CHECK_NUMBER_OR_FLOAT (num, 0);
 507
 508   if (XTYPE (num) == Lisp_Float)
 509     XSET (num, Lisp_Int, (int) XFLOAT (num)->data);
 510
 511   return num;
 512 }
 513 \f
 514 static SIGTYPE
 515 float_error (signo)
 516      int signo;
 517 {
 518   if (! in_float)
 519     fatal_error_signal (signo);
 520
 521 #ifdef BSD
 522 #ifdef BSD4_1
 523   sigrelse (SIGILL);
 524 #else /* not BSD4_1 */
 525   sigsetmask (SIGEMPTYMASK);
 526 #endif /* not BSD4_1 */
 527 #else
 528   /* Must reestablish handler each time it is called.  */
 529   signal (SIGILL, float_error);
 530 #endif /* BSD */
 531
 532   in_float = 0;
 533
 534   Fsignal (Qarith_error, Fcons (float_error_arg, Qnil));
 535 }
 536
 537 init_floatfns ()
 538 {
 539   signal (SIGILL, float_error);
 540   in_float = 0;
 541 }
 542
 543 syms_of_floatfns ()
 544 {
 545   defsubr (&Sacos);
 546   defsubr (&Sasin);
 547   defsubr (&Satan);
 548   defsubr (&Scos);
 549   defsubr (&Ssin);
 550   defsubr (&Stan);
 551 #if 0
 552   defsubr (&Sacosh);
 553   defsubr (&Sasinh);
 554   defsubr (&Satanh);
 555   defsubr (&Scosh);
 556   defsubr (&Ssinh);
 557   defsubr (&Stanh);
 558   defsubr (&Sbessel_y0);
 559   defsubr (&Sbessel_y1);
 560   defsubr (&Sbessel_yn);
 561   defsubr (&Sbessel_j0);
 562   defsubr (&Sbessel_j1);
 563   defsubr (&Sbessel_jn);
 564   defsubr (&Serf);
 565   defsubr (&Serfc);
 566   defsubr (&Slog_gamma);
 567   defsubr (&Scbrt);
 568 #endif
 569   defsubr (&Sexp);
 570   defsubr (&Sexpt);
 571   defsubr (&Slog);
 572   defsubr (&Slog10);
 573   defsubr (&Ssqrt);
 574
 575   defsubr (&Sabs);
 576   defsubr (&Sfloat);
 577   defsubr (&Slogb);
 578   defsubr (&Sceiling);
 579   defsubr (&Sfloor);
 580   defsubr (&Sround);
 581   defsubr (&Struncate);
 582 }
 583
 584 #else /* not LISP_FLOAT_TYPE */
 585
 586 init_floatfns ()
 587 {}
 588
 589 syms_of_floatfns ()
 590 {}
 591
 592 #endif /* not LISP_FLOAT_TYPE */