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