src/floatfns.c

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