cgit.sxemacs.org Git - sxemacs/blob - src/ent/floatfns.c

   1 /* Primitive operations on floating point for SXEmacs Lisp interpreter.
   2    Copyright (C) 1988, 1993, 1994 Free Software Foundation, Inc.
   3
   4 This file is part of SXEmacs
   5
   6 SXEmacs 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 3 of the License, or
   9 (at your option) any later version.
  10
  11 SXEmacs 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 this program.  If not, see <http://www.gnu.org/licenses/>. */
  18
  19
  20 /* Synched up with: FSF 19.30. */
  21
  22 /* ANSI C requires only these float functions:
  23    acos, asin, atan, atan2, ceil, cos, cosh, exp, fabs, floor, fmod,
  24    frexp, ldexp, log, log10, modf, pow, sin, sinh, sqrt, tan, tanh.
  25
  26    Define HAVE_INVERSE_HYPERBOLIC if you have acosh, asinh, and atanh.
  27    Define HAVE_CBRT if you have cbrt().
  28    Define HAVE_RINT if you have rint().
  29    If you don't define these, then the appropriate routines will be simulated.
  30
  31    Define HAVE_MATHERR if on a system supporting the SysV matherr() callback.
  32    (This should happen automatically.)
  33
  34    Define FLOAT_CHECK_ERRNO if the float library routines set errno.
  35    This has no effect if HAVE_MATHERR is defined.
  36
  37    Define FLOAT_CATCH_SIGILL if the float library routines signal SIGILL.
  38    (What systems actually do this?  Let me know. -jwz)
  39
  40    Define FLOAT_CHECK_DOMAIN if the float library doesn't handle errors by
  41    either setting errno, or signalling SIGFPE/SIGILL.  Otherwise, domain and
  42    range checking will happen before calling the float routines.  This has
  43    no effect if HAVE_MATHERR is defined (since matherr will be called when
  44    a domain error occurs).
  45  */
  46
  47 #include <config.h>
  48 #include "lisp.h"
  49 #include "syssignal.h"
  50
  51 #ifdef HAVE_FPFLOAT
  52
  53 /* The code uses emacs_rint, so that it works to undefine HAVE_RINT
  54    if `rint' exists but does not work right.  */
  55 #ifdef HAVE_RINT
  56 #define emacs_rint rint
  57 #else
  58 static fpfloat emacs_rint(fpfloat x)
  59 {
  60         fpfloat r = floor(x + 0.5);
  61         fpfloat diff = fabs(r - x);
  62         /* Round to even and correct for any roundoff errors.  */
  63         if (diff >= 0.5 && (diff > 0.5 || r != 2.0 * floor(r / 2.0)))
  64                 r += r < x ? 1.0 : -1.0;
  65         return r;
  66 }
  67 #endif
  68
  69 /* Nonzero while executing in floating point.
  70    This tells float_error what to do.  */
  71 static int in_float;
  72
  73 /* If an argument is out of range for a mathematical function,
  74    here is the actual argument value to use in the error message.  */
  75 static Lisp_Object float_error_arg, float_error_arg2;
  76 static const char *float_error_fn_name;
  77
  78 /* Evaluate the floating point expression D, recording NUM
  79    as the original argument for error messages.
  80    D is normally an assignment expression.
  81    Handle errors which may result in signals or may set errno.
  82
  83    Note that float_error may be declared to return void, so you can't
  84    just cast the zero after the colon to (SIGTYPE) to make the types
  85    check properly.  */
  86 #ifdef FLOAT_CHECK_ERRNO
  87 #define IN_FLOAT(d, name, num)                          \
  88   do {                                                  \
  89     float_error_arg = num;                              \
  90     float_error_fn_name = name;                         \
  91     in_float = 1; errno = 0; (d); in_float = 0;         \
  92     if (errno != 0) in_float_error ();                  \
  93   } while (0)
  94 #define IN_FLOAT2(d, name, num, num2)                   \
  95   do {                                                  \
  96     float_error_arg = num;                              \
  97     float_error_arg2 = num2;                            \
  98     float_error_fn_name = name;                         \
  99     in_float = 2; errno = 0; (d); in_float = 0;         \
 100     if (errno != 0) in_float_error ();                  \
 101   } while (0)
 102 #else
 103 #define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0)
 104 #define IN_FLOAT2(d, name, num, num2) (in_float = 2, (d), in_float = 0)
 105 #endif
 106
 107 #define arith_error(op,arg) \
 108   Fsignal (Qarith_error, list2 (build_string (op), arg))
 109 #define range_error(op,arg) \
 110   Fsignal (Qrange_error, list2 (build_string (op), arg))
 111 #define range_error2(op,a1,a2) \
 112   Fsignal (Qrange_error, list3 (build_string (op), a1, a2))
 113 #define domain_error(op,arg) \
 114   Fsignal (Qdomain_error, list2 (build_string (op), arg))
 115 #define domain_error2(op,a1,a2) \
 116   Fsignal (Qdomain_error, list3 (build_string (op), a1, a2))
 117
 118 /* Convert float to Lisp Integer if it fits, else signal a range
 119    error using the given arguments.
 120    If numbers from multi-prec libraries are available, range errors
 121    are never signaled.
 122 */
 123 static Lisp_Object
 124 float_to_int(fpfloat x, const char *name, Lisp_Object num, Lisp_Object num2)
 125 {
 126 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 127         bigz_set_fpfloat(ent_scratch_bigz, x);
 128         return ent_mpz_downgrade_maybe(ent_scratch_bigz);
 129
 130         if (name || NILP(num) || NILP(num2));
 131         return Qnil;
 132 #else  /* !HAVE_MPZ */
 133         REGISTER EMACS_INT result = (EMACS_INT) x;
 134
 135         if (result > EMACS_INT_MAX || result < EMACS_INT_MIN) {
 136                 if (!UNBOUNDP(num2))
 137                         range_error2(name, num, num2);
 138                 else
 139                         range_error(name, num);
 140         }
 141         return make_int(result);
 142 #endif  /* HAVE_MPZ */
 143 }
 144
 145 static void in_float_error(void)
 146 {
 147         switch (errno) {
 148         case 0:
 149                 break;
 150         case EDOM:
 151                 if (in_float == 2)
 152                         domain_error2(float_error_fn_name, float_error_arg,
 153                                       float_error_arg2);
 154                 else
 155                         domain_error(float_error_fn_name, float_error_arg);
 156                 break;
 157         case ERANGE:
 158                 range_error(float_error_fn_name, float_error_arg);
 159                 break;
 160         default:
 161                 arith_error(float_error_fn_name, float_error_arg);
 162                 break;
 163         }
 164 }
 165
 166 \f
 167 #endif  /* HAVE_FPFLOAT */
 168 \f
 169 /* Trig functions.  */
 170
 171 #if defined HAVE_MPFR && defined WITH_MPFR
 172 #define MPFR_TRIG_FUN(op) do                                            \
 173 {                                                                       \
 174         Lisp_Object bfrnumber;                                          \
 175                                                                         \
 176         if (INDEFP(number))                                             \
 177                 return make_indef(NOT_A_NUMBER);                        \
 178                                                                         \
 179         bigfr_set_prec(ent_scratch_bigfr,                               \
 180                        internal_get_precision(precision));              \
 181                                                                         \
 182         bfrnumber = Fcoerce_number(number, Qbigfr, Qnil);               \
 183         bigfr_##op(ent_scratch_bigfr, XBIGFR_DATA(bfrnumber));          \
 184         return make_bigfr_bfr(ent_scratch_bigfr);                       \
 185 } while (0)
 186 #endif
 187
 188 #if defined(HAVE_MPFR) && defined WITH_MPFR || defined(HAVE_FPFLOAT)
 189
 190 DEFUN("acos", Facos, 1, 2, 0,   /*
 191 Return the inverse cosine of NUMBER.
 192 If optional argument PRECISION is non-nil, its value
 193 (an integer) is used as precision.
 194 */
 195       (number, precision))
 196 {
 197 #if defined HAVE_MPFR && defined WITH_MPFR
 198
 199         MPFR_TRIG_FUN(acos);
 200
 201 #else  /* !HAVE_MPFR */
 202         if (INDEFP(number)) {
 203                 return make_indef(NOT_A_NUMBER);
 204         }
 205
 206         number = ent_lift(number, FLOAT_T, NULL);
 207
 208         if (FLOATP(number)) {
 209                 fpfloat d;
 210                 d = acos(XFLOAT_DATA(number));
 211                 return make_float(d);
 212         } else if (INDEFP(number)) {
 213                 return make_indef(NOT_A_NUMBER);
 214         }
 215
 216         Fsignal(Qarith_error, list1(number));
 217         return Qnil;
 218 #endif  /* HAVE_MPFR */
 219 }
 220
 221 DEFUN("asin", Fasin, 1, 2, 0,   /*
 222 Return the inverse sine of NUMBER.
 223 If optional argument PRECISION is non-nil, its value
 224 (an integer) is used as precision.
 225 */
 226       (number, precision))
 227 {
 228 #if defined HAVE_MPFR && defined WITH_MPFR
 229
 230         MPFR_TRIG_FUN(asin);
 231
 232 #else  /* !HAVE_MPFR */
 233         if (INDEFP(number)) {
 234                 return make_indef(NOT_A_NUMBER);
 235         }
 236
 237         number = ent_lift(number, FLOAT_T, NULL);
 238
 239         if (FLOATP(number)) {
 240                 fpfloat d;
 241                 d = asin(XFLOAT_DATA(number));
 242                 return make_float(d);
 243         } else if (INDEFP(number)) {
 244                 return make_indef(NOT_A_NUMBER);
 245         }
 246
 247         Fsignal(Qarith_error, list1(number));
 248         return Qnil;
 249
 250         if (NILP(precision));
 251 #endif  /* HAVE_MPFR */
 252 }
 253
 254 DEFUN("atan", Fatan, 1, 3, 0,   /*
 255 Return the inverse tangent of NUMBER.
 256 If optional second argument NUMBER2 is provided,
 257 return atan2 (NUMBER, NUMBER2).
 258 If optional argument PRECISION is non-nil, its value
 259 (an integer) is used as precision.
 260 */
 261       (number, number2, precision))
 262 {
 263 #if defined HAVE_MPFR && defined WITH_MPFR
 264         Lisp_Object result;
 265
 266         if (NILP(number2)) {
 267                 Lisp_Object bfrnumber;
 268
 269                 if (INDEFP(number))
 270                         return make_indef(NOT_A_NUMBER);
 271
 272                 bigfr_set_prec(ent_scratch_bigfr,
 273                                internal_get_precision(precision));
 274                 bfrnumber = Fcoerce_number(number, Qbigfr, Qnil);
 275                 bigfr_atan(ent_scratch_bigfr, XBIGFR_DATA(bfrnumber));
 276                 result = make_bigfr_bfr(ent_scratch_bigfr);
 277         } else {
 278                 Lisp_Object bfrn1;
 279                 Lisp_Object bfrn2;
 280
 281                 if (INDEFP(number))
 282                         return make_indef(NOT_A_NUMBER);
 283                 if (INFINITYP(number2))
 284                         return Qzero;
 285                 if (INDEFP(number2))
 286                         return make_indef(NOT_A_NUMBER);
 287
 288                 bigfr_set_prec(ent_scratch_bigfr,
 289                                internal_get_precision(precision));
 290                 bfrn1 = Fcoerce_number(number, Qbigfr, Qnil);
 291                 bfrn2 = Fcoerce_number(number2, Qbigfr, Qnil);
 292                 bigfr_atan2(ent_scratch_bigfr,
 293                             XBIGFR_DATA(bfrn1),
 294                             XBIGFR_DATA(bfrn2));
 295                 result = make_bigfr_bfr(ent_scratch_bigfr);
 296         }
 297
 298         return result;
 299
 300 #else  /* !HAVE_MPFR */
 301         if (INDEFP(number)) {
 302                 return make_indef(NOT_A_NUMBER);
 303         }
 304
 305         number = ent_lift(number, FLOAT_T, NULL);
 306
 307         if (INDEFP(number))
 308                 return make_indef(NOT_A_NUMBER);
 309
 310         if (NILP(number2) && FLOATP(number)) {
 311                 fpfloat d;
 312                 d = atan(XFLOAT_DATA(number));
 313                 return make_float(d);
 314         } else if (FLOATP(number)) {
 315                 number = ent_lift(number2, FLOAT_T, NULL);
 316
 317                 if (FLOATP(number2)) {
 318                         fpfloat d;
 319                         d = atan2(XFLOAT_DATA(number), XFLOAT_DATA(number2));
 320                         return make_float(d);
 321                 } else if (INFINITYP(number2)) {
 322                         return Qzero;
 323                 } else if (INDEFP(number2)) {
 324                         return make_indef(NOT_A_NUMBER);
 325                 }
 326         }
 327
 328         /* Just signal here, I'm not in the mood to distinguish cases here */
 329         Fsignal(Qarith_error, list1(number));
 330         return Qnil;
 331
 332         if (NILP(precision));
 333 #endif  /* HAVE_MPFR */
 334 }
 335
 336 DEFUN("cos", Fcos, 1, 2, 0,     /*
 337 Return the cosine of NUMBER.
 338 If optional argument PRECISION is non-nil, its value
 339 (an integer) is used as precision.
 340 */
 341       (number, precision))
 342 {
 343 #if defined HAVE_MPFR && defined WITH_MPFR
 344
 345         MPFR_TRIG_FUN(cos);
 346
 347 #else  /* !HAVE_MPFR */
 348         if (INDEFP(number)) {
 349                 return make_indef(NOT_A_NUMBER);
 350         }
 351
 352         number = ent_lift(number, FLOAT_T, NULL);
 353
 354         if (FLOATP(number)) {
 355                 fpfloat d;
 356                 d = cos(XFLOAT_DATA(number));
 357                 return make_float(d);
 358         } else if (INDEFP(number)) {
 359                 return make_indef(NOT_A_NUMBER);
 360         }
 361
 362         Fsignal(Qarith_error, list1(number));
 363         return Qnil;
 364
 365         if (NILP(precision));
 366 #endif  /* HAVE_MPFR */
 367 }
 368
 369 DEFUN("sin", Fsin, 1, 2, 0,     /*
 370 Return the sine of NUMBER.
 371 If optional argument PRECISION is non-nil, its value
 372 (an integer) is used as precision.
 373 */
 374       (number, precision))
 375 {
 376 #if defined HAVE_MPFR && defined WITH_MPFR
 377
 378         MPFR_TRIG_FUN(sin);
 379
 380 #else  /* !HAVE_MPFR */
 381         if (INDEFP(number)) {
 382                 return make_indef(NOT_A_NUMBER);
 383         }
 384
 385         number = ent_lift(number, FLOAT_T, NULL);
 386
 387         if (FLOATP(number)) {
 388                 fpfloat d;
 389                 d = sin(XFLOAT_DATA(number));
 390                 return make_float(d);
 391         } else if (INDEFP(number)) {
 392                 return make_indef(NOT_A_NUMBER);
 393         }
 394
 395         Fsignal(Qarith_error, list1(number));
 396         return Qnil;
 397
 398         if (NILP(precision));
 399 #endif  /* HAVE_MPFR */
 400 }
 401
 402 DEFUN("tan", Ftan, 1, 2, 0,     /*
 403 Return the tangent of NUMBER.
 404 If optional argument PRECISION is non-nil, its value
 405 (an integer) is used as precision.
 406 */
 407       (number, precision))
 408 {
 409 #if defined HAVE_MPFR && defined WITH_MPFR
 410
 411         MPFR_TRIG_FUN(tan);
 412
 413 #else  /* !HAVE_MPFR */
 414         if (INDEFP(number)) {
 415                 return make_indef(NOT_A_NUMBER);
 416         }
 417
 418         number = ent_lift(number, FLOAT_T, NULL);
 419
 420         if (FLOATP(number)) {
 421                 fpfloat d;
 422                 d = XFLOAT_DATA(number);
 423                 d = sin(d) / cos(d);
 424                 return make_float(d);
 425         } else if (INDEFP(number)) {
 426                 return make_indef(NOT_A_NUMBER);
 427         }
 428
 429         Fsignal(Qarith_error, list1(number));
 430         return Qnil;
 431
 432         if (NILP(precision));
 433 #endif  /* HAVE_MPFR */
 434 }
 435
 436 #if defined HAVE_MPFR && defined WITH_MPFR
 437 DEFUN("sec", Fsec, 1, 2, 0,     /*
 438 Return the secant of NUMBER.
 439 If optional argument PRECISION is non-nil, its value
 440 (an integer) is used as precision.
 441 */
 442       (number, precision))
 443 {
 444         MPFR_TRIG_FUN(sec);
 445 }
 446
 447 DEFUN("csc", Fcsc, 1, 2, 0,     /*
 448 Return the cosecant of NUMBER.
 449 If optional argument PRECISION is non-nil, its value
 450 (an integer) is used as precision.
 451 */
 452       (number, precision))
 453 {
 454         MPFR_TRIG_FUN(csc);
 455 }
 456
 457 DEFUN("cot", Fcot, 1, 2, 0,     /*
 458 Return the cotangent of NUMBER.
 459 If optional argument PRECISION is non-nil, its value
 460 (an integer) is used as precision.
 461 */
 462       (number, precision))
 463 {
 464         MPFR_TRIG_FUN(cot);
 465 }
 466 #endif  /* HAVE_MPFR */
 467
 468 #endif  /* HAVE_MPFR || HAVE_FPFLOAT (trig functions) */
 469 \f
 470 /* Bessel functions */
 471 #if 0                           /* Leave these out unless we find there's a reason for them.  */
 472 /* #ifdef HAVE_FPFLOAT */
 473
 474 DEFUN("bessel-j0", Fbessel_j0, 1, 1, 0, /*
 475 Return the bessel function j0 of NUMBER.
 476 */
 477       (number))
 478 {
 479         fpfloat d = extract_float(number);
 480         IN_FLOAT(d = j0(d), "bessel-j0", number);
 481         return make_float(d);
 482 }
 483
 484 DEFUN("bessel-j1", Fbessel_j1, 1, 1, 0, /*
 485 Return the bessel function j1 of NUMBER.
 486 */
 487       (number))
 488 {
 489         fpfloat d = extract_float(number);
 490         IN_FLOAT(d = j1(d), "bessel-j1", number);
 491         return make_float(d);
 492 }
 493
 494 DEFUN("bessel-jn", Fbessel_jn, 2, 2, 0, /*
 495 Return the order N bessel function output jn of NUMBER.
 496 The first number (the order) is truncated to an integer.
 497 */
 498       (number1, number2))
 499 {
 500         int i1 = extract_float(number1);
 501         fpfloat f2 = extract_float(number2);
 502
 503         IN_FLOAT(f2 = jn(i1, f2), "bessel-jn", number1);
 504         return make_float(f2);
 505 }
 506
 507 DEFUN("bessel-y0", Fbessel_y0, 1, 1, 0, /*
 508 Return the bessel function y0 of NUMBER.
 509 */
 510       (number))
 511 {
 512         fpfloat d = extract_float(number);
 513         IN_FLOAT(d = y0(d), "bessel-y0", number);
 514         return make_float(d);
 515 }
 516
 517 DEFUN("bessel-y1", Fbessel_y1, 1, 1, 0, /*
 518 Return the bessel function y1 of NUMBER.
 519 */
 520       (number))
 521 {
 522         fpfloat d = extract_float(number);
 523         IN_FLOAT(d = y1(d), "bessel-y0", number);
 524         return make_float(d);
 525 }
 526
 527 DEFUN("bessel-yn", Fbessel_yn, 2, 2, 0, /*
 528 Return the order N bessel function output yn of NUMBER.
 529 The first number (the order) is truncated to an integer.
 530 */
 531       (number1, number2))
 532 {
 533         int i1 = extract_float(number1);
 534         fpfloat f2 = extract_float(number2);
 535
 536         IN_FLOAT(f2 = yn(i1, f2), "bessel-yn", number1);
 537         return make_float(f2);
 538 }
 539
 540 #endif                          /* 0 (bessel functions) */
 541
 542 \f
 543 /* Error functions. */
 544 #if defined(HAVE_MPFR) && defined WITH_MPFR || defined(HAVE_FPFLOAT)
 545 DEFUN("erf", Ferf, 1, 2, 0,     /*
 546 Return the mathematical error function of NUMBER.
 547 */
 548       (number, precision))
 549 {
 550 #if defined HAVE_MPFR && defined WITH_MPFR
 551
 552         MPFR_TRIG_FUN(erf);
 553
 554 #else  /* !HAVE_MPFR */
 555         if (INDEFP(number)) {
 556                 return make_indef(NOT_A_NUMBER);
 557         }
 558
 559         number = ent_lift(number, FLOAT_T, NULL);
 560
 561         if (FLOATP(number)) {
 562                 fpfloat d;
 563                 d = erf(XFLOAT_DATA(number));
 564                 return make_float(d);
 565         } else if (INDEFP(number)) {
 566                 return make_indef(NOT_A_NUMBER);
 567         }
 568
 569         Fsignal(Qarith_error, list1(number));
 570         return Qnil;
 571
 572         if (NILP(precision));
 573 #endif  /* HAVE_MPFR */
 574 }
 575
 576 DEFUN("erfc", Ferfc, 1, 2, 0,   /*
 577 Return the complementary error function of NUMBER.
 578 */
 579       (number, precision))
 580 {
 581 #if defined HAVE_MPFR && defined WITH_MPFR
 582
 583         MPFR_TRIG_FUN(erfc);
 584
 585 #else  /* !HAVE_MPFR */
 586         if (INDEFP(number)) {
 587                 return make_indef(NOT_A_NUMBER);
 588         }
 589
 590         number = ent_lift(number, FLOAT_T, NULL);
 591
 592         if (FLOATP(number)) {
 593                 fpfloat d;
 594                 d = erfc(XFLOAT_DATA(number));
 595                 return make_float(d);
 596         } else if (INDEFP(number)) {
 597                 return make_indef(NOT_A_NUMBER);
 598         }
 599
 600         Fsignal(Qarith_error, list1(number));
 601         return Qnil;
 602
 603         if (NILP(precision));
 604 #endif  /* HAVE_MPFR */
 605 }
 606
 607 DEFUN("log-gamma", Flog_gamma, 1, 2, 0, /*
 608 Return the log gamma of NUMBER.
 609 */
 610       (number, precision))
 611 {
 612 #if defined HAVE_MPFR && defined WITH_MPFR
 613
 614         MPFR_TRIG_FUN(lgamma);
 615
 616 #else  /* !HAVE_MPFR */
 617         if (INDEFP(number)) {
 618                 return make_indef(NOT_A_NUMBER);
 619         }
 620
 621         number = ent_lift(number, FLOAT_T, NULL);
 622
 623         if (FLOATP(number)) {
 624                 fpfloat d;
 625                 d = lgamma(XFLOAT_DATA(number));
 626                 return make_float(d);
 627         } else if (INDEFP(number)) {
 628                 return make_indef(NOT_A_NUMBER);
 629         }
 630
 631         Fsignal(Qarith_error, list1(number));
 632         return Qnil;
 633
 634         if (NILP(precision));
 635 #endif  /* HAVE_MPFR */
 636 }
 637 #endif  /* HAVE_FPFLOAT || HAVE_MPFR */
 638
 639 \f
 640 /* Root and Log functions. */
 641
 642 #if defined(HAVE_FPFLOAT) || defined(HAVE_MPFR) && defined WITH_MPFR
 643 DEFUN("exp", Fexp, 1, 2, 0,     /*
 644 Return the exponential base e of NUMBER.
 645 If optional argument PRECISION is non-nil, its value
 646 (an integer) is used as precision.
 647 */
 648       (number, precision))
 649 {
 650 /* Attention, somehow the precision must be large enough to make the result
 651  * fit, otherwise this is a good memory test :)
 652  */
 653 #if defined(HAVE_MPFR) && defined WITH_MPFR ||  \
 654         defined(HAVE_MPC) && defined WITH_MPC ||        \
 655         defined HAVE_PSEUC && defined WITH_PSEUC
 656
 657         if (INDEFP(number)) {
 658                 if (XINDEF_DATA(number) == POS_INFINITY)
 659                         return number;
 660                 else if (XINDEF_DATA(number) == NEG_INFINITY)
 661                         return Fcoerce_number(Qzero, Qbigfr, precision);
 662                 else
 663                         return number;
 664         }
 665
 666         if (COMPARABLEP(number)) {
 667 #if defined HAVE_MPFR && defined WITH_MPFR
 668                 Lisp_Object bfrnumber;
 669
 670                 bigfr_set_prec(ent_scratch_bigfr,
 671                                internal_get_precision(precision));
 672
 673                 bfrnumber = Fcoerce_number(number, Qbigfr, Qnil);
 674                 bigfr_exp(ent_scratch_bigfr, XBIGFR_DATA(bfrnumber));
 675                 return make_bigfr_bfr(ent_scratch_bigfr);
 676
 677 #endif  /* HAVE_MPFR */
 678 #if defined HAVE_MPC && defined WITH_MPC ||     \
 679         defined HAVE_PSEUC && defined WITH_PSEUC
 680         } else if (BIGCP(number)) {
 681                 bigc_set_prec(ent_scratch_bigc,
 682                               internal_get_precision(precision));
 683
 684                 bigc_exp(ent_scratch_bigc, XBIGC_DATA(number));
 685                 return make_bigc_bc(ent_scratch_bigc);
 686 #endif  /* HAVE_MPC */
 687         }
 688
 689         return wrong_type_argument(Qnumberp, number);
 690 #else  /* !HAVE_MPFR && !HAVE_MPC */
 691         if (INDEFP(number)) {
 692                 goto indefcase;
 693         }
 694
 695         number = ent_lift(number, FLOAT_T, NULL);
 696
 697         if (FLOATP(number)) {
 698                 fpfloat d;
 699                 d = exp(XFLOAT_DATA(number));
 700                 return make_float(d);
 701         } else if (INDEFP(number)) {
 702         indefcase:
 703                 if (XINDEF_DATA(number) == POS_INFINITY)
 704                         return number;
 705                 else if (XINDEF_DATA(number) == NEG_INFINITY)
 706                         return Fcoerce_number(Qzero, Qfloat, precision);
 707                 else
 708                         return number;
 709         }
 710
 711         Fsignal(Qarith_error, list1(number));
 712         return Qnil;
 713
 714         if (NILP(precision));
 715 #endif  /* HAVE_MPFR */
 716 }
 717 #endif  /* HAVE_FPFLOAT || HAVE_MPFR */
 718
 719 DEFUN("2^", Fexp2, 1, 2, 0,     /*
 720 Return the exponential of NUMBER to 2 power.
 721 If optional argument PRECISION is non-nil, its value
 722 \(an integer\) is used as precision in float computations.
 723 */
 724       (number, precision))
 725 {
 726 #if defined HAVE_MPFR && defined WITH_MPFR
 727         Lisp_Object bfrnumber;
 728 #endif
 729 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 730         if (INTP(number))
 731                 return _ent_binop(ASE_BINARY_OP_POW,
 732                                   INT_T, make_int(2), INT_T, number);
 733 #endif
 734         if (INDEFP(number))
 735                 return _ent_binop(ASE_BINARY_OP_POW,
 736                                   INT_T, make_int(2), INDEF_T, number);
 737
 738 #if defined HAVE_MPFR && defined WITH_MPFR
 739         bfrnumber = Fcoerce_number(number, Qbigfr, Qnil);
 740         bigfr_set_prec(ent_scratch_bigfr,
 741                        internal_get_precision(precision));
 742
 743         bigfr_exp2(ent_scratch_bigfr, XBIGFR_DATA(bfrnumber));
 744         return make_bigfr_bfr(ent_scratch_bigfr);
 745 #endif
 746         /* fallback */
 747         if (NILP(precision));
 748         return Qnil;
 749 }
 750
 751 DEFUN("10^", Fexp10, 1, 2, 0,   /*
 752 Return the exponential of NUMBER to 10 power.
 753 If optional argument PRECISION is non-nil, its value
 754 \(an integer\) is used as precision in float computations.
 755 */
 756       (number, precision))
 757 {
 758 #if defined HAVE_MPFR && defined WITH_MPFR
 759         Lisp_Object bfrnumber;
 760 #endif
 761 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 762         if (INTP(number))
 763                 return _ent_binop(ASE_BINARY_OP_POW,
 764                                   INT_T, make_int(10), INT_T, number);
 765 #endif
 766         if (INDEFP(number))
 767                 return _ent_binop(ASE_BINARY_OP_POW,
 768                                   INT_T, make_int(10), INDEF_T, number);
 769
 770 #if defined HAVE_MPFR && defined WITH_MPFR
 771         bfrnumber = Fcoerce_number(number, Qbigfr, Qnil);
 772         bigfr_set_prec(ent_scratch_bigfr,
 773                        internal_get_precision(precision));
 774
 775         bigfr_exp10(ent_scratch_bigfr, XBIGFR_DATA(bfrnumber));
 776         return make_bigfr_bfr(ent_scratch_bigfr);
 777 #endif
 778         /* fallback */
 779         if (NILP(precision));
 780         return Qnil;
 781 }
 782
 783 #if defined(HAVE_FPFLOAT) || defined(HAVE_MPFR) && defined WITH_MPFR
 784 DEFUN("log", Flog, 1, 3, 0,     /*
 785 Return the natural logarithm of NUMBER.
 786 If second optional argument BASE is given, return the logarithm of
 787 NUMBER using that base.
 788 If third optional argument PRECISION is given, use its value
 789 (an integer) as precision.
 790 */
 791       (number, base, precision))
 792 {
 793 #if defined HAVE_MPFR && defined WITH_MPFR
 794         Lisp_Object bfrnumber;
 795
 796         if (!NILP(base)) {
 797                 Lisp_Object _logn, _logb;
 798                 _logn = Flog(number, Qnil, precision);
 799                 if (UNLIKELY(INDEFP(_logn))) {
 800                         return _logn;
 801                 }
 802                 _logb = Flog(base, Qnil, precision);
 803                 return ent_binop(ASE_BINARY_OP_QUO, _logn, _logb);
 804         }
 805
 806         if (INDEFP(number)) {
 807                 if (XINDEF_DATA(number) == POS_INFINITY) {
 808                         return number;
 809                 } else if (XINDEF_DATA(number) == NEG_INFINITY) {
 810                         return make_indef(NOT_A_NUMBER);
 811                 } else {
 812                         return number;
 813                 }
 814         }
 815
 816         bigfr_set_prec(ent_scratch_bigfr,
 817                        internal_get_precision(precision));
 818
 819         bfrnumber = Fcoerce_number(number, Qbigfr, Qnil);
 820         bigfr_log(ent_scratch_bigfr, XBIGFR_DATA(bfrnumber));
 821         return make_bigfr_bfr(ent_scratch_bigfr);
 822
 823 #else  /* !HAVE_MPFR */
 824         if (INDEFP(number)) {
 825                 goto indefcase;
 826         }
 827
 828         number = ent_lift(number, FLOAT_T, NULL);
 829
 830         if (FLOATP(number)) {
 831                 fpfloat d;
 832                 d = log(XFLOAT_DATA(number));
 833                 return make_float(d);
 834         } else if (INDEFP(number)) {
 835         indefcase:
 836                 if (XINDEF_DATA(number) == POS_INFINITY) {
 837                         return number;
 838                 } else if (XINDEF_DATA(number) == NEG_INFINITY) {
 839                         return make_indef(NOT_A_NUMBER);
 840                 } else {
 841                         return number;
 842                 }
 843         }
 844
 845         Fsignal(Qarith_error, list1(number));
 846         return Qnil;
 847
 848         if (NILP(precision));
 849 #endif  /* HAVE_MPFR */
 850 }
 851
 852 DEFUN("log10", Flog10, 1, 2, 0, /*
 853 Return the logarithm base 10 of NUMBER.
 854 If second optional argument PRECISION is given, use its value
 855 (an integer) as precision.
 856 */
 857       (number, precision))
 858 {
 859 #if defined HAVE_MPFR && defined WITH_MPFR
 860         Lisp_Object bfrnumber;
 861
 862         if (INDEFP(number)) {
 863                 if (XINDEF_DATA(number) == POS_INFINITY)
 864                         return number;
 865                 else if (XINDEF_DATA(number) == NEG_INFINITY)
 866                         return make_indef(NOT_A_NUMBER);
 867                 else
 868                         return number;
 869         }
 870
 871         bigfr_set_prec(ent_scratch_bigfr,
 872                        internal_get_precision(precision));
 873
 874         bfrnumber = Fcoerce_number(number, Qbigfr, Qnil);
 875         bigfr_log10(ent_scratch_bigfr, XBIGFR_DATA(bfrnumber));
 876         return make_bigfr_bfr(ent_scratch_bigfr);
 877
 878 #else  /* !HAVE_MPFR */
 879         if (INDEFP(number)) {
 880                 goto indefcase;
 881         }
 882
 883         number = ent_lift(number, FLOAT_T, NULL);
 884
 885         if (FLOATP(number)) {
 886                 fpfloat d;
 887                 d = log10(XFLOAT_DATA(number));
 888                 return make_float(d);
 889         } else if (INDEFP(number)) {
 890         indefcase:
 891                 if (XINDEF_DATA(number) == POS_INFINITY)
 892                         return number;
 893                 else if (XINDEF_DATA(number) == NEG_INFINITY)
 894                         return make_indef(NOT_A_NUMBER);
 895                 else
 896                         return number;
 897         }
 898
 899         Fsignal(Qarith_error, list1(number));
 900         return Qnil;
 901
 902         if (NILP(precision));
 903 #endif  /* HAVE_MPFR */
 904 }
 905
 906 #if defined HAVE_MPFR && defined WITH_MPFR
 907 DEFUN("log2", Flog2, 1, 2, 0,   /*
 908 Return the logarithm base 2 of NUMBER.
 909 If second optional argument PRECISION is given, use its value
 910 (an integer) as precision.
 911 */
 912       (number, precision))
 913 {
 914         Lisp_Object bfrnumber;
 915
 916         if (INDEFP(number)) {
 917                 if (XINDEF_DATA(number) == POS_INFINITY)
 918                         return number;
 919                 else if (XINDEF_DATA(number) == NEG_INFINITY)
 920                         return make_indef(NOT_A_NUMBER);
 921                 else
 922                         return number;
 923         }
 924
 925         bigfr_set_prec(ent_scratch_bigfr,
 926                        internal_get_precision(precision));
 927
 928         bfrnumber = Fcoerce_number(number, Qbigfr, Qnil);
 929         bigfr_log2(ent_scratch_bigfr, XBIGFR_DATA(bfrnumber));
 930         return make_bigfr_bfr(ent_scratch_bigfr);
 931 }
 932 #endif  /* HAVE_MPFR */
 933
 934
 935 DEFUN("sqrt", Fsqrt, 1, 2, 0,   /*
 936 Return the square root of NUMBER.
 937 If second optional argument PRECISION is given, use its value
 938 (an integer) as precision.
 939 */
 940       (number, precision))
 941 {
 942 #if defined(HAVE_MPFR) && defined WITH_MPFR ||  \
 943         defined(HAVE_MPC) && defined WITH_MPC ||        \
 944         defined(HAVE_PSEUC) && defined WITH_PSEUC
 945
 946         if (INDEFP(number)) {
 947                 if (XINDEF_DATA(number) == POS_INFINITY)
 948                         return number;
 949                 else if (XINDEF_DATA(number) == NEG_INFINITY)
 950                         return make_indef(COMPLEX_INFINITY);
 951                 else
 952                         return number;
 953         }
 954
 955         if (COMPARABLEP(number)) {
 956 #if defined HAVE_MPFR && defined WITH_MPFR
 957                 bigfr_set_prec(ent_scratch_bigfr,
 958                                internal_get_precision(precision));
 959
 960                 if (NATNUMP(number))
 961                         bigfr_sqrt_ui(ent_scratch_bigfr,
 962                                       (unsigned long)XUINT(number));
 963                 else if (BIGZP(number) &&
 964                          bigz_fits_ulong_p(XBIGZ_DATA(number)) &&
 965                          bigz_sign(XBIGZ_DATA(number)) >= 0) {
 966                         bigfr_sqrt_ui(ent_scratch_bigfr,
 967                                       (unsigned long)bigz_to_ulong(
 968                                               XBIGZ_DATA(number)));
 969                 } else if (!NILP(Fnonnegativep(number))) {
 970                         Lisp_Object bfrnumber;
 971                         bfrnumber = Fcoerce_number(number, Qbigfr, Qnil);
 972                         bigfr_sqrt(ent_scratch_bigfr, XBIGFR_DATA(bfrnumber));
 973                 } else {
 974 #if defined HAVE_MPC && defined WITH_MPC ||     \
 975         defined HAVE_PSEUC && defined WITH_PSEUC
 976                         Lisp_Object bcnumber;
 977                         bigc_set_prec(ent_scratch_bigc,
 978                                       internal_get_precision(precision));
 979                         bcnumber = Fcoerce_number(number, Qbigc, precision);
 980                         bigc_sqrt(ent_scratch_bigc, XBIGC_DATA(bcnumber));
 981                         return make_bigc_bc(ent_scratch_bigc);
 982 #else  /* !HAVE_MPC */
 983                         Lisp_Object bfrnumber;
 984                         bfrnumber = Fcoerce_number(number, Qbigfr, Qnil);
 985                         bigfr_sqrt(ent_scratch_bigfr, XBIGFR_DATA(bfrnumber));
 986 #endif  /* HAVE_MPC */
 987                 }
 988                 return make_bigfr_bfr(ent_scratch_bigfr);
 989 #endif  /* HAVE_MPFR */
 990 #if defined HAVE_MPC && defined WITH_MPC ||     \
 991         defined HAVE_PSEUC && defined WITH_PSEUC
 992         } else if (BIGCP(number) || BIGGP(number)) {
 993                 Lisp_Object bcnumber;
 994                 bigc_set_prec(ent_scratch_bigc,
 995                               internal_get_precision(precision));
 996
 997                 bcnumber = Fcoerce_number(number, Qbigc, precision);
 998                 bigc_sqrt(ent_scratch_bigc, XBIGC_DATA(bcnumber));
 999                 return make_bigc_bc(ent_scratch_bigc);
1000 #endif  /* HAVE_MPC */
1001         }
1002
1003         if (NILP(precision));
1004         return wrong_type_argument(Qnumberp, number);
1005
1006 #else  /* !HAVE_MPFR && !HAVE_MPC */
1007         if (INDEFP(number)) {
1008                 goto indefcase;
1009         }
1010
1011         number = ent_lift(number, FLOAT_T, NULL);
1012
1013         if (FLOATP(number)) {
1014                 fpfloat d;
1015                 d = sqrt(XFLOAT_DATA(number));
1016                 return make_float(d);
1017         } else if (INDEFP(number)) {
1018         indefcase:
1019                 if (XINDEF_DATA(number) == POS_INFINITY)
1020                         return number;
1021                 else if (XINDEF_DATA(number) == NEG_INFINITY)
1022                         return make_indef(COMPLEX_INFINITY);
1023                 else
1024                         return number;
1025         }
1026
1027         Fsignal(Qarith_error, list1(number));
1028         return Qnil;
1029
1030         if (NILP(precision));
1031 #endif  /* HAVE_MPFR */
1032 }
1033
1034 DEFUN("cube-root", Fcube_root, 1, 2, 0, /*
1035 Return the cube root of NUMBER.
1036 If second optional argument PRECISION is given, use its value
1037 (an integer) as precision.
1038 */
1039       (number, precision))
1040 {
1041 #if defined HAVE_MPFR && defined WITH_MPFR
1042         Lisp_Object bfrnumber;
1043
1044         if (INDEFP(number))
1045                 return number;
1046
1047         bigfr_set_prec(ent_scratch_bigfr,
1048                        internal_get_precision(precision));
1049
1050         bfrnumber = Fcoerce_number(number, Qbigfr, Qnil);
1051         bigfr_cbrt(ent_scratch_bigfr, XBIGFR_DATA(bfrnumber));
1052         return make_bigfr_bfr(ent_scratch_bigfr);
1053
1054 #else  /* !HAVE_MPFR */
1055         if (INDEFP(number)) {
1056                 goto indefcase;
1057         }
1058
1059         number = ent_lift(number, FLOAT_T, NULL);
1060
1061         if (FLOATP(number)) {
1062                 fpfloat d;
1063 #ifdef HAVE_CBRT
1064                 d = cbrt(XFLOAT_DATA(number));
1065 #else
1066                 d = XFLOAT_DATA(number);
1067                 if (d >= 0.0)
1068                         d = pow(d, 1.0 / 3.0);
1069                 else
1070                         d = -pow(-d, 1.0 / 3.0);
1071 #endif
1072                 return make_float(d);
1073         } else if (INDEFP(number)) {
1074         indefcase:
1075                 return number;
1076         }
1077
1078         Fsignal(Qarith_error, list1(number));
1079         return Qnil;
1080
1081         if (NILP(precision));
1082 #endif  /* HAVE_MPFR */
1083 }
1084 #endif  /* HAVE_FPFLOAT || MPFR */
1085
1086
1087 #if defined HAVE_MPFR && defined WITH_MPFR
1088 DEFUN("root", Froot, 2, 3, 0,   /*
1089 Return the RADIX-th root of NUMBER.
1090 If third optional argument PRECISION is given, use its value
1091 (an integer) as precision.
1092 */
1093       (number, radix, precision))
1094 {
1095         Lisp_Object bfrnumber;
1096
1097         if (!NATNUMP(radix)) {
1098                 dead_wrong_type_argument(Qnatnump, radix);
1099                 return Qnil;
1100         }
1101
1102         if (INDEFP(number)) {
1103                 if (XINDEF_DATA(number) == POS_INFINITY)
1104                         return number;
1105                 else if (XINDEF_DATA(number) == NEG_INFINITY)
1106                         return make_indef(COMPLEX_INFINITY);
1107                 else
1108                         return number;
1109         }
1110
1111         bigfr_set_prec(ent_scratch_bigfr,
1112                        internal_get_precision(precision));
1113
1114         bfrnumber = Fcoerce_number(number, Qbigfr, Qnil);
1115         bigfr_root(ent_scratch_bigfr, XBIGFR_DATA(bfrnumber), XUINT(radix));
1116         return make_bigfr_bfr(ent_scratch_bigfr);
1117 }
1118 #endif  /* HAVE_MPFR */
1119
1120 \f
1121 /* (Inverse) hyperbolic trig functions. */
1122 #if defined(HAVE_FPFLOAT) || defined(HAVE_MPFR) && defined WITH_MPFR
1123
1124 DEFUN("acosh", Facosh, 1, 2, 0, /*
1125 Return the inverse hyperbolic cosine of NUMBER.
1126 If optional argument PRECISION is non-nil, its value
1127 (an integer) is used as precision.
1128 */
1129       (number, precision))
1130 {
1131 #if defined HAVE_MPFR && defined WITH_MPFR
1132
1133         MPFR_TRIG_FUN(acosh);
1134
1135 #else  /* !HAVE_MPFR */
1136         if (INDEFP(number)) {
1137                 return make_indef(NOT_A_NUMBER);
1138         }
1139
1140         number = ent_lift(number, FLOAT_T, NULL);
1141
1142         if (FLOATP(number)) {
1143                 fpfloat d = XFLOAT_DATA(number);
1144 #ifdef HAVE_INVERSE_HYPERBOLIC
1145                 d = acosh(d);
1146 #else
1147                 d = log(d + sqrt(d * d - 1.0));
1148 #endif
1149                 return make_float(d);
1150         } else if (INDEFP(number)) {
1151                 return make_indef(NOT_A_NUMBER);
1152         }
1153
1154         Fsignal(Qarith_error, list1(number));
1155         return Qnil;
1156
1157         if (NILP(precision));
1158 #endif  /* HAVE_MPFR */
1159 }
1160
1161 DEFUN("asinh", Fasinh, 1, 2, 0, /*
1162 Return the inverse hyperbolic sine of NUMBER.
1163 If optional argument PRECISION is non-nil, its value
1164 (an integer) is used as precision.
1165 */
1166       (number, precision))
1167 {
1168 #if defined HAVE_MPFR && defined WITH_MPFR
1169
1170         MPFR_TRIG_FUN(asinh);
1171
1172 #else  /* !HAVE_MPFR */
1173         if (INDEFP(number)) {
1174                 return make_indef(NOT_A_NUMBER);
1175         }
1176
1177         number = ent_lift(number, FLOAT_T, NULL);
1178
1179         if (FLOATP(number)) {
1180                 fpfloat d = XFLOAT_DATA(number);
1181 #ifdef HAVE_INVERSE_HYPERBOLIC
1182                 d = acosh(d);
1183 #else
1184                 d = log(d + sqrt(d * d + 1.0));
1185 #endif
1186                 return make_float(d);
1187         } else if (INDEFP(number)) {
1188                 return make_indef(NOT_A_NUMBER);
1189         }
1190
1191         Fsignal(Qarith_error, list1(number));
1192         return Qnil;
1193
1194         if (NILP(precision));
1195 #endif  /* HAVE_MPFR */
1196 }
1197
1198 DEFUN("atanh", Fatanh, 1, 2, 0, /*
1199 Return the inverse hyperbolic tangent of NUMBER.
1200 If optional argument PRECISION is non-nil, its value
1201 (an integer) is used as precision.
1202 */
1203       (number, precision))
1204 {
1205 #if defined HAVE_MPFR && defined WITH_MPFR
1206
1207         MPFR_TRIG_FUN(atanh);
1208
1209 #else  /* !HAVE_MPFR */
1210         if (INDEFP(number)) {
1211                 return make_indef(NOT_A_NUMBER);
1212         }
1213
1214         number = ent_lift(number, FLOAT_T, NULL);
1215
1216         if (FLOATP(number)) {
1217                 fpfloat d = XFLOAT_DATA(number);
1218 #ifdef HAVE_INVERSE_HYPERBOLIC
1219                 d = atanh(d);
1220 #else
1221                 d = 0.5 * log((1.0 + d) / (1.0 - d));
1222 #endif
1223                 return make_float(d);
1224         } else if (INDEFP(number)) {
1225                 return make_indef(NOT_A_NUMBER);
1226         }
1227
1228         Fsignal(Qarith_error, list1(number));
1229         return Qnil;
1230
1231         if (NILP(precision));
1232 #endif  /* HAVE_MPFR */
1233 }
1234
1235 DEFUN("cosh", Fcosh, 1, 2, 0,   /*
1236 Return the hyperbolic cosine of NUMBER.
1237 If optional argument PRECISION is non-nil, its value
1238 (an integer) is used as precision.
1239 */
1240       (number, precision))
1241 {
1242 #if defined HAVE_MPFR && defined WITH_MPFR
1243
1244         MPFR_TRIG_FUN(cosh);
1245
1246 #else  /* !HAVE_MPFR */
1247         if (INDEFP(number)) {
1248                 return make_indef(NOT_A_NUMBER);
1249         }
1250
1251         number = ent_lift(number, FLOAT_T, NULL);
1252
1253         if (FLOATP(number)) {
1254                 fpfloat d;
1255                 d = cosh(XFLOAT_DATA(number));
1256                 return make_float(d);
1257         } else if (INDEFP(number)) {
1258                 return make_indef(NOT_A_NUMBER);
1259         }
1260
1261         Fsignal(Qarith_error, list1(number));
1262         return Qnil;
1263
1264         if (NILP(precision));
1265 #endif  /* HAVE_MPFR */
1266 }
1267
1268 DEFUN("sinh", Fsinh, 1, 2, 0,   /*
1269 Return the hyperbolic sine of NUMBER.
1270 If optional argument PRECISION is non-nil, its value
1271 (an integer) is used as precision.
1272 */
1273       (number, precision))
1274 {
1275 #if defined HAVE_MPFR && defined WITH_MPFR
1276
1277         MPFR_TRIG_FUN(sinh);
1278
1279 #else  /* !HAVE_MPFR */
1280         if (INDEFP(number)) {
1281                 return make_indef(NOT_A_NUMBER);
1282         }
1283
1284         number = ent_lift(number, FLOAT_T, NULL);
1285
1286         if (FLOATP(number)) {
1287                 fpfloat d;
1288                 d = sinh(XFLOAT_DATA(number));
1289                 return make_float(d);
1290         } else if (INDEFP(number)) {
1291                 return make_indef(NOT_A_NUMBER);
1292         }
1293
1294         Fsignal(Qarith_error, list1(number));
1295         return Qnil;
1296
1297         if (NILP(precision));
1298 #endif  /* HAVE_MFPR */
1299 }
1300
1301 DEFUN("tanh", Ftanh, 1, 2, 0,   /*
1302 Return the hyperbolic tangent of NUMBER.
1303 If optional argument PRECISION is non-nil, its value
1304 (an integer) is used as precision.
1305 */
1306       (number, precision))
1307 {
1308 #if defined HAVE_MPFR && defined WITH_MPFR
1309
1310         MPFR_TRIG_FUN(tanh);
1311
1312 #else  /* !HAVE_MPFR */
1313         if (INDEFP(number)) {
1314                 return make_indef(NOT_A_NUMBER);
1315         }
1316
1317         number = ent_lift(number, FLOAT_T, NULL);
1318
1319         if (FLOATP(number)) {
1320                 fpfloat d = XFLOAT_DATA(number);
1321                 d = tanh(d);
1322                 return make_float(d);
1323         } else if (INDEFP(number)) {
1324                 return make_indef(NOT_A_NUMBER);
1325         }
1326
1327         Fsignal(Qarith_error, list1(number));
1328         return Qnil;
1329
1330         if (NILP(precision));
1331 #endif  /* HAVE_MPFR */
1332 }
1333
1334 #if defined HAVE_MPFR && defined WITH_MPFR
1335
1336 DEFUN("sech", Fsech, 1, 2, 0,   /*
1337 Return the hyperbolic secant of NUMBER.
1338 If optional argument PRECISION is non-nil, its value
1339 (an integer) is used as precision.
1340 */
1341       (number, precision))
1342 {
1343         MPFR_TRIG_FUN(sech);
1344 }
1345
1346 DEFUN("csch", Fcsch, 1, 2, 0,   /*
1347 Return the hyperbolic cosecant of NUMBER.
1348 If optional argument PRECISION is non-nil, its value
1349 (an integer) is used as precision.
1350 */
1351       (number, precision))
1352 {
1353         MPFR_TRIG_FUN(csch);
1354 }
1355
1356 DEFUN("coth", Fcoth, 1, 2, 0,   /*
1357 Return the hyperbolic cotangent of NUMBER.
1358 If optional argument PRECISION is non-nil, its value
1359 (an integer) is used as precision.
1360 */
1361       (number, precision))
1362 {
1363         MPFR_TRIG_FUN(coth);
1364 }
1365 #endif  /* HAVE_MPFR */
1366
1367 #endif  /* HAVE_MPFR || HAVE_FPFLOAT (inverse trig functions) */
1368
1369 \f
1370 /* Rounding functions */
1371
1372 DEFUN("abs", Fabs, 1, 1, 0,     /*
1373 Return the absolute value of NUMBER.
1374 */
1375       (number))
1376 {
1377 #ifdef HAVE_FPFLOAT
1378         if (FLOATP(number)) {
1379                 return make_float(fabs(XFLOAT_DATA(number)));
1380         }
1381 #endif                          /* HAVE_FPFLOAT */
1382
1383         if (INTP(number)) {
1384 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1385                 /* The most negative Lisp int will overflow */
1386                 return (XINT(number) >= 0)
1387                         ? number : make_integer(-XINT(number));
1388 #else  /* !HAVE_MPZ */
1389                 return (XINT(number) >= 0) ? number : make_int(-XINT(number));
1390 #endif  /* HAVE_MPZ */
1391         }
1392
1393 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1394         if (BIGZP(number)) {
1395                 if (bigz_sign(XBIGZ_DATA(number)) >= 0)
1396                         return number;
1397
1398                 bigz_abs(ent_scratch_bigz, XBIGZ_DATA(number));
1399                 return make_bigz_bz(ent_scratch_bigz);
1400         }
1401 #endif  /* HAVE_MPZ */
1402
1403 #if defined HAVE_MPQ && defined WITH_GMP
1404         if (BIGQP(number)) {
1405                 if (bigq_sign(XBIGQ_DATA(number)) >= 0)
1406                         return number;
1407
1408                 bigq_abs(ent_scratch_bigq, XBIGQ_DATA(number));
1409                 return make_bigq_bq(ent_scratch_bigq);
1410         }
1411 #endif  /* HAVE_MPQ */
1412
1413 #if defined HAVE_MPF && defined WITH_GMP
1414         if (BIGFP(number)) {
1415                 if (bigf_sign(XBIGF_DATA (number)) >= 0)
1416                         return number;
1417
1418                 bigf_set_prec(ent_scratch_bigf, XBIGF_GET_PREC(number));
1419
1420                 bigf_abs(ent_scratch_bigf, XBIGF_DATA(number));
1421                 return make_bigf_bf(ent_scratch_bigf);
1422         }
1423 #endif  /* HAVE_MPF */
1424
1425 #if defined HAVE_MPFR && defined WITH_MPFR
1426         if (BIGFRP(number)) {
1427                 if (bigfr_sign(XBIGFR_DATA (number)) >= 0)
1428                         return number;
1429
1430                 bigfr_set_prec(ent_scratch_bigfr, XBIGFR_GET_PREC(number));
1431
1432                 bigfr_abs(ent_scratch_bigfr, XBIGFR_DATA(number));
1433                 return make_bigfr_bfr(ent_scratch_bigfr);
1434         }
1435 #endif  /* HAVE_MPFR */
1436
1437 #if defined(HAVE_PSEUG) && defined WITH_PSEUG && defined(HAVE_MPFR)
1438         if (BIGGP(number)) {
1439                 bigfr_set_prec(ent_scratch_bigfr,
1440                                internal_get_precision(Qnil));
1441
1442                 bigg_abs(ent_scratch_bigfr, XBIGG_DATA(number));
1443                 return make_bigfr_bfr(ent_scratch_bigfr);
1444         }
1445 #endif  /* HAVE_PSEUG && HAVE_MPFR */
1446
1447 #if defined HAVE_MPC && defined WITH_MPC ||     \
1448         defined HAVE_PSEUC && defined WITH_PSEUC
1449         if (BIGCP(number)) {
1450                 bigfr_set_prec(ent_scratch_bigfr, XBIGC_GET_PREC(number));
1451
1452                 if (bigc_nan_p(XBIGC_DATA(number)))
1453                         return make_indef(NOT_A_NUMBER);
1454                 else if (bigc_inf_p(XBIGC_DATA(number)))
1455                         return make_indef(POS_INFINITY);
1456                 else
1457                         bigc_abs(ent_scratch_bigfr, XBIGC_DATA(number));
1458
1459                 return make_bigfr_bfr(ent_scratch_bigfr);
1460         }
1461 #endif  /* HAVE_PSEUG */
1462
1463         if (INDEFP(number)) {
1464                 if (XINDEF_DATA(number) == POS_INFINITY)
1465                         return number;
1466                 else if (XINDEF_DATA(number) == NEG_INFINITY)
1467                         return make_indef(POS_INFINITY);
1468                 else
1469                         return number;
1470         }
1471
1472         return Fabs(wrong_type_argument(Qnumberp, number));
1473 }
1474
1475 #if defined(HAVE_FPFLOAT)
1476 /* fuck fuck fuck, I want this in number.el */
1477 DEFUN("float", Ffloat, 1, 1, 0, /*
1478 Return the floating point number numerically equal to NUMBER.
1479 */
1480       (number))
1481 {
1482         /* Just create the float in order of preference */
1483         return Fcoerce_number(number, Qfloat, Qnil);
1484 }
1485 #endif  /* HAVE_FPFLOAT */
1486
1487 #ifdef HAVE_FPFLOAT
1488 DEFUN("logb", Flogb, 1, 1, 0,   /*
1489 Return largest integer <= the base 2 log of the magnitude of NUMBER.
1490 This is the same as the exponent of a float.
1491 */
1492       (number))
1493 {
1494         fpfloat f = extract_float(number);
1495
1496         if (f == 0.0)
1497                 return make_int(EMACS_INT_MIN);
1498 #ifdef HAVE_LOGB
1499         {
1500                 fpfloat _lb = logb(f);
1501                 Lisp_Object val;
1502                 IN_FLOAT(val = make_int((EMACS_INT)_lb), "logb", number);
1503                 return val;
1504         }
1505 #else
1506 #ifdef HAVE_FREXP
1507         {
1508                 int exqp;
1509                 IN_FLOAT(frexp(f, &exqp), "logb", number);
1510                 return make_int(exqp - 1);
1511         }
1512 #else
1513         {
1514                 int i;
1515                 fpfloat d;
1516                 EMACS_INT val;
1517                 if (f < 0.0)
1518                         f = -f;
1519                 val = -1;
1520                 while (f < 0.5) {
1521                         for (i = 1, d = 0.5; d * d >= f; i += i)
1522                                 d *= d;
1523                         f /= d;
1524                         val -= i;
1525                 }
1526                 while (f >= 1.0) {
1527                         for (i = 1, d = 2.0; d * d <= f; i += i)
1528                                 d *= d;
1529                         f /= d;
1530                         val += i;
1531                 }
1532                 return make_int(val);
1533         }
1534 #endif                          /* ! HAVE_FREXP */
1535 #endif                          /* ! HAVE_LOGB */
1536 }
1537 #endif                          /* HAVE_FPFLOAT */
1538
1539 DEFUN("ceiling", Fceiling, 1, 1, 0,     /*
1540 Return the smallest integer no less than NUMBER.  (Round toward +inf.)
1541 */
1542       (number))
1543 {
1544 #ifdef HAVE_FPFLOAT
1545         if (FLOATP(number)) {
1546                 fpfloat d;
1547                 d = ceil(XFLOAT_DATA(number));
1548                 return (float_to_int(d, "ceiling", number, Qunbound));
1549         }
1550 #endif                          /* HAVE_FPFLOAT */
1551
1552 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1553         if (INTEGERP(number))
1554 #else  /* !HAVE_MPZ */
1555         if (INTP(number))
1556 #endif  /* HAVE_MPZ */
1557                 return number;
1558
1559 #if defined(HAVE_MPQ) && defined(HAVE_MPZ) && defined WITH_GMP
1560         if (BIGQP(number)) {
1561                 bigz_ceil(ent_scratch_bigz,
1562                           XBIGQ_NUMERATOR(number),
1563                           XBIGQ_DENOMINATOR(number));
1564                 return ent_mpz_downgrade_maybe(ent_scratch_bigz);
1565         }
1566 #endif
1567
1568 #if defined HAVE_MPF && defined WITH_GMP
1569         else if (BIGFP(number)) {
1570 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1571                 bigf_ceil(ent_scratch_bigf, XBIGF_DATA(number));
1572                 bigz_set_bigf(ent_scratch_bigz, ent_scratch_bigf);
1573                 return ent_mpz_downgrade_maybe(ent_scratch_bigz);
1574 #else  /* !HAVE_MPZ */
1575                 bigf_ceil(ent_scratch_bigf, XBIGF_DATA(number));
1576                 return make_int((EMACS_INT)bigf_to_long(ent_scratch_bigf));
1577 #endif  /* HAVE_MPZ */
1578         }
1579 #endif  /* HAVE_MPF */
1580
1581 #if defined HAVE_MPFR && defined WITH_MPFR
1582         else if (BIGFRP(number)) {
1583 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1584                 bigfr_ceil(ent_scratch_bigfr, XBIGFR_DATA(number));
1585                 bigz_set_bigfr(ent_scratch_bigz, ent_scratch_bigfr);
1586                 return ent_mpz_downgrade_maybe(ent_scratch_bigz);
1587 #else  /* !HAVE_MPZ */
1588                 bigfr_ceil(ent_scratch_bigfr, XBIGFR_DATA(number));
1589                 return make_int((EMACS_INT)bigfr_to_long(ent_scratch_bigfr));
1590 #endif  /* HAVE_MPZ */
1591         }
1592 #endif  /* HAVE_MPFR */
1593
1594         if (INDEFP(number))
1595                 return number;
1596
1597 #if defined HAVE_MPC && defined WITH_MPC ||     \
1598         defined HAVE_PSEUC && defined WITH_PSEUC ||     \
1599         defined HAVE_PSEUG && defined WITH_PSEUG
1600         return Fceiling(wrong_type_argument(Qcomparablep, number));
1601 #else  /* !HAVE_MPC */
1602         return Fceiling(wrong_type_argument(Qnumberp, number));
1603 #endif  /* HAVE_MPC */
1604 }
1605
1606 DEFUN("floor", Ffloor, 1, 2, 0, /*
1607 Return the largest integer no greater than NUMBER.  (Round towards -inf.)
1608 With optional second argument DIVISOR, return the largest integer no
1609 greater than NUMBER/DIVISOR.
1610 */
1611       (number, divisor))
1612 {
1613         ase_object_type_t ntquo;
1614         Lisp_Object quo;
1615
1616         CHECK_COMPARABLE(number);
1617         if (NILP(divisor)) {
1618                 return Ffloor(number, make_int(1L));
1619
1620         }
1621
1622         /* !NILP(divisor) */
1623
1624         CHECK_COMPARABLE(divisor);
1625
1626         if (INTEGERP(number) && INTEGERP(divisor)) {
1627 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1628                 /* this is the optimised version, since
1629                  * bigz_floor always takes two arguments
1630                  */
1631                 number = ent_lift(number, BIGZ_T, NULL);
1632                 divisor = ent_lift(divisor, BIGZ_T, NULL);
1633
1634                 bigz_floor(ent_scratch_bigz,
1635                            XBIGZ_DATA(number),
1636                            XBIGZ_DATA(divisor));
1637                 return ent_mpz_downgrade_maybe(ent_scratch_bigz);
1638 #else
1639                 number = ent_lift(number, FLOAT_T, NULL);
1640                 divisor = ent_lift(divisor, FLOAT_T, NULL);
1641 #endif
1642         }
1643
1644         quo = ent_binop(ASE_BINARY_OP_QUO, number, divisor);
1645         ntquo = ase_optable_index(quo);
1646
1647         switch (ntquo) {
1648         case INT_T:             /* trivial */
1649         case BIGZ_T:
1650         case INDEF_T:
1651                 return quo;
1652                 break;
1653         case FLOAT_T: {
1654                 fpfloat d;
1655                 IN_FLOAT((d = floor(XFLOAT_DATA(quo))), "floor", quo);
1656                 return (float_to_int(d, "floor", quo, Qunbound));
1657         }
1658         case BIGQ_T:
1659 #if defined(HAVE_MPQ) && defined(HAVE_MPZ) && defined WITH_GMP
1660                 bigz_floor(ent_scratch_bigz,
1661                            XBIGQ_NUMERATOR(quo), XBIGQ_DENOMINATOR(quo));
1662                 return ent_mpz_downgrade_maybe(ent_scratch_bigz);
1663                 break;
1664 #else
1665                 return quo;
1666 #endif
1667         case BIGF_T:
1668 #if defined HAVE_MPF && defined WITH_GMP
1669                 bigf_floor(ent_scratch_bigf, XBIGF_DATA(quo));
1670 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1671                 bigz_set_bigf(ent_scratch_bigz, ent_scratch_bigf);
1672                 return ent_mpz_downgrade_maybe(ent_scratch_bigz);
1673 #else  /* !HAVE_MPZ */
1674                 return make_int(
1675                         (EMACS_INT)bigf_to_long(ent_scratch_bigf));
1676 #endif  /* HAVE_MPZ */
1677                 break;
1678 #endif  /* HAVE_MPF */
1679
1680         case BIGFR_T:
1681 #if defined HAVE_MPFR && defined WITH_MPFR
1682                 bigfr_floor(ent_scratch_bigfr, XBIGFR_DATA(quo));
1683 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1684                 bigz_set_bigfr(ent_scratch_bigz, ent_scratch_bigfr);
1685                 return ent_mpz_downgrade_maybe(ent_scratch_bigz);
1686 #else  /* !HAVE_MPZ */
1687                 return make_int(
1688                         (EMACS_INT)bigfr_to_long(ent_scratch_bigfr));
1689 #endif  /* HAVE_MPZ */
1690                 break;
1691 #endif  /* HAVE_MPFR */
1692
1693         default:
1694                 return quo;
1695         }
1696
1697         return Fsignal(Qdomain_error, Qnil);
1698 }
1699
1700 DEFUN("round", Fround, 1, 1, 0, /*
1701 Return the nearest integer to NUMBER.
1702
1703 NUMBER has to have an archimedian valuation, #'round returns the
1704 integer z for which | number - z | is minimal.
1705 */
1706       (number))
1707 {
1708 #ifdef HAVE_FPFLOAT
1709         if (FLOATP(number)) {
1710                 fpfloat d;
1711                 /* Screw the prevailing rounding mode.  */
1712                 d = emacs_rint(XFLOAT_DATA(number));
1713                 return (float_to_int(d, "round", number, Qunbound));
1714         }
1715 #endif                          /* HAVE_FPFLOAT */
1716
1717 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1718         if (INTEGERP(number))
1719 #else  /* !HAVE_MPZ */
1720         if (INTP(number))
1721 #endif  /* HAVE_MPZ */
1722                 return number;
1723
1724 #if defined(HAVE_MPQ) && defined(HAVE_MPZ) && defined WITH_GMP
1725         else if (BIGQP(number)) {
1726                 /* first off, let's create the division, remainder as well */
1727                 /* fuck ugly? */
1728                 mpz_tdiv_qr(ent_scratch_bigz,
1729                             bigq_numerator(ent_scratch_bigq),
1730                             XBIGQ_NUMERATOR(number),
1731                             XBIGQ_DENOMINATOR(number));
1732
1733                 /* <- denom(number) * 2 */
1734                 mpz_mul_2exp(bigq_numerator(ent_scratch_bigq),
1735                              bigq_numerator(ent_scratch_bigq), 1);
1736
1737                 /* check if we had to add one */
1738                 if (mpz_cmpabs(bigq_numerator(ent_scratch_bigq),
1739                                XBIGQ_DENOMINATOR(number)) >= 0) {
1740                         /* >= ceil(denom(number) / 2) */
1741                         if (mpz_sgn(bigq_numerator(ent_scratch_bigq)) > 0) {
1742                                 mpz_add_ui(ent_scratch_bigz,
1743                                            ent_scratch_bigz, 1UL);
1744                         } else {
1745                                 mpz_sub_ui(ent_scratch_bigz,
1746                                            ent_scratch_bigz, 1UL);
1747                         }
1748                 }
1749                 return ent_mpz_downgrade_maybe(ent_scratch_bigz);
1750         }
1751 #endif  /* HAVE_MPQ && HAVE_MPZ */
1752
1753 #if defined HAVE_MPF && defined WITH_GMP
1754         else if (BIGFP(number)) {
1755                 warn_when_safe(Qbigf, Qnotice,
1756                                "rounding number of type 'bigf (mpf-floats)"
1757                                "not yet implemented");
1758                 return number;
1759         }
1760 #endif  /* HAVE_MPF */
1761
1762 #if defined HAVE_MPFR && defined WITH_MPFR
1763         else if (BIGFRP(number)) {
1764 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1765                 bigfr_rint(ent_scratch_bigfr, XBIGFR_DATA(number));
1766                 bigz_set_bigfr(ent_scratch_bigz, ent_scratch_bigfr);
1767                 return ent_mpz_downgrade_maybe(ent_scratch_bigz);
1768 #else  /* !HAVE_MPZ */
1769                 bigfr_rint(ent_scratch_bigfr, XBIGFR_DATA(number));
1770                 return make_int((EMACS_INT)bigfr_to_long(ent_scratch_bigfr));
1771 #endif  /* HAVE_MPZ */
1772         }
1773 #endif  /* HAVE_MPFR */
1774
1775         else if (INDEFP(number))
1776                 return number;
1777
1778 #if defined HAVE_MPC && defined WITH_MPC ||     \
1779         defined HAVE_PSEUC && defined WITH_PSEUC ||     \
1780         defined HAVE_PSEUG && defined WITH_PSEUG
1781         return Fround(wrong_type_argument(Qcomparablep, number));
1782 #else  /* !HAVE_MPC */
1783         return Fround(wrong_type_argument(Qnumberp, number));
1784 #endif  /* HAVE_MPC */
1785 }
1786
1787 DEFUN("truncate", Ftruncate, 1, 1, 0,   /*
1788 Truncate a floating point number to an integer.
1789 Rounds the value toward zero.
1790 */
1791       (number))
1792 {
1793 #ifdef HAVE_FPFLOAT
1794         if (FLOATP(number))
1795                 return float_to_int(XFLOAT_DATA(number), "truncate", number,
1796                                     Qunbound);
1797 #endif                          /* HAVE_FPFLOAT */
1798
1799 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1800         if (INTEGERP(number))
1801 #else  /* !HAVE_MPZ */
1802         if (INTP(number))
1803 #endif  /* HAVE_MPZ */
1804                 return number;
1805
1806 #if defined HAVE_MPQ && defined WITH_GMP
1807         else if (BIGQP(number)) {
1808                 bigz_div(ent_scratch_bigz,
1809                          XBIGQ_NUMERATOR(number),
1810                          XBIGQ_DENOMINATOR(number));
1811                 return ent_mpz_downgrade_maybe(ent_scratch_bigz);
1812         }
1813 #endif
1814
1815 #if defined HAVE_MPF && defined WITH_GMP
1816         else if (BIGFP(number)) {
1817 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1818                 bigf_trunc(ent_scratch_bigf, XBIGF_DATA(number));
1819                 bigz_set_bigf(ent_scratch_bigz, ent_scratch_bigf);
1820                 return ent_mpz_downgrade_maybe(ent_scratch_bigz);
1821 #else  /* !HAVE_MPZ */
1822                 bigf_trunc(ent_scratch_bigf, XBIGF_DATA(number));
1823                 return make_int((EMACS_INT)bigf_to_long(ent_scratch_bigf));
1824 #endif  /* HAVE_MPZ */
1825         }
1826 #endif  /* HAVE_MPF */
1827
1828 #if defined HAVE_MPFR && defined WITH_MPFR
1829         else if (BIGFRP(number)) {
1830 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1831                 bigfr_trunc(ent_scratch_bigfr, XBIGFR_DATA(number));
1832                 bigz_set_bigfr(ent_scratch_bigz, ent_scratch_bigfr);
1833                 return ent_mpz_downgrade_maybe(ent_scratch_bigz);
1834 #else  /* !HAVE_MPZ */
1835                 bigfr_trunc(ent_scratch_bigfr, XBIGFR_DATA(number));
1836                 return make_int((EMACS_INT)bigfr_to_long(ent_scratch_bigfr));
1837 #endif  /* HAVE_MPZ */
1838         }
1839 #endif  /* HAVE_MPFR */
1840
1841         else if (INDEFP(number))
1842                 return number;
1843
1844 #if defined HAVE_MPC && defined WITH_MPC ||     \
1845         defined HAVE_PSEUC && defined WITH_PSEUC ||     \
1846         defined HAVE_PSEUG && defined WITH_PSEUG
1847         return Ftruncate(wrong_type_argument(Qcomparablep, number));
1848 #else  /* !HAVE_MPC */
1849         return Ftruncate(wrong_type_argument(Qnumberp, number));
1850 #endif  /* HAVE_MPC */
1851 }
1852
1853 DEFUN("almost=", Falmost_eq, 2, 3, 0,   /*
1854 Return t if NUMBER1 is almost equal to NUMBER2.
1855
1856 Optional argument THRES can be used to specify the threshold,
1857 float-epsilon by default.
1858 */
1859       (number1, number2, thres))
1860 {
1861 #if defined HAVE_FPFLOAT
1862         if (NILP(thres)) {
1863                 thres = Vfloat_epsilon;
1864         }
1865         CHECK_FLOAT(thres);
1866
1867         if (FLOATP(number1) && FLOATP(number2)) {
1868                 fpfloat n1 = XFLOAT_DATA(number1);
1869                 fpfloat n2 = XFLOAT_DATA(number2);
1870                 fpfloat thr = XFLOAT_DATA(thres);
1871                 fpfloat d;
1872                 if (n1 >= n2) {
1873                         d = n1 - n2;
1874                 } else {
1875                         d = n2 - n1;
1876                 }
1877                 return d < thr ? Qt : Qnil;
1878         }
1879 #endif  /* HAVE_FPFLOAT */
1880         return ent_binrel(ASE_BINARY_REL_EQUALP, number1, number2) ? Qt : Qnil;
1881 }
1882
1883 DEFUN("almost/=", Falmost_neq, 2, 3, 0, /*
1884 Return t if NUMBER1 is clearly different from NUMBER2.
1885
1886 Optional argument THRES can be used to specify the threshold,
1887 float-epsilon by default.
1888 */
1889       (number1, number2, thres))
1890 {
1891 #if defined HAVE_FPFLOAT
1892         if (NILP(thres)) {
1893                 thres = Vfloat_epsilon;
1894         }
1895         CHECK_FLOAT(thres);
1896
1897         if (FLOATP(number1) && FLOATP(number2)) {
1898                 fpfloat n1 = XFLOAT_DATA(number1);
1899                 fpfloat n2 = XFLOAT_DATA(number2);
1900                 fpfloat thr = XFLOAT_DATA(thres);
1901                 fpfloat d;
1902                 if (n1 >= n2) {
1903                         d = n1 - n2;
1904                 } else {
1905                         d = n2 - n1;
1906                 }
1907                 return d < thr ? Qnil : Qt;
1908         }
1909 #endif  /* HAVE_FPFLOAT */
1910         return ent_binrel(ASE_BINARY_REL_NEQP, number1, number2) ? Qt : Qnil;
1911 }
1912
1913 \f
1914 /* misc complex functions */
1915 DEFUN("conjugate", Fconjugate, 1, 1, 0, /*
1916 Return the \(canonical\) conjugate of NUMBER.
1917 If NUMBER is a comparable, just return NUMBER.
1918 */
1919       (number))
1920 {
1921         if (COMPARABLEP(number)) {
1922                 return number;
1923 #if defined HAVE_PSEUG && defined WITH_PSEUG
1924         } else if (BIGGP(number)) {
1925                 bigg_conj(ent_scratch_bigg, XBIGG_DATA(number));
1926                 return make_bigg_bg(ent_scratch_bigg);
1927 #endif
1928 #if defined HAVE_MPC && defined WITH_MPC ||     \
1929         defined HAVE_PSEUC && defined WITH_PSEUC
1930         } else if (BIGCP(number)) {
1931                 bigc_set_prec(ent_scratch_bigc, XBIGC_GET_PREC(number));
1932                 bigc_conj(ent_scratch_bigc, XBIGC_DATA(number));
1933                 return make_bigc_bc(ent_scratch_bigc);
1934 #endif
1935 #if defined HAVE_QUATERN && defined WITH_QUATERN
1936         } else if (QUATERNP(number)) {
1937                 quatern_conj(ent_scratch_quatern, XQUATERN_DATA(number));
1938                 return make_quatern_qu(ent_scratch_quatern);
1939 #endif
1940         } else if (INDEFP(number)) {
1941                 return number;
1942         }
1943
1944         /* what should the rest do? */
1945         return Fconjugate(wrong_type_argument(Qnumberp, number));
1946 }
1947
1948 DEFUN("canonical-norm", Fcanonical_norm, 1, 1, 0,       /*
1949 Return the canonical norm of NUMBER.
1950 */
1951       (number))
1952 {
1953         if (INDEFP(number)) {
1954                 if (INFINITYP(number))
1955                         return make_indef(POS_INFINITY);
1956                 else
1957                         return make_indef(NOT_A_NUMBER);
1958         } else if (COMPARABLEP(number)) {
1959                 return Fabs(number);
1960 #if defined HAVE_PSEUG && defined WITH_PSEUG
1961         } else if (BIGGP(number)) {
1962                 bigg_norm(ent_scratch_bigz, XBIGG_DATA(number));
1963                 return make_bigz_bz(ent_scratch_bigz);
1964 #endif
1965 #if defined HAVE_MPC && defined WITH_MPC ||     \
1966         defined HAVE_PSEUC && defined WITH_PSEUC
1967         } else if (BIGCP(number)) {
1968                 bigfr_set_prec(ent_scratch_bigfr, XBIGC_GET_PREC(number));
1969                 bigc_norm(ent_scratch_bigfr, XBIGC_DATA(number));
1970                 return make_bigfr_bfr(ent_scratch_bigfr);
1971 #endif
1972 #if defined HAVE_QUATERN && defined WITH_QUATERN
1973         } else if (QUATERNP(number)) {
1974                 quatern_norm(ent_scratch_bigz, XQUATERN_DATA(number));
1975                 return make_bigz_bz(ent_scratch_bigz);
1976 #endif
1977         }
1978
1979         /* what should the rest do? */
1980         return Fcanonical_norm(wrong_type_argument(Qnumberp, number));
1981 }
1982
1983 DEFUN("real-part", Freal_part, 1, 1, 0, /*
1984 Return the real part of NUMBER.
1985 */
1986       (number))
1987 {
1988         if (INDEFP(number)) {
1989                 if (COMPARABLE_INDEF_P(number))
1990                         return number;
1991                 else if (INFINITYP(number))
1992                         return make_indef(POS_INFINITY);
1993                 else
1994                         return make_indef(NOT_A_NUMBER);
1995         } else if (COMPARABLEP(number)) {
1996                 return number;
1997 #if defined HAVE_PSEUG && defined WITH_PSEUG
1998         } else if (BIGGP(number)) {
1999                 return make_bigz_bz(bigg_re(XBIGG_DATA(number)));
2000 #endif
2001 #if defined HAVE_MPC && defined WITH_MPC ||     \
2002         defined HAVE_PSEUC && defined WITH_PSEUC
2003         } else if (BIGCP(number)) {
2004                 return make_bigfr_bfr(bigc_re(XBIGC_DATA(number)));
2005 #endif
2006         }
2007
2008         /* what should the rest do? */
2009         return Freal_part(wrong_type_argument(Qnumberp, number));
2010 }
2011
2012 DEFUN("imaginary-part", Fimaginary_part, 1, 1, 0,       /*
2013 Return the imaginary part of NUMBER.
2014 If NUMBER is a comparable, 0 is returned.
2015 */
2016       (number))
2017 {
2018         if (INDEFP(number)) {
2019                 if (COMPARABLE_INDEF_P(number))
2020                         return Qzero;
2021                 else if (INFINITYP(number))
2022                         return make_indef(POS_INFINITY);
2023                 else
2024                         return make_indef(NOT_A_NUMBER);
2025         } else if (RATIONALP(number)) {
2026                 return make_int(0);
2027 #if defined HAVE_MPFR && defined WITH_MPFR
2028         } else if (REALP(number)) {
2029                 return make_bigfr(0.0, 0UL);
2030 #endif
2031 #if defined HAVE_PSEUG && defined WITH_PSEUG
2032         } else if (BIGGP(number)) {
2033                 return make_bigz_bz(bigg_im(XBIGG_DATA(number)));
2034 #endif
2035 #if defined HAVE_MPC && defined WITH_MPC ||     \
2036         defined HAVE_PSEUC && defined WITH_PSEUC
2037         } else if (BIGCP(number)) {
2038                 return make_bigfr_bfr(bigc_im(XBIGC_DATA(number)));
2039 #endif
2040         }
2041
2042         /* what should the rest do? */
2043         return Fimaginary_part(wrong_type_argument(Qnumberp, number));
2044 }
2045
2046 \f
2047 /* Float-rounding functions. */
2048 #if defined(HAVE_FPFLOAT) || defined(HAVE_MPFR) && defined WITH_MPFR || \
2049         defined(HAVE_MPF) && defined WITH_GMP
2050
2051 DEFUN("fceiling", Ffceiling, 1, 1, 0,   /*
2052 Return the smallest integer no less than NUMBER, as a float.
2053 \(Round toward +inf.\)
2054 */
2055       (number))
2056 {
2057 #if defined HAVE_MPF && defined WITH_GMP
2058         if (BIGFP(number)) {
2059                 bigf_set_prec(ent_scratch_bigf, XBIGF_GET_PREC(number));
2060
2061                 bigf_ceil(ent_scratch_bigf, XBIGF_DATA(number));
2062                 return make_bigf_bf(ent_scratch_bigf);
2063         }
2064 #endif  /* HAVE_MPF */
2065
2066 #if defined HAVE_MPFR && defined WITH_MPFR
2067         if (BIGFRP(number)) {
2068                 bigfr_set_prec(ent_scratch_bigfr, XBIGFR_GET_PREC(number));
2069
2070                 bigfr_ceil(ent_scratch_bigfr, XBIGFR_DATA(number));
2071                 return make_bigfr_bfr(ent_scratch_bigfr);
2072         }
2073 #endif  /* HAVE_MPFR */
2074
2075         if (INDEFP(number))
2076                 return number;
2077
2078         number = ent_lift(number, FLOAT_T, NULL);
2079
2080         if (FLOATP(number))
2081                 return make_float(ceil(XFLOAT_DATA(number)));
2082         else
2083                 return number;
2084 }
2085
2086 DEFUN("ffloor", Fffloor, 1, 1, 0,       /*
2087 Return the largest integer no greater than NUMBER, as a float.
2088 \(Round towards -inf.\)
2089 */
2090       (number))
2091 {
2092 #if defined HAVE_MPF && defined WITH_GMP
2093         if (BIGFP(number)) {
2094                 bigf_set_prec(ent_scratch_bigf, XBIGF_GET_PREC(number));
2095
2096                 bigf_floor(ent_scratch_bigf, XBIGF_DATA(number));
2097                 return make_bigf_bf(ent_scratch_bigf);
2098         }
2099 #endif  /* HAVE_MPF */
2100
2101 #if defined HAVE_MPFR && defined WITH_MPFR
2102         if (BIGFRP(number)) {
2103                 bigfr_set_prec(ent_scratch_bigfr, XBIGFR_GET_PREC(number));
2104
2105                 bigfr_floor(ent_scratch_bigfr, XBIGFR_DATA(number));
2106                 return make_bigfr_bfr(ent_scratch_bigfr);
2107         }
2108 #endif  /* HAVE_MPFR */
2109
2110         if (INDEFP(number))
2111                 return number;
2112
2113         number = ent_lift(number, FLOAT_T, NULL);
2114
2115         if (FLOATP(number))
2116                 return make_float(floor(XFLOAT_DATA(number)));
2117         else
2118                 return number;
2119 }
2120
2121 DEFUN("fround", Ffround, 1, 1, 0,       /*
2122 Return the nearest integer to NUMBER, as a float.
2123 */
2124       (number))
2125 {
2126 #if defined HAVE_MPF && defined WITH_GMP
2127         if (BIGFP(number)) {
2128                 warn_when_safe(Qbigf, Qnotice,
2129                                "rounding number of type 'bigf (mpf-floats)"
2130                                "not yet implemented");
2131                 return number;
2132         }
2133 #endif  /* HAVE_MPF */
2134
2135 #if defined HAVE_MPFR && defined WITH_MPFR
2136         if (BIGFRP(number)) {
2137                 bigfr_set_prec(ent_scratch_bigfr, XBIGFR_GET_PREC(number));
2138
2139                 bigfr_rint(ent_scratch_bigfr, XBIGFR_DATA(number));
2140                 return make_bigfr_bfr(ent_scratch_bigfr);
2141         }
2142 #endif  /* HAVE_MPFR */
2143
2144         if (INDEFP(number))
2145                 return number;
2146
2147         number = ent_lift(number, FLOAT_T, NULL);
2148
2149         if (FLOATP(number))
2150                 return make_float(emacs_rint(XFLOAT_DATA(number)));
2151         else
2152                 return number;
2153 }
2154
2155 DEFUN("ftruncate", Fftruncate, 1, 1, 0, /*
2156 Truncate a floating point number to an integral float value.
2157 Rounds the value toward zero.
2158 */
2159       (number))
2160 {
2161         fpfloat d;
2162 #if defined HAVE_MPF && defined WITH_GMP
2163         if (BIGFP(number)) {
2164                 bigf_set_prec(ent_scratch_bigf, XBIGF_GET_PREC(number));
2165
2166                 bigf_trunc(ent_scratch_bigf, XBIGF_DATA(number));
2167                 return make_bigf_bf(ent_scratch_bigf);
2168         }
2169 #endif  /* HAVE_MPF */
2170
2171 #if defined HAVE_MPFR && defined WITH_MPFR
2172         if (BIGFRP(number)) {
2173                 bigfr_set_prec(ent_scratch_bigfr, XBIGFR_GET_PREC(number));
2174
2175                 bigfr_trunc(ent_scratch_bigfr, XBIGFR_DATA(number));
2176                 return make_bigfr_bfr(ent_scratch_bigfr);
2177         }
2178 #endif  /* HAVE_MPFR */
2179
2180         if (INDEFP(number))
2181                 return number;
2182
2183         number = ent_lift(number, FLOAT_T, NULL);
2184
2185         if (FLOATP(number)) {
2186                 d = XFLOAT_DATA(number);
2187                 if (d >= 0.0)
2188                         d = floor(d);
2189                 else
2190                         d = ceil(d);
2191                 return make_float(d);
2192         } else {
2193                 return number;
2194         }
2195 }
2196 #endif  /* HAVE_MPF(R) || HAVE_FPFLOAT (float-rounding functions) */
2197
2198 \f
2199 #ifdef HAVE_FPFLOAT
2200 #ifdef FLOAT_CATCH_SIGILL
2201 static SIGTYPE float_error(int signo)
2202 {
2203         if (!in_float)
2204                 fatal_error_signal(signo);
2205
2206         EMACS_REESTABLISH_SIGNAL(signo, arith_error);
2207         EMACS_UNBLOCK_SIGNAL(signo);
2208
2209         in_float = 0;
2210
2211         /* Was Fsignal(), but it just doesn't make sense for an error
2212            occurring inside a signal handler to be restartable, considering
2213            that anything could happen when the error is signaled and trapped
2214            and considering the asynchronous nature of signal handlers. */
2215         signal_error(Qarith_error, list1(float_error_arg));
2216 }
2217
2218 /* Another idea was to replace the library function `infnan'
2219    where SIGILL is signaled.  */
2220
2221 #endif                          /* FLOAT_CATCH_SIGILL */
2222
2223 /* In C++, it is impossible to determine what type matherr expects
2224    without some more configure magic.
2225    We shouldn't be using matherr anyways - it's a non-standard SYSVism. */
2226 #if defined (HAVE_MATHERR) && !defined(__cplusplus)
2227 int matherr(struct exception *x)
2228 {
2229         Lisp_Object args;
2230         if (!in_float)
2231                 /* Not called from emacs-lisp float routines; do the default thing. */
2232                 return 0;
2233
2234         /* if (!strcmp (x->name, "pow")) x->name = "expt"; */
2235
2236         args = Fcons(build_string(x->name),
2237                      Fcons(make_float(x->arg1), ((in_float == 2)
2238                                                  ? Fcons(make_float(x->arg2),
2239                                                          Qnil)
2240                                                  : Qnil)));
2241         switch (x->type) {
2242         case DOMAIN:
2243                 Fsignal(Qdomain_error, args);
2244                 break;
2245         case SING:
2246                 Fsignal(Qsingularity_error, args);
2247                 break;
2248         case OVERFLOW:
2249                 Fsignal(Qoverflow_error, args);
2250                 break;
2251         case UNDERFLOW:
2252                 Fsignal(Qunderflow_error, args);
2253                 break;
2254         default:
2255                 Fsignal(Qarith_error, args);
2256                 break;
2257         }
2258         return 1;               /* don't set errno or print a message */
2259 }
2260 #endif                          /* HAVE_MATHERR */
2261 #endif                          /* HAVE_FPFLOAT */
2262 \f
2263 void init_floatfns_very_early(void)
2264 {
2265 #ifdef HAVE_FPFLOAT
2266 # ifdef FLOAT_CATCH_SIGILL
2267         signal(SIGILL, float_error);
2268 # endif
2269         in_float = 0;
2270 #endif                          /* HAVE_FPFLOAT */
2271 }
2272
2273 void syms_of_floatfns(void)
2274 {
2275
2276         /* Trig functions.  */
2277
2278 #if defined(HAVE_FPFLOAT) || defined HAVE_MPFR && defined WITH_MPFR
2279         DEFSUBR(Facos);
2280         DEFSUBR(Fasin);
2281         DEFSUBR(Fatan);
2282         DEFSUBR(Fcos);
2283         DEFSUBR(Fsin);
2284         DEFSUBR(Ftan);
2285 #endif  /* HAVE_FPFLOAT || HAVE_MPFR*/
2286 #if defined HAVE_MPFR && defined WITH_MPFR
2287         DEFSUBR(Fsec);
2288         DEFSUBR(Fcsc);
2289         DEFSUBR(Fcot);
2290 #endif
2291
2292         /* Bessel functions */
2293
2294 #if 0
2295         DEFSUBR(Fbessel_y0);
2296         DEFSUBR(Fbessel_y1);
2297         DEFSUBR(Fbessel_yn);
2298         DEFSUBR(Fbessel_j0);
2299         DEFSUBR(Fbessel_j1);
2300         DEFSUBR(Fbessel_jn);
2301 #endif                          /* 0 */
2302
2303         /* Error functions. */
2304
2305 #if 1
2306 #if defined(HAVE_FPFLOAT) || defined(HAVE_MPFR) && defined WITH_MPFR
2307         DEFSUBR(Ferf);
2308         DEFSUBR(Ferfc);
2309         DEFSUBR(Flog_gamma);
2310 #endif
2311 #endif                          /* 0 */
2312
2313         /* Root and Log functions. */
2314
2315 #if defined(HAVE_FPFLOAT) || defined(HAVE_MPFR) && defined WITH_MPFR
2316         DEFSUBR(Fexp);
2317 #endif  /* HAVE_FPFLOAT || HAVE_MPFR */
2318         DEFSUBR(Fexp2);
2319         DEFSUBR(Fexp10);
2320 #if 0
2321         DEFSUBR(Fexpt);
2322 #endif
2323 #if defined(HAVE_FPFLOAT) || defined(HAVE_MPFR) && defined WITH_MPFR
2324         DEFSUBR(Flog);
2325 #if defined HAVE_MPFR && defined WITH_MPFR
2326         DEFSUBR(Flog2);
2327 #endif  /* HAVE_MPFR */
2328         DEFSUBR(Flog10);
2329         DEFSUBR(Fsqrt);
2330         DEFSUBR(Fcube_root);
2331 #if defined HAVE_MPFR && defined WITH_MPFR
2332         DEFSUBR(Froot);
2333 #endif
2334 #endif  /* HAVE_FPFLOAT || HAVE_MPFR*/
2335
2336         /* Inverse trig functions. */
2337
2338 #if defined(HAVE_FPFLOAT) || defined(HAVE_MPFR) && defined WITH_MPFR
2339         DEFSUBR(Facosh);
2340         DEFSUBR(Fasinh);
2341         DEFSUBR(Fatanh);
2342         DEFSUBR(Fcosh);
2343         DEFSUBR(Fsinh);
2344         DEFSUBR(Ftanh);
2345 #endif  /* HAVE_FPFLOAT || HAVE_MPFR */
2346 #if defined HAVE_MPFR && defined WITH_MPFR
2347         DEFSUBR(Fsech);
2348         DEFSUBR(Fcsch);
2349         DEFSUBR(Fcoth);
2350 #endif  /* HAVE_MPFR */
2351
2352         /* Rounding functions */
2353
2354         DEFSUBR(Fabs);
2355 #ifdef HAVE_FPFLOAT
2356         DEFSUBR(Ffloat);
2357         DEFSUBR(Flogb);
2358 #endif                          /* HAVE_FPFLOAT */
2359         DEFSUBR(Fceiling);
2360         DEFSUBR(Ffloor);
2361         DEFSUBR(Fround);
2362         DEFSUBR(Ftruncate);
2363         DEFSUBR(Falmost_eq);
2364         DEFSUBR(Falmost_neq);
2365
2366         /* misc complex functions */
2367         DEFSUBR(Fconjugate);
2368         DEFSUBR(Fcanonical_norm);
2369         DEFSUBR(Freal_part);
2370         DEFSUBR(Fimaginary_part);
2371
2372         /* Float-rounding functions. */
2373
2374 #if defined(HAVE_FPFLOAT) || defined(HAVE_MPF) && defined WITH_GMP ||   \
2375         defined(HAVE_MPFR) && defined WITH_MPFR
2376         DEFSUBR(Ffceiling);
2377         DEFSUBR(Fffloor);
2378         DEFSUBR(Ffround);
2379         DEFSUBR(Fftruncate);
2380 #endif  /* HAVE_FPFLOAT || HAVE_MPF(R) */
2381 }
2382
2383 void vars_of_floatfns(void)
2384 {
2385 }