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