floatfns.c 23.9 KB
Newer Older
Mike Rowan's avatar
Mike Rowan committed
1
/* Primitive operations on floating point for GNU Emacs Lisp interpreter.
Karl Heuer's avatar
Karl Heuer committed
2
   Copyright (C) 1988, 1993, 1994 Free Software Foundation, Inc.
Mike Rowan's avatar
Mike Rowan committed
3 4 5 6 7

This file is part of GNU Emacs.

GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
Jim Blandy's avatar
Jim Blandy committed
8
the Free Software Foundation; either version 2, or (at your option)
Mike Rowan's avatar
Mike Rowan committed
9 10 11 12 13 14 15 16 17 18 19 20
any later version.

GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU Emacs; see the file COPYING.  If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */


21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45
/* ANSI C requires only these float functions:
   acos, asin, atan, atan2, ceil, cos, cosh, exp, fabs, floor, fmod,
   frexp, ldexp, log, log10, modf, pow, sin, sinh, sqrt, tan, tanh.

   Define HAVE_INVERSE_HYPERBOLIC if you have acosh, asinh, and atanh.
   Define HAVE_CBRT if you have cbrt.
   Define HAVE_RINT if you have rint.
   If you don't define these, then the appropriate routines will be simulated.

   Define HAVE_MATHERR if on a system supporting the SysV matherr callback.
   (This should happen automatically.)

   Define FLOAT_CHECK_ERRNO if the float library routines set errno.
   This has no effect if HAVE_MATHERR is defined.

   Define FLOAT_CATCH_SIGILL if the float library routines signal SIGILL.
   (What systems actually do this?  Please let us know.)

   Define FLOAT_CHECK_DOMAIN if the float library doesn't handle errors by
   either setting errno, or signalling SIGFPE/SIGILL.  Otherwise, domain and
   range checking will happen before calling the float routines.  This has
   no effect if HAVE_MATHERR is defined (since matherr will be called when
   a domain error occurs.)
 */

Mike Rowan's avatar
Mike Rowan committed
46 47
#include <signal.h>

48
#include <config.h>
Mike Rowan's avatar
Mike Rowan committed
49
#include "lisp.h"
Jim Blandy's avatar
Jim Blandy committed
50
#include "syssignal.h"
Mike Rowan's avatar
Mike Rowan committed
51 52 53 54

Lisp_Object Qarith_error;

#ifdef LISP_FLOAT_TYPE
Jim Blandy's avatar
Jim Blandy committed
55

56
#ifdef MSDOS
Karl Heuer's avatar
Karl Heuer committed
57
/* These are redefined (correctly, but differently) in values.h.  */
58 59 60 61 62
#undef INTBITS
#undef LONGBITS
#undef SHORTBITS
#endif

63 64 65 66 67 68 69 70 71 72
/* Work around a problem that happens because math.h on hpux 7
   defines two static variables--which, in Emacs, are not really static,
   because `static' is defined as nothing.  The problem is that they are
   defined both here and in lread.c.
   These macros prevent the name conflict.  */
#if defined (HPUX) && !defined (HPUX8)
#define _MAXLDBL floatfns_maxldbl
#define _NMAXLDBL floatfns_nmaxldbl
#endif

Mike Rowan's avatar
Mike Rowan committed
73
#include <math.h>
74

75
/* This declaration is omitted on some systems, like Ultrix.  */
76
#if !defined (HPUX) && defined (HAVE_LOGB) && !defined (logb)
77
extern double logb ();
78
#endif /* not HPUX and HAVE_LOGB and no logb macro */
79

80 81 82 83 84 85 86
#if defined(DOMAIN) && defined(SING) && defined(OVERFLOW)
    /* If those are defined, then this is probably a `matherr' machine. */
# ifndef HAVE_MATHERR
#  define HAVE_MATHERR
# endif
#endif

Richard M. Stallman's avatar
Richard M. Stallman committed
87
#ifdef NO_MATHERR
88 89 90
#undef HAVE_MATHERR
#endif

91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
#ifdef HAVE_MATHERR
# ifdef FLOAT_CHECK_ERRNO
#  undef FLOAT_CHECK_ERRNO
# endif
# ifdef FLOAT_CHECK_DOMAIN
#  undef FLOAT_CHECK_DOMAIN
# endif
#endif

#ifndef NO_FLOAT_CHECK_ERRNO
#define FLOAT_CHECK_ERRNO
#endif

#ifdef FLOAT_CHECK_ERRNO
# include <errno.h>
Jim Blandy's avatar
Jim Blandy committed
106 107

extern int errno;
108
#endif
Jim Blandy's avatar
Jim Blandy committed
109 110 111 112 113 114 115 116 117 118 119

/* Avoid traps on VMS from sinh and cosh.
   All the other functions set errno instead.  */

#ifdef VMS
#undef cosh
#undef sinh
#define cosh(x) ((exp(x)+exp(-x))*0.5)
#define sinh(x) ((exp(x)-exp(-x))*0.5)
#endif /* VMS */

120 121 122 123
#ifndef HAVE_RINT
#define rint(x) (floor((x)+0.5))
#endif

Jim Blandy's avatar
Jim Blandy committed
124
static SIGTYPE float_error ();
Mike Rowan's avatar
Mike Rowan committed
125 126 127 128 129 130 131

/* Nonzero while executing in floating point.
   This tells float_error what to do.  */

static int in_float;

/* If an argument is out of range for a mathematical function,
Jim Blandy's avatar
Jim Blandy committed
132
   here is the actual argument value to use in the error message.  */
Mike Rowan's avatar
Mike Rowan committed
133

134 135 136
static Lisp_Object float_error_arg, float_error_arg2;

static char *float_error_fn_name;
Mike Rowan's avatar
Mike Rowan committed
137

Jim Blandy's avatar
Jim Blandy committed
138 139 140
/* Evaluate the floating point expression D, recording NUM
   as the original argument for error messages.
   D is normally an assignment expression.
141 142 143 144 145
   Handle errors which may result in signals or may set errno.

   Note that float_error may be declared to return void, so you can't
   just cast the zero after the colon to (SIGTYPE) to make the types
   check properly.  */
Jim Blandy's avatar
Jim Blandy committed
146

147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173
#ifdef FLOAT_CHECK_ERRNO
#define IN_FLOAT(d, name, num)				\
  do {							\
    float_error_arg = num;				\
    float_error_fn_name = name;				\
    in_float = 1; errno = 0; (d); in_float = 0;		\
    switch (errno) {					\
    case 0: break;					\
    case EDOM:	 domain_error (float_error_fn_name, float_error_arg);	\
    case ERANGE: range_error (float_error_fn_name, float_error_arg);	\
    default:	 arith_error (float_error_fn_name, float_error_arg);	\
    }							\
  } while (0)
#define IN_FLOAT2(d, name, num, num2)			\
  do {							\
    float_error_arg = num;				\
    float_error_arg2 = num2;				\
    float_error_fn_name = name;				\
    in_float = 1; errno = 0; (d); in_float = 0;		\
    switch (errno) {					\
    case 0: break;					\
    case EDOM:	 domain_error (float_error_fn_name, float_error_arg);	\
    case ERANGE: range_error (float_error_fn_name, float_error_arg);	\
    default:	 arith_error (float_error_fn_name, float_error_arg);	\
    }							\
  } while (0)
#else
174
#define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0)
175 176 177
#define IN_FLOAT2(d, name, num, num2) (in_float = 1, (d), in_float = 0)
#endif

178 179 180 181 182
/* Convert float to Lisp_Int if it fits, else signal a range error
   using the given arguments.  */
#define FLOAT_TO_INT(x, i, name, num)					\
  do									\
    {									\
183 184
      if ((x) >= (((EMACS_INT) 1) << (VALBITS-1)) ||			\
	  (x) <= - (((EMACS_INT) 1) << (VALBITS-1)) - 1)		\
185
	range_error (name, num);					\
186
      XSETINT (i,  (EMACS_INT)(x));					\
187 188 189 190 191
    }									\
  while (0)
#define FLOAT_TO_INT2(x, i, name, num1, num2)				\
  do									\
    {									\
192 193
      if ((x) >= (((EMACS_INT) 1) << (VALBITS-1)) ||			\
	  (x) <= - (((EMACS_INT) 1) << (VALBITS-1)) - 1)		\
194
	range_error2 (name, num1, num2);				\
195
      XSETINT (i,  (EMACS_INT)(x));					\
196 197 198
    }									\
  while (0)

199 200 201 202
#define arith_error(op,arg) \
  Fsignal (Qarith_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
#define range_error(op,arg) \
  Fsignal (Qrange_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
203 204 205
#define range_error2(op,a1,a2) \
  Fsignal (Qrange_error, Fcons (build_string ((op)), \
				Fcons ((a1), Fcons ((a2), Qnil))))
206 207 208
#define domain_error(op,arg) \
  Fsignal (Qdomain_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
#define domain_error2(op,a1,a2) \
209 210
  Fsignal (Qdomain_error, Fcons (build_string ((op)), \
				 Fcons ((a1), Fcons ((a2), Qnil))))
Mike Rowan's avatar
Mike Rowan committed
211 212 213 214 215 216 217 218 219

/* Extract a Lisp number as a `double', or signal an error.  */

double
extract_float (num)
     Lisp_Object num;
{
  CHECK_NUMBER_OR_FLOAT (num, 0);

220
  if (FLOATP (num))
Mike Rowan's avatar
Mike Rowan committed
221 222 223
    return XFLOAT (num)->data;
  return (double) XINT (num);
}
224 225

/* Trig functions.  */
Mike Rowan's avatar
Mike Rowan committed
226 227 228

DEFUN ("acos", Facos, Sacos, 1, 1, 0,
  "Return the inverse cosine of ARG.")
229 230
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
231
{
232 233 234 235 236 237
  double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
  if (d > 1.0 || d < -1.0)
    domain_error ("acos", arg);
#endif
  IN_FLOAT (d = acos (d), "acos", arg);
Mike Rowan's avatar
Mike Rowan committed
238 239 240
  return make_float (d);
}

241 242
DEFUN ("asin", Fasin, Sasin, 1, 1, 0,
  "Return the inverse sine of ARG.")
243 244
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
245
{
246 247 248 249 250 251
  double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
  if (d > 1.0 || d < -1.0)
    domain_error ("asin", arg);
#endif
  IN_FLOAT (d = asin (d), "asin", arg);
Mike Rowan's avatar
Mike Rowan committed
252 253 254
  return make_float (d);
}

255 256
DEFUN ("atan", Fatan, Satan, 1, 1, 0,
  "Return the inverse tangent of ARG.")
257 258
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
259
{
260 261
  double d = extract_float (arg);
  IN_FLOAT (d = atan (d), "atan", arg);
Mike Rowan's avatar
Mike Rowan committed
262 263 264
  return make_float (d);
}

265 266
DEFUN ("cos", Fcos, Scos, 1, 1, 0,
  "Return the cosine of ARG.")
267 268
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
269
{
270 271
  double d = extract_float (arg);
  IN_FLOAT (d = cos (d), "cos", arg);
Mike Rowan's avatar
Mike Rowan committed
272 273 274
  return make_float (d);
}

275 276
DEFUN ("sin", Fsin, Ssin, 1, 1, 0,
  "Return the sine of ARG.")
277 278
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
279
{
280 281
  double d = extract_float (arg);
  IN_FLOAT (d = sin (d), "sin", arg);
Mike Rowan's avatar
Mike Rowan committed
282 283 284
  return make_float (d);
}

285 286
DEFUN ("tan", Ftan, Stan, 1, 1, 0,
  "Return the tangent of ARG.")
287 288 289 290 291 292 293 294 295 296
  (arg)
     register Lisp_Object arg;
{
  double d = extract_float (arg);
  double c = cos (d);
#ifdef FLOAT_CHECK_DOMAIN
  if (c == 0.0)
    domain_error ("tan", arg);
#endif
  IN_FLOAT (d = sin (d) / c, "tan", arg);
Mike Rowan's avatar
Mike Rowan committed
297 298 299
  return make_float (d);
}

300 301
#if 0 /* Leave these out unless we find there's a reason for them.  */

Mike Rowan's avatar
Mike Rowan committed
302 303
DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0,
  "Return the bessel function j0 of ARG.")
304 305
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
306
{
307 308
  double d = extract_float (arg);
  IN_FLOAT (d = j0 (d), "bessel-j0", arg);
Mike Rowan's avatar
Mike Rowan committed
309 310 311 312 313
  return make_float (d);
}

DEFUN ("bessel-j1", Fbessel_j1, Sbessel_j1, 1, 1, 0,
  "Return the bessel function j1 of ARG.")
314 315
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
316
{
317 318
  double d = extract_float (arg);
  IN_FLOAT (d = j1 (d), "bessel-j1", arg);
Mike Rowan's avatar
Mike Rowan committed
319 320 321 322 323 324
  return make_float (d);
}

DEFUN ("bessel-jn", Fbessel_jn, Sbessel_jn, 2, 2, 0,
  "Return the order N bessel function output jn of ARG.\n\
The first arg (the order) is truncated to an integer.")
325 326
  (arg1, arg2)
     register Lisp_Object arg1, arg2;
Mike Rowan's avatar
Mike Rowan committed
327
{
328 329
  int i1 = extract_float (arg1);
  double f2 = extract_float (arg2);
Mike Rowan's avatar
Mike Rowan committed
330

331
  IN_FLOAT (f2 = jn (i1, f2), "bessel-jn", arg1);
Mike Rowan's avatar
Mike Rowan committed
332 333 334 335 336
  return make_float (f2);
}

DEFUN ("bessel-y0", Fbessel_y0, Sbessel_y0, 1, 1, 0,
  "Return the bessel function y0 of ARG.")
337 338
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
339
{
340 341
  double d = extract_float (arg);
  IN_FLOAT (d = y0 (d), "bessel-y0", arg);
Mike Rowan's avatar
Mike Rowan committed
342 343 344 345 346
  return make_float (d);
}

DEFUN ("bessel-y1", Fbessel_y1, Sbessel_y1, 1, 1, 0,
  "Return the bessel function y1 of ARG.")
347 348
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
349
{
350 351
  double d = extract_float (arg);
  IN_FLOAT (d = y1 (d), "bessel-y0", arg);
Mike Rowan's avatar
Mike Rowan committed
352 353 354 355 356 357
  return make_float (d);
}

DEFUN ("bessel-yn", Fbessel_yn, Sbessel_yn, 2, 2, 0,
  "Return the order N bessel function output yn of ARG.\n\
The first arg (the order) is truncated to an integer.")
358 359
  (arg1, arg2)
     register Lisp_Object arg1, arg2;
Mike Rowan's avatar
Mike Rowan committed
360
{
361 362
  int i1 = extract_float (arg1);
  double f2 = extract_float (arg2);
Mike Rowan's avatar
Mike Rowan committed
363

364
  IN_FLOAT (f2 = yn (i1, f2), "bessel-yn", arg1);
Mike Rowan's avatar
Mike Rowan committed
365 366 367
  return make_float (f2);
}

368 369 370
#endif

#if 0 /* Leave these out unless we see they are worth having.  */
Mike Rowan's avatar
Mike Rowan committed
371 372 373

DEFUN ("erf", Ferf, Serf, 1, 1, 0,
  "Return the mathematical error function of ARG.")
374 375
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
376
{
377 378
  double d = extract_float (arg);
  IN_FLOAT (d = erf (d), "erf", arg);
Mike Rowan's avatar
Mike Rowan committed
379 380 381 382 383
  return make_float (d);
}

DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0,
  "Return the complementary error function of ARG.")
384 385
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
386
{
387 388
  double d = extract_float (arg);
  IN_FLOAT (d = erfc (d), "erfc", arg);
Mike Rowan's avatar
Mike Rowan committed
389 390 391 392 393
  return make_float (d);
}

DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0,
  "Return the log gamma of ARG.")
394 395
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
396
{
397 398
  double d = extract_float (arg);
  IN_FLOAT (d = lgamma (d), "log-gamma", arg);
Mike Rowan's avatar
Mike Rowan committed
399 400 401
  return make_float (d);
}

402
DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0,
403
  "Return the cube root of ARG.")
404 405
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
406
{
407 408 409 410 411 412 413 414 415
  double d = extract_float (arg);
#ifdef HAVE_CBRT
  IN_FLOAT (d = cbrt (d), "cube-root", arg);
#else
  if (d >= 0.0)
    IN_FLOAT (d = pow (d, 1.0/3.0), "cube-root", arg);
  else
    IN_FLOAT (d = -pow (-d, 1.0/3.0), "cube-root", arg);
#endif
Mike Rowan's avatar
Mike Rowan committed
416 417 418
  return make_float (d);
}

Richard M. Stallman's avatar
Richard M. Stallman committed
419 420
#endif

421 422
DEFUN ("exp", Fexp, Sexp, 1, 1, 0,
  "Return the exponential base e of ARG.")
423 424 425 426 427 428 429 430 431 432 433 434
  (arg)
     register Lisp_Object arg;
{
  double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
  if (d > 709.7827)   /* Assume IEEE doubles here */
    range_error ("exp", arg);
  else if (d < -709.0)
    return make_float (0.0);
  else
#endif
    IN_FLOAT (d = exp (d), "exp", arg);
Mike Rowan's avatar
Mike Rowan committed
435 436 437 438
  return make_float (d);
}

DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
439
  "Return the exponential X ** Y.")
440 441
  (arg1, arg2)
     register Lisp_Object arg1, arg2;
Mike Rowan's avatar
Mike Rowan committed
442 443 444
{
  double f1, f2;

445 446
  CHECK_NUMBER_OR_FLOAT (arg1, 0);
  CHECK_NUMBER_OR_FLOAT (arg2, 0);
447 448
  if (INTEGERP (arg1)     /* common lisp spec */
      && INTEGERP (arg2)) /* don't promote, if both are ints */
Mike Rowan's avatar
Mike Rowan committed
449
    {				/* this can be improved by pre-calculating */
450
      int acc, x, y;		/* some binary powers of x then accumulating */
451 452
      Lisp_Object val;

453 454
      x = XINT (arg1);
      y = XINT (arg2);
Mike Rowan's avatar
Mike Rowan committed
455 456 457 458
      acc = 1;
      
      if (y < 0)
	{
459 460 461 462 463 464
	  if (x == 1)
	    acc = 1;
	  else if (x == -1)
	    acc = (y & 1) ? -1 : 1;
	  else
	    acc = 0;
Mike Rowan's avatar
Mike Rowan committed
465 466 467
	}
      else
	{
468 469 470 471 472 473 474
	  while (y > 0)
	    {
	      if (y & 1)
		acc *= x;
	      x *= x;
	      y = (unsigned)y >> 1;
	    }
Mike Rowan's avatar
Mike Rowan committed
475
	}
476
      XSETINT (val, acc);
477
      return val;
Mike Rowan's avatar
Mike Rowan committed
478
    }
479 480
  f1 = FLOATP (arg1) ? XFLOAT (arg1)->data : XINT (arg1);
  f2 = FLOATP (arg2) ? XFLOAT (arg2)->data : XINT (arg2);
481 482 483 484 485 486 487
  /* Really should check for overflow, too */
  if (f1 == 0.0 && f2 == 0.0)
    f1 = 1.0;
#ifdef FLOAT_CHECK_DOMAIN
  else if ((f1 == 0.0 && f2 < 0.0) || (f1 < 0 && f2 != floor(f2)))
    domain_error2 ("expt", arg1, arg2);
#endif
Richard M. Stallman's avatar
Richard M. Stallman committed
488
  IN_FLOAT2 (f1 = pow (f1, f2), "expt", arg1, arg2);
Mike Rowan's avatar
Mike Rowan committed
489 490
  return make_float (f1);
}
491

492
DEFUN ("log", Flog, Slog, 1, 2, 0,
493 494 495 496
  "Return the natural logarithm of ARG.\n\
If second optional argument BASE is given, return log ARG using that base.")
  (arg, base)
     register Lisp_Object arg, base;
Mike Rowan's avatar
Mike Rowan committed
497
{
498
  double d = extract_float (arg);
499

500 501 502 503
#ifdef FLOAT_CHECK_DOMAIN
  if (d <= 0.0)
    domain_error2 ("log", arg, base);
#endif
504
  if (NILP (base))
505
    IN_FLOAT (d = log (d), "log", arg);
506 507 508 509
  else
    {
      double b = extract_float (base);

510 511 512 513 514 515 516
#ifdef FLOAT_CHECK_DOMAIN
      if (b <= 0.0 || b == 1.0)
	domain_error2 ("log", arg, base);
#endif
      if (b == 10.0)
	IN_FLOAT2 (d = log10 (d), "log", arg, base);
      else
517
	IN_FLOAT2 (d = log (d) / log (b), "log", arg, base);
518
    }
Mike Rowan's avatar
Mike Rowan committed
519 520 521
  return make_float (d);
}

522 523
DEFUN ("log10", Flog10, Slog10, 1, 1, 0,
  "Return the logarithm base 10 of ARG.")
524 525
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
526
{
527 528 529 530 531 532
  double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
  if (d <= 0.0)
    domain_error ("log10", arg);
#endif
  IN_FLOAT (d = log10 (d), "log10", arg);
533 534 535
  return make_float (d);
}

Mike Rowan's avatar
Mike Rowan committed
536 537
DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
  "Return the square root of ARG.")
538 539
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
540
{
541 542 543 544 545 546
  double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
  if (d < 0.0)
    domain_error ("sqrt", arg);
#endif
  IN_FLOAT (d = sqrt (d), "sqrt", arg);
Mike Rowan's avatar
Mike Rowan committed
547 548
  return make_float (d);
}
549

Richard M. Stallman's avatar
Richard M. Stallman committed
550
#if 0 /* Not clearly worth adding.  */
Mike Rowan's avatar
Mike Rowan committed
551

552 553
DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0,
  "Return the inverse hyperbolic cosine of ARG.")
554 555
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
556
{
557 558 559 560 561 562 563 564 565 566
  double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
  if (d < 1.0)
    domain_error ("acosh", arg);
#endif
#ifdef HAVE_INVERSE_HYPERBOLIC
  IN_FLOAT (d = acosh (d), "acosh", arg);
#else
  IN_FLOAT (d = log (d + sqrt (d*d - 1.0)), "acosh", arg);
#endif
567 568 569 570 571
  return make_float (d);
}

DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0,
  "Return the inverse hyperbolic sine of ARG.")
572 573
  (arg)
     register Lisp_Object arg;
574
{
575 576 577 578 579 580
  double d = extract_float (arg);
#ifdef HAVE_INVERSE_HYPERBOLIC
  IN_FLOAT (d = asinh (d), "asinh", arg);
#else
  IN_FLOAT (d = log (d + sqrt (d*d + 1.0)), "asinh", arg);
#endif
581 582 583 584 585
  return make_float (d);
}

DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0,
  "Return the inverse hyperbolic tangent of ARG.")
586 587
  (arg)
     register Lisp_Object arg;
588
{
589 590 591 592 593 594 595 596 597 598
  double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
  if (d >= 1.0 || d <= -1.0)
    domain_error ("atanh", arg);
#endif
#ifdef HAVE_INVERSE_HYPERBOLIC
  IN_FLOAT (d = atanh (d), "atanh", arg);
#else
  IN_FLOAT (d = 0.5 * log ((1.0 + d) / (1.0 - d)), "atanh", arg);
#endif
599 600 601 602 603
  return make_float (d);
}

DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0,
  "Return the hyperbolic cosine of ARG.")
604 605
  (arg)
     register Lisp_Object arg;
606
{
607 608 609 610 611 612
  double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
  if (d > 710.0 || d < -710.0)
    range_error ("cosh", arg);
#endif
  IN_FLOAT (d = cosh (d), "cosh", arg);
613 614 615 616 617
  return make_float (d);
}

DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0,
  "Return the hyperbolic sine of ARG.")
618 619
  (arg)
     register Lisp_Object arg;
620
{
621 622 623 624 625 626
  double d = extract_float (arg);
#ifdef FLOAT_CHECK_DOMAIN
  if (d > 710.0 || d < -710.0)
    range_error ("sinh", arg);
#endif
  IN_FLOAT (d = sinh (d), "sinh", arg);
Mike Rowan's avatar
Mike Rowan committed
627 628 629 630 631
  return make_float (d);
}

DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0,
  "Return the hyperbolic tangent of ARG.")
632 633
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
634
{
635 636
  double d = extract_float (arg);
  IN_FLOAT (d = tanh (d), "tanh", arg);
Mike Rowan's avatar
Mike Rowan committed
637 638
  return make_float (d);
}
639
#endif
Mike Rowan's avatar
Mike Rowan committed
640 641 642

DEFUN ("abs", Fabs, Sabs, 1, 1, 0,
  "Return the absolute value of ARG.")
643 644
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
645
{
646
  CHECK_NUMBER_OR_FLOAT (arg, 0);
Mike Rowan's avatar
Mike Rowan committed
647

648
  if (FLOATP (arg))
649 650
    IN_FLOAT (arg = make_float (fabs (XFLOAT (arg)->data)), "abs", arg);
  else if (XINT (arg) < 0)
651
    XSETINT (arg, - XINT (arg));
Mike Rowan's avatar
Mike Rowan committed
652

653
  return arg;
Mike Rowan's avatar
Mike Rowan committed
654 655 656 657
}

DEFUN ("float", Ffloat, Sfloat, 1, 1, 0,
  "Return the floating point number equal to ARG.")
658 659
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
660
{
661
  CHECK_NUMBER_OR_FLOAT (arg, 0);
Mike Rowan's avatar
Mike Rowan committed
662

663
  if (INTEGERP (arg))
664
    return make_float ((double) XINT (arg));
Mike Rowan's avatar
Mike Rowan committed
665
  else				/* give 'em the same float back */
666
    return arg;
Mike Rowan's avatar
Mike Rowan committed
667 668 669
}

DEFUN ("logb", Flogb, Slogb, 1, 1, 0,
Richard M. Stallman's avatar
Richard M. Stallman committed
670
  "Returns largest integer <= the base 2 log of the magnitude of ARG.\n\
Mike Rowan's avatar
Mike Rowan committed
671
This is the same as the exponent of a float.")
672 673
     (arg)
     Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
674
{
675
  Lisp_Object val;
676 677
  int value;
  double f = extract_float (arg);
678

679 680 681 682
  if (f == 0.0)
    value = -(VALMASK >> 1);
  else
    {
683
#ifdef HAVE_LOGB
684
      IN_FLOAT (value = logb (f), "logb", arg);
685 686
#else
#ifdef HAVE_FREXP
687 688
      IN_FLOAT (frexp (f, &value), "logb", arg);
      value--;
689
#else
690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708
      int i;
      double d;
      if (f < 0.0)
	f = -f;
      value = -1;
      while (f < 0.5)
	{
	  for (i = 1, d = 0.5; d * d >= f; i += i)
	    d *= d;
	  f /= d;
	  value -= i;
	}
      while (f >= 1.0)
	{
	  for (i = 1, d = 2.0; d * d <= f; i += i)
	    d *= d;
	  f /= d;
	  value += i;
	}
709
#endif
710
#endif
711
    }
712
  XSETINT (val, value);
713
  return val;
Mike Rowan's avatar
Mike Rowan committed
714 715 716 717 718 719
}

/* the rounding functions  */

DEFUN ("ceiling", Fceiling, Sceiling, 1, 1, 0,
  "Return the smallest integer no less than ARG.  (Round toward +inf.)")
720 721
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
722
{
723
  CHECK_NUMBER_OR_FLOAT (arg, 0);
Mike Rowan's avatar
Mike Rowan committed
724

725
  if (FLOATP (arg))
726 727 728 729 730 731
    {
      double d;

      IN_FLOAT (d = ceil (XFLOAT (arg)->data), "ceiling", arg);
      FLOAT_TO_INT (d, arg, "ceiling", arg);
    }
Mike Rowan's avatar
Mike Rowan committed
732

733
  return arg;
Mike Rowan's avatar
Mike Rowan committed
734 735
}

736 737 738 739 740 741 742 743
#endif /* LISP_FLOAT_TYPE */


DEFUN ("floor", Ffloor, Sfloor, 1, 2, 0,
  "Return the largest integer no greater than ARG.  (Round towards -inf.)\n\
With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR.")
  (arg, divisor)
     register Lisp_Object arg, divisor;
Mike Rowan's avatar
Mike Rowan committed
744
{
745
  CHECK_NUMBER_OR_FLOAT (arg, 0);
Mike Rowan's avatar
Mike Rowan committed
746

747 748 749 750 751 752 753
  if (! NILP (divisor))
    {
      int i1, i2;

      CHECK_NUMBER_OR_FLOAT (divisor, 1);

#ifdef LISP_FLOAT_TYPE
754
      if (FLOATP (arg) || FLOATP (divisor))
755 756 757
	{
	  double f1, f2;

758 759
	  f1 = FLOATP (arg) ? XFLOAT (arg)->data : XINT (arg);
	  f2 = (FLOATP (divisor) ? XFLOAT (divisor)->data : XINT (divisor));
760 761 762
	  if (f2 == 0)
	    Fsignal (Qarith_error, Qnil);

763 764
	  IN_FLOAT2 (f1 = floor (f1 / f2), "floor", arg, divisor);
	  FLOAT_TO_INT2 (f1, arg, "floor", arg, divisor);
765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780
	  return arg;
	}
#endif

      i1 = XINT (arg);
      i2 = XINT (divisor);

      if (i2 == 0)
	Fsignal (Qarith_error, Qnil);

      /* With C's /, the result is implementation-defined if either operand
	 is negative, so use only nonnegative operands.  */
      i1 = (i2 < 0
	    ? (i1 <= 0  ?  -i1 / -i2  :  -1 - ((i1 - 1) / -i2))
	    : (i1 < 0  ?  -1 - ((-1 - i1) / i2)  :  i1 / i2));

781
      XSETINT (arg, i1);
782 783 784 785
      return arg;
    }

#ifdef LISP_FLOAT_TYPE
786
  if (FLOATP (arg))
787 788 789 790 791
    {
      double d;
      IN_FLOAT (d = floor (XFLOAT (arg)->data), "floor", arg);
      FLOAT_TO_INT (d, arg, "floor", arg);
    }
792
#endif
Mike Rowan's avatar
Mike Rowan committed
793

794
  return arg;
Mike Rowan's avatar
Mike Rowan committed
795 796
}

797 798
#ifdef LISP_FLOAT_TYPE

Mike Rowan's avatar
Mike Rowan committed
799 800
DEFUN ("round", Fround, Sround, 1, 1, 0,
  "Return the nearest integer to ARG.")
801 802
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
803
{
804
  CHECK_NUMBER_OR_FLOAT (arg, 0);
Mike Rowan's avatar
Mike Rowan committed
805

806
  if (FLOATP (arg))
807 808 809 810 811 812 813
    {
      double d;

      /* Screw the prevailing rounding mode.  */
      IN_FLOAT (d = rint (XFLOAT (arg)->data), "round", arg);
      FLOAT_TO_INT (d, arg, "round", arg);
    }
Mike Rowan's avatar
Mike Rowan committed
814

815
  return arg;
Mike Rowan's avatar
Mike Rowan committed
816 817 818 819 820
}

DEFUN ("truncate", Ftruncate, Struncate, 1, 1, 0,
       "Truncate a floating point number to an int.\n\
Rounds the value toward zero.")
821 822
  (arg)
     register Lisp_Object arg;
Mike Rowan's avatar
Mike Rowan committed
823
{
824
  CHECK_NUMBER_OR_FLOAT (arg, 0);
Mike Rowan's avatar
Mike Rowan committed
825

826
  if (FLOATP (arg))
827 828 829 830 831 832
    {
      double d;

      d = XFLOAT (arg)->data;
      FLOAT_TO_INT (d, arg, "truncate", arg);
    }
833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859

  return arg;
}

/* It's not clear these are worth adding.  */

DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0,
  "Return the smallest integer no less than ARG, as a float.\n\
\(Round toward +inf.\)")
  (arg)
     register Lisp_Object arg;
{
  double d = extract_float (arg);
  IN_FLOAT (d = ceil (d), "fceiling", arg);
  return make_float (d);
}

DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0,
  "Return the largest integer no greater than ARG, as a float.\n\
\(Round towards -inf.\)")
  (arg)
     register Lisp_Object arg;
{
  double d = extract_float (arg);
  IN_FLOAT (d = floor (d), "ffloor", arg);
  return make_float (d);
}
Mike Rowan's avatar
Mike Rowan committed
860

861 862 863 864 865 866
DEFUN ("fround", Ffround, Sfround, 1, 1, 0,
  "Return the nearest integer to ARG, as a float.")
  (arg)
     register Lisp_Object arg;
{
  double d = extract_float (arg);
867
  IN_FLOAT (d = rint (d), "fround", arg);
868 869 870 871 872 873 874 875 876 877 878 879 880
  return make_float (d);
}

DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0,
       "Truncate a floating point number to an integral float value.\n\
Rounds the value toward zero.")
  (arg)
     register Lisp_Object arg;
{
  double d = extract_float (arg);
  if (d >= 0.0)
    IN_FLOAT (d = floor (d), "ftruncate", arg);
  else
881
    IN_FLOAT (d = ceil (d), "ftruncate", arg);
882
  return make_float (d);
Mike Rowan's avatar
Mike Rowan committed
883 884
}

885
#ifdef FLOAT_CATCH_SIGILL
Jim Blandy's avatar
Jim Blandy committed
886
static SIGTYPE
Mike Rowan's avatar
Mike Rowan committed
887 888 889 890 891 892
float_error (signo)
     int signo;
{
  if (! in_float)
    fatal_error_signal (signo);

Jim Blandy's avatar
Jim Blandy committed
893
#ifdef BSD
Mike Rowan's avatar
Mike Rowan committed
894 895 896
#ifdef BSD4_1
  sigrelse (SIGILL);
#else /* not BSD4_1 */
Jim Blandy's avatar
Jim Blandy committed
897
  sigsetmask (SIGEMPTYMASK);
Mike Rowan's avatar
Mike Rowan committed
898
#endif /* not BSD4_1 */
Jim Blandy's avatar
Jim Blandy committed
899 900 901 902
#else
  /* Must reestablish handler each time it is called.  */
  signal (SIGILL, float_error);
#endif /* BSD */
Mike Rowan's avatar
Mike Rowan committed
903 904 905 906 907 908

  in_float = 0;

  Fsignal (Qarith_error, Fcons (float_error_arg, Qnil));
}

909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943
/* Another idea was to replace the library function `infnan'
   where SIGILL is signaled.  */

#endif /* FLOAT_CATCH_SIGILL */

#ifdef HAVE_MATHERR
int 
matherr (x)
     struct exception *x;
{
  Lisp_Object args;
  if (! in_float)
    /* Not called from emacs-lisp float routines; do the default thing. */
    return 0;
  if (!strcmp (x->name, "pow"))
    x->name = "expt";

  args
    = Fcons (build_string (x->name),
	     Fcons (make_float (x->arg1),
		    ((!strcmp (x->name, "log") || !strcmp (x->name, "pow"))
		     ? Fcons (make_float (x->arg2), Qnil)
		     : Qnil)));
  switch (x->type)
    {
    case DOMAIN:	Fsignal (Qdomain_error, args);		break;
    case SING:		Fsignal (Qsingularity_error, args);	break;
    case OVERFLOW:	Fsignal (Qoverflow_error, args);	break;
    case UNDERFLOW:	Fsignal (Qunderflow_error, args);	break;
    default:		Fsignal (Qarith_error, args);		break;
    }
  return (1);	/* don't set errno or print a message */
}
#endif /* HAVE_MATHERR */

Mike Rowan's avatar
Mike Rowan committed
944 945
init_floatfns ()
{
946
#ifdef FLOAT_CATCH_SIGILL
Mike Rowan's avatar
Mike Rowan committed
947
  signal (SIGILL, float_error);
948
#endif 
Mike Rowan's avatar
Mike Rowan committed
949 950 951
  in_float = 0;
}

952 953 954 955 956 957 958
#else /* not LISP_FLOAT_TYPE */

init_floatfns ()
{}

#endif /* not LISP_FLOAT_TYPE */

Mike Rowan's avatar
Mike Rowan committed
959 960
syms_of_floatfns ()
{
961
#ifdef LISP_FLOAT_TYPE
Mike Rowan's avatar
Mike Rowan committed
962 963 964
  defsubr (&Sacos);
  defsubr (&Sasin);
  defsubr (&Satan);
965 966 967 968 969 970
  defsubr (&Scos);
  defsubr (&Ssin);
  defsubr (&Stan);
#if 0
  defsubr (&Sacosh);
  defsubr (&Sasinh);
Mike Rowan's avatar
Mike Rowan committed
971
  defsubr (&Satanh);
972 973 974
  defsubr (&Scosh);
  defsubr (&Ssinh);
  defsubr (&Stanh);
Mike Rowan's avatar
Mike Rowan committed
975 976 977 978 979 980 981 982
  defsubr (&Sbessel_y0);
  defsubr (&Sbessel_y1);
  defsubr (&Sbessel_yn);
  defsubr (&Sbessel_j0);
  defsubr (&Sbessel_j1);
  defsubr (&Sbessel_jn);
  defsubr (&Serf);
  defsubr (&Serfc);
983
  defsubr (&Slog_gamma);
984
  defsubr (&Scube_root);
985
#endif
986 987 988 989
  defsubr (&Sfceiling);
  defsubr (&Sffloor);
  defsubr (&Sfround);
  defsubr (&Sftruncate);
Mike Rowan's avatar
Mike Rowan committed
990
  defsubr (&Sexp);
991
  defsubr (&Sexpt);
Mike Rowan's avatar
Mike Rowan committed
992 993 994 995 996 997 998 999 1000 1001
  defsubr (&Slog);
  defsubr (&Slog10);
  defsubr (&Ssqrt);

  defsubr (&Sabs);
  defsubr (&Sfloat);
  defsubr (&Slogb);
  defsubr (&Sceiling);
  defsubr (&Sround);
  defsubr (&Struncate);
1002 1003
#endif /* LISP_FLOAT_TYPE */
  defsubr (&Sfloor);
Mike Rowan's avatar
Mike Rowan committed
1004
}