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 #endif
 246 \f
 247 DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0,
 248   "Return the cube root of ARG.")
 249   (num)
 250      register Lisp_Object num;
 251 {
 252   double d = extract_float (num);
 253   IN_FLOAT (d = cbrt (d), num);
 254   return make_float (d);
 255 }
 256
 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 ("expm1", Fexpm1, Sexpm1, 1, 1, 0,
 268   "Return the exp (x)-1 of ARG.")
 269   (num)
 270      register Lisp_Object num;
 271 {
 272   double d = extract_float (num);
 273   IN_FLOAT (d = expm1 (d), num);
 274   return make_float (d);
 275 }
 276
 277 DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
 278   "Return the exponential X ** Y.")
 279   (num1, num2)
 280      register Lisp_Object num1, num2;
 281 {
 282   double f1, f2;
 283
 284   CHECK_NUMBER_OR_FLOAT (num1, 0);
 285   CHECK_NUMBER_OR_FLOAT (num2, 0);
 286   if ((XTYPE (num1) == Lisp_Int) && /* common lisp spec */
 287       (XTYPE (num2) == Lisp_Int)) /* don't promote, if both are ints */
 288     {                           /* this can be improved by pre-calculating */
 289       int acc, x, y;            /* some binary powers of x then acumulating */
 290       /* these, therby saving some time. -wsr */
 291       x = XINT (num1);
 292       y = XINT (num2);
 293       acc = 1;
 294
 295       if (y < 0)
 296         {
 297           for (; y < 0; y++)
 298             acc /= x;
 299         }
 300       else
 301         {
 302           for (; y > 0; y--)
 303             acc *= x;
 304         }
 305       return XSET (x, Lisp_Int, acc);
 306     }
 307   f1 = (XTYPE (num1) == Lisp_Float) ? XFLOAT (num1)->data : XINT (num1);
 308   f2 = (XTYPE (num2) == Lisp_Float) ? XFLOAT (num2)->data : XINT (num2);
 309   IN_FLOAT (f1 = pow (f1, f2), num1);
 310   return make_float (f1);
 311 }
 312
 313 DEFUN ("log", Flog, Slog, 1, 1, 0,
 314   "Return the natural logarithm of ARG.")
 315   (num)
 316      register Lisp_Object num;
 317 {
 318   double d = extract_float (num);
 319   IN_FLOAT (d = log (d), num);
 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 ("log1p", Flog1p, Slog1p, 1, 1, 0,
 334   "Return the log (1+x) of ARG.")
 335   (num)
 336      register Lisp_Object num;
 337 {
 338   double d = extract_float (num);
 339   IN_FLOAT (d = log1p (d), num);
 340   return make_float (d);
 341 }
 342
 343 DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
 344   "Return the square root of ARG.")
 345   (num)
 346      register Lisp_Object num;
 347 {
 348   double d = extract_float (num);
 349   IN_FLOAT (d = sqrt (d), num);
 350   return make_float (d);
 351 }
 352 \f
 353 #ifndef /* Not clearly worth adding.  */
 354
 355 DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0,
 356   "Return the inverse hyperbolic cosine of ARG.")
 357   (num)
 358      register Lisp_Object num;
 359 {
 360   double d = extract_float (num);
 361   IN_FLOAT (d = acosh (d), num);
 362   return make_float (d);
 363 }
 364
 365 DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0,
 366   "Return the inverse hyperbolic sine of ARG.")
 367   (num)
 368      register Lisp_Object num;
 369 {
 370   double d = extract_float (num);
 371   IN_FLOAT (d = asinh (d), num);
 372   return make_float (d);
 373 }
 374
 375 DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0,
 376   "Return the inverse hyperbolic tangent of ARG.")
 377   (num)
 378      register Lisp_Object num;
 379 {
 380   double d = extract_float (num);
 381   IN_FLOAT (d = atanh (d), num);
 382   return make_float (d);
 383 }
 384
 385 DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0,
 386   "Return the hyperbolic cosine of ARG.")
 387   (num)
 388      register Lisp_Object num;
 389 {
 390   double d = extract_float (num);
 391   IN_FLOAT (d = cosh (d), num);
 392   return make_float (d);
 393 }
 394
 395 DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0,
 396   "Return the hyperbolic sine of ARG.")
 397   (num)
 398      register Lisp_Object num;
 399 {
 400   double d = extract_float (num);
 401   IN_FLOAT (d = sinh (d), num);
 402   return make_float (d);
 403 }
 404
 405 DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0,
 406   "Return the hyperbolic tangent of ARG.")
 407   (num)
 408      register Lisp_Object num;
 409 {
 410   double d = extract_float (num);
 411   IN_FLOAT (d = tanh (d), num);
 412   return make_float (d);
 413 }
 414 #endif
 415 \f
 416 DEFUN ("abs", Fabs, Sabs, 1, 1, 0,
 417   "Return the absolute value of ARG.")
 418   (num)
 419      register Lisp_Object num;
 420 {
 421   CHECK_NUMBER_OR_FLOAT (num, 0);
 422
 423   if (XTYPE (num) == Lisp_Float)
 424     IN_FLOAT (num = make_float (fabs (XFLOAT (num)->data)), num);
 425   else if (XINT (num) < 0)
 426     XSETINT (num, - XFASTINT (num));
 427
 428   return num;
 429 }
 430
 431 DEFUN ("float", Ffloat, Sfloat, 1, 1, 0,
 432   "Return the floating point number equal to ARG.")
 433   (num)
 434      register Lisp_Object num;
 435 {
 436   CHECK_NUMBER_OR_FLOAT (num, 0);
 437
 438   if (XTYPE (num) == Lisp_Int)
 439     return make_float ((double) XINT (num));
 440   else                          /* give 'em the same float back */
 441     return num;
 442 }
 443
 444 DEFUN ("logb", Flogb, Slogb, 1, 1, 0,
 445   "Returns the integer that is the base 2 log of ARG.\n\
 446 This is the same as the exponent of a float.")
 447      (num)
 448 Lisp_Object num;
 449 {
 450   Lisp_Object val;
 451   double f;
 452
 453   CHECK_NUMBER_OR_FLOAT (num, 0);
 454   f = (XTYPE (num) == Lisp_Float) ? XFLOAT (num)->data : XINT (num);
 455   IN_FLOAT (val = logb (f), num);
 456   XSET (val, Lisp_Int, val);
 457   return val;
 458 }
 459
 460 /* the rounding functions  */
 461
 462 DEFUN ("ceiling", Fceiling, Sceiling, 1, 1, 0,
 463   "Return the smallest integer no less than ARG.  (Round toward +inf.)")
 464   (num)
 465      register Lisp_Object num;
 466 {
 467   CHECK_NUMBER_OR_FLOAT (num, 0);
 468
 469   if (XTYPE (num) == Lisp_Float)
 470     IN_FLOAT (XSET (num, Lisp_Int, ceil (XFLOAT (num)->data)), num);
 471
 472   return num;
 473 }
 474
 475 DEFUN ("floor", Ffloor, Sfloor, 1, 1, 0,
 476   "Return the largest integer no greater than ARG.  (Round towards -inf.)")
 477   (num)
 478      register Lisp_Object num;
 479 {
 480   CHECK_NUMBER_OR_FLOAT (num, 0);
 481
 482   if (XTYPE (num) == Lisp_Float)
 483     IN_FLOAT (XSET (num, Lisp_Int, floor (XFLOAT (num)->data)), num);
 484
 485   return num;
 486 }
 487
 488 DEFUN ("round", Fround, Sround, 1, 1, 0,
 489   "Return the nearest integer to ARG.")
 490   (num)
 491      register Lisp_Object num;
 492 {
 493   CHECK_NUMBER_OR_FLOAT (num, 0);
 494
 495   if (XTYPE (num) == Lisp_Float)
 496     IN_FLOAT (XSET (num, Lisp_Int, rint (XFLOAT (num)->data)), num);
 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 #endif
 569   defsubr (&Scube_root);
 570   defsubr (&Sexp);
 571   defsubr (&Sexpm1);
 572   defsubr (&Sexpt);
 573   defsubr (&Slog);
 574   defsubr (&Slog10);
 575   defsubr (&Slog1p);
 576   defsubr (&Ssqrt);
 577
 578   defsubr (&Sabs);
 579   defsubr (&Sfloat);
 580   defsubr (&Slogb);
 581   defsubr (&Sceiling);
 582   defsubr (&Sfloor);
 583   defsubr (&Sround);
 584   defsubr (&Struncate);
 585 }
 586
 587 #else /* not LISP_FLOAT_TYPE */
 588
 589 init_floatfns ()
 590 {}
 591
 592 syms_of_floatfns ()
 593 {}
 594
 595 #endif /* not LISP_FLOAT_TYPE */