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 #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       return XSET (x, Lisp_Int, acc);
 296     }
 297   f1 = (XTYPE (num1) == Lisp_Float) ? XFLOAT (num1)->data : XINT (num1);
 298   f2 = (XTYPE (num2) == Lisp_Float) ? XFLOAT (num2)->data : XINT (num2);
 299   IN_FLOAT (f1 = pow (f1, f2), num1);
 300   return make_float (f1);
 301 }
 302
 303 DEFUN ("log", Flog, Slog, 1, 2, 0,
 304   "Return the natural logarithm of NUM.
 305 If second optional argument BASE is given, return log NUM using that base.")
 306   (num, base)
 307      register Lisp_Object num;
 308 {
 309   double d = extract_float (num);
 310
 311   if (NILP (base))
 312     IN_FLOAT (d = log (d), num);
 313   else
 314     {
 315       double b = extract_float (base);
 316
 317       IN_FLOAT (d = log (num) / log (b), num);
 318     }
 319   return make_float (d);
 320 }
 321
 322 DEFUN ("log10", Flog10, Slog10, 1, 1, 0,
 323   "Return the logarithm base 10 of ARG.")
 324   (num)
 325      register Lisp_Object num;
 326 {
 327   double d = extract_float (num);
 328   IN_FLOAT (d = log10 (d), num);
 329   return make_float (d);
 330 }
 331
 332 DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
 333   "Return the square root of ARG.")
 334   (num)
 335      register Lisp_Object num;
 336 {
 337   double d = extract_float (num);
 338   IN_FLOAT (d = sqrt (d), num);
 339   return make_float (d);
 340 }
 341 \f
 342 #if 0 /* Not clearly worth adding.  */
 343
 344 DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0,
 345   "Return the inverse hyperbolic cosine of ARG.")
 346   (num)
 347      register Lisp_Object num;
 348 {
 349   double d = extract_float (num);
 350   IN_FLOAT (d = acosh (d), num);
 351   return make_float (d);
 352 }
 353
 354 DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0,
 355   "Return the inverse hyperbolic sine of ARG.")
 356   (num)
 357      register Lisp_Object num;
 358 {
 359   double d = extract_float (num);
 360   IN_FLOAT (d = asinh (d), num);
 361   return make_float (d);
 362 }
 363
 364 DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0,
 365   "Return the inverse hyperbolic tangent of ARG.")
 366   (num)
 367      register Lisp_Object num;
 368 {
 369   double d = extract_float (num);
 370   IN_FLOAT (d = atanh (d), num);
 371   return make_float (d);
 372 }
 373
 374 DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0,
 375   "Return the hyperbolic cosine of ARG.")
 376   (num)
 377      register Lisp_Object num;
 378 {
 379   double d = extract_float (num);
 380   IN_FLOAT (d = cosh (d), num);
 381   return make_float (d);
 382 }
 383
 384 DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0,
 385   "Return the hyperbolic sine of ARG.")
 386   (num)
 387      register Lisp_Object num;
 388 {
 389   double d = extract_float (num);
 390   IN_FLOAT (d = sinh (d), num);
 391   return make_float (d);
 392 }
 393
 394 DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0,
 395   "Return the hyperbolic tangent of ARG.")
 396   (num)
 397      register Lisp_Object num;
 398 {
 399   double d = extract_float (num);
 400   IN_FLOAT (d = tanh (d), num);
 401   return make_float (d);
 402 }
 403 #endif
 404 \f
 405 DEFUN ("abs", Fabs, Sabs, 1, 1, 0,
 406   "Return the absolute value of ARG.")
 407   (num)
 408      register Lisp_Object num;
 409 {
 410   CHECK_NUMBER_OR_FLOAT (num, 0);
 411
 412   if (XTYPE (num) == Lisp_Float)
 413     IN_FLOAT (num = make_float (fabs (XFLOAT (num)->data)), num);
 414   else if (XINT (num) < 0)
 415     XSETINT (num, - XFASTINT (num));
 416
 417   return num;
 418 }
 419
 420 DEFUN ("float", Ffloat, Sfloat, 1, 1, 0,
 421   "Return the floating point number equal to ARG.")
 422   (num)
 423      register Lisp_Object num;
 424 {
 425   CHECK_NUMBER_OR_FLOAT (num, 0);
 426
 427   if (XTYPE (num) == Lisp_Int)
 428     return make_float ((double) XINT (num));
 429   else                          /* give 'em the same float back */
 430     return num;
 431 }
 432
 433 DEFUN ("logb", Flogb, Slogb, 1, 1, 0,
 434   "Returns the integer that is the base 2 log of ARG.\n\
 435 This is the same as the exponent of a float.")
 436      (num)
 437 Lisp_Object num;
 438 {
 439 #ifdef USG
 440   /* System V apparently doesn't have a `logb' function.  */
 441   return Flog (num, make_number (2));
 442 #else
 443   Lisp_Object val;
 444   double f = extract_float (num);
 445
 446   IN_FLOAT (val = logb (f), num);
 447   XSET (val, Lisp_Int, val);
 448   return val;
 449 #endif
 450 }
 451
 452 /* the rounding functions  */
 453
 454 DEFUN ("ceiling", Fceiling, Sceiling, 1, 1, 0,
 455   "Return the smallest integer no less than ARG.  (Round toward +inf.)")
 456   (num)
 457      register Lisp_Object num;
 458 {
 459   CHECK_NUMBER_OR_FLOAT (num, 0);
 460
 461   if (XTYPE (num) == Lisp_Float)
 462     IN_FLOAT (XSET (num, Lisp_Int, ceil (XFLOAT (num)->data)), num);
 463
 464   return num;
 465 }
 466
 467 DEFUN ("floor", Ffloor, Sfloor, 1, 1, 0,
 468   "Return the largest integer no greater than ARG.  (Round towards -inf.)")
 469   (num)
 470      register Lisp_Object num;
 471 {
 472   CHECK_NUMBER_OR_FLOAT (num, 0);
 473
 474   if (XTYPE (num) == Lisp_Float)
 475     IN_FLOAT (XSET (num, Lisp_Int, floor (XFLOAT (num)->data)), num);
 476
 477   return num;
 478 }
 479
 480 DEFUN ("round", Fround, Sround, 1, 1, 0,
 481   "Return the nearest integer to ARG.")
 482   (num)
 483      register Lisp_Object num;
 484 {
 485   CHECK_NUMBER_OR_FLOAT (num, 0);
 486
 487   if (XTYPE (num) == Lisp_Float)
 488     {
 489 #ifdef USG
 490       /* Screw the prevailing rounding mode.  */
 491       IN_FLOAT (XSET (num, Lisp_Int, floor (XFLOAT (num)->data + 0.5)), num);
 492 #else
 493       IN_FLOAT (XSET (num, Lisp_Int, rint (XFLOAT (num)->data)), num);
 494 #endif
 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 */