428
+ − 1 /* Primitive operations on floating point for XEmacs Lisp interpreter.
+ − 2 Copyright (C) 1988, 1993, 1994 Free Software Foundation, Inc.
+ − 3
+ − 4 This file is part of XEmacs.
+ − 5
+ − 6 XEmacs is free software; you can redistribute it and/or modify it
+ − 7 under the terms of the GNU General Public License as published by the
+ − 8 Free Software Foundation; either version 2, or (at your option) any
+ − 9 later version.
+ − 10
+ − 11 XEmacs is distributed in the hope that it will be useful, but WITHOUT
+ − 12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ − 13 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ − 14 for more details.
+ − 15
+ − 16 You should have received a copy of the GNU General Public License
+ − 17 along with XEmacs; see the file COPYING. If not, write to
+ − 18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ − 19 Boston, MA 02111-1307, USA. */
+ − 20
+ − 21 /* Synched up with: FSF 19.30. */
+ − 22
+ − 23 /* ANSI C requires only these float functions:
+ − 24 acos, asin, atan, atan2, ceil, cos, cosh, exp, fabs, floor, fmod,
+ − 25 frexp, ldexp, log, log10, modf, pow, sin, sinh, sqrt, tan, tanh.
+ − 26
+ − 27 Define HAVE_INVERSE_HYPERBOLIC if you have acosh, asinh, and atanh.
+ − 28 Define HAVE_CBRT if you have cbrt().
+ − 29 Define HAVE_RINT if you have rint().
+ − 30 If you don't define these, then the appropriate routines will be simulated.
+ − 31
+ − 32 Define HAVE_MATHERR if on a system supporting the SysV matherr() callback.
+ − 33 (This should happen automatically.)
+ − 34
+ − 35 Define FLOAT_CHECK_ERRNO if the float library routines set errno.
+ − 36 This has no effect if HAVE_MATHERR is defined.
+ − 37
+ − 38 Define FLOAT_CATCH_SIGILL if the float library routines signal SIGILL.
+ − 39 (What systems actually do this? Let me know. -jwz)
+ − 40
+ − 41 Define FLOAT_CHECK_DOMAIN if the float library doesn't handle errors by
+ − 42 either setting errno, or signalling SIGFPE/SIGILL. Otherwise, domain and
+ − 43 range checking will happen before calling the float routines. This has
+ − 44 no effect if HAVE_MATHERR is defined (since matherr will be called when
+ − 45 a domain error occurs).
+ − 46 */
+ − 47
+ − 48 #include <config.h>
+ − 49 #include "lisp.h"
+ − 50 #include "syssignal.h"
+ − 51 #include "sysfloat.h"
+ − 52
430
+ − 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
428
+ − 58 static double
430
+ − 59 emacs_rint (double x)
428
+ − 60 {
+ − 61 double r = floor (x + 0.5);
+ − 62 double diff = fabs (r - x);
+ − 63 /* Round to even and correct for any roundoff errors. */
+ − 64 if (diff >= 0.5 && (diff > 0.5 || r != 2.0 * floor (r / 2.0)))
+ − 65 r += r < x ? 1.0 : -1.0;
+ − 66 return r;
+ − 67 }
+ − 68 #endif
+ − 69
+ − 70 /* Nonzero while executing in floating point.
+ − 71 This tells float_error what to do. */
+ − 72 static int in_float;
+ − 73
+ − 74 /* If an argument is out of range for a mathematical function,
+ − 75 here is the actual argument value to use in the error message. */
+ − 76 static Lisp_Object float_error_arg, float_error_arg2;
442
+ − 77 static const char *float_error_fn_name;
428
+ − 78
+ − 79 /* Evaluate the floating point expression D, recording NUM
+ − 80 as the original argument for error messages.
+ − 81 D is normally an assignment expression.
+ − 82 Handle errors which may result in signals or may set errno.
+ − 83
+ − 84 Note that float_error may be declared to return void, so you can't
+ − 85 just cast the zero after the colon to (SIGTYPE) to make the types
+ − 86 check properly. */
+ − 87 #ifdef FLOAT_CHECK_ERRNO
+ − 88 #define IN_FLOAT(d, name, num) \
+ − 89 do { \
+ − 90 float_error_arg = num; \
+ − 91 float_error_fn_name = name; \
+ − 92 in_float = 1; errno = 0; (d); in_float = 0; \
+ − 93 if (errno != 0) in_float_error (); \
+ − 94 } while (0)
+ − 95 #define IN_FLOAT2(d, name, num, num2) \
+ − 96 do { \
+ − 97 float_error_arg = num; \
+ − 98 float_error_arg2 = num2; \
+ − 99 float_error_fn_name = name; \
+ − 100 in_float = 2; errno = 0; (d); in_float = 0; \
+ − 101 if (errno != 0) in_float_error (); \
+ − 102 } while (0)
+ − 103 #else
+ − 104 #define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0)
+ − 105 #define IN_FLOAT2(d, name, num, num2) (in_float = 2, (d), in_float = 0)
+ − 106 #endif
+ − 107
+ − 108
+ − 109 #define arith_error(op,arg) \
771
+ − 110 Fsignal (Qarith_error, list2 (build_msg_string (op), arg))
428
+ − 111 #define range_error(op,arg) \
771
+ − 112 Fsignal (Qrange_error, list2 (build_msg_string (op), arg))
428
+ − 113 #define range_error2(op,a1,a2) \
771
+ − 114 Fsignal (Qrange_error, list3 (build_msg_string (op), a1, a2))
428
+ − 115 #define domain_error(op,arg) \
771
+ − 116 Fsignal (Qdomain_error, list2 (build_msg_string (op), arg))
428
+ − 117 #define domain_error2(op,a1,a2) \
771
+ − 118 Fsignal (Qdomain_error, list3 (build_msg_string (op), a1, a2))
428
+ − 119
+ − 120
+ − 121 /* Convert float to Lisp Integer if it fits, else signal a range
1983
+ − 122 error using the given arguments. If bignums are available, range errors
+ − 123 are never signaled. */
428
+ − 124 static Lisp_Object
2286
+ − 125 float_to_int (double x,
+ − 126 #ifdef HAVE_BIGNUM
+ − 127 const char *UNUSED (name), Lisp_Object UNUSED (num),
+ − 128 Lisp_Object UNUSED (num2)
+ − 129 #else
+ − 130 const char *name, Lisp_Object num, Lisp_Object num2
+ − 131 #endif
+ − 132 )
428
+ − 133 {
1983
+ − 134 #ifdef HAVE_BIGNUM
+ − 135 bignum_set_double (scratch_bignum, x);
+ − 136 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ − 137 #else
2039
+ − 138 REGISTER EMACS_INT result = (EMACS_INT) x;
+ − 139
+ − 140 if (result > EMACS_INT_MAX || result < EMACS_INT_MIN)
+ − 141 {
+ − 142 if (!UNBOUNDP (num2))
+ − 143 range_error2 (name, num, num2);
+ − 144 else
+ − 145 range_error (name, num);
+ − 146 }
+ − 147 return make_int (result);
1983
+ − 148 #endif /* HAVE_BIGNUM */
428
+ − 149 }
+ − 150
+ − 151
+ − 152 static void
+ − 153 in_float_error (void)
+ − 154 {
+ − 155 switch (errno)
+ − 156 {
+ − 157 case 0:
+ − 158 break;
+ − 159 case EDOM:
+ − 160 if (in_float == 2)
+ − 161 domain_error2 (float_error_fn_name, float_error_arg, float_error_arg2);
+ − 162 else
+ − 163 domain_error (float_error_fn_name, float_error_arg);
+ − 164 break;
+ − 165 case ERANGE:
+ − 166 range_error (float_error_fn_name, float_error_arg);
+ − 167 break;
+ − 168 default:
+ − 169 arith_error (float_error_fn_name, float_error_arg);
+ − 170 break;
+ − 171 }
+ − 172 }
+ − 173
+ − 174
+ − 175 static Lisp_Object
2286
+ − 176 mark_float (Lisp_Object UNUSED (obj))
428
+ − 177 {
+ − 178 return Qnil;
+ − 179 }
+ − 180
+ − 181 static int
2286
+ − 182 float_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth))
428
+ − 183 {
+ − 184 return (extract_float (obj1) == extract_float (obj2));
+ − 185 }
+ − 186
665
+ − 187 static Hashcode
2286
+ − 188 float_hash (Lisp_Object obj, int UNUSED (depth))
428
+ − 189 {
+ − 190 /* mod the value down to 32-bit range */
+ − 191 /* #### change for 64-bit machines */
+ − 192 return (unsigned long) fmod (extract_float (obj), 4e9);
+ − 193 }
+ − 194
1204
+ − 195 static const struct memory_description float_description[] = {
428
+ − 196 { XD_END }
+ − 197 };
+ − 198
934
+ − 199 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("float", float,
+ − 200 1, /*dumpable-flag*/
+ − 201 mark_float, print_float, 0, float_equal,
+ − 202 float_hash, float_description,
+ − 203 Lisp_Float);
428
+ − 204
+ − 205 /* Extract a Lisp number as a `double', or signal an error. */
+ − 206
+ − 207 double
+ − 208 extract_float (Lisp_Object num)
+ − 209 {
+ − 210 if (FLOATP (num))
+ − 211 return XFLOAT_DATA (num);
+ − 212
+ − 213 if (INTP (num))
+ − 214 return (double) XINT (num);
+ − 215
1983
+ − 216 #ifdef HAVE_BIGNUM
+ − 217 if (BIGNUMP (num))
+ − 218 return bignum_to_double (XBIGNUM_DATA (num));
+ − 219 #endif
+ − 220
+ − 221 #ifdef HAVE_RATIO
+ − 222 if (RATIOP (num))
+ − 223 return ratio_to_double (XRATIO_DATA (num));
+ − 224 #endif
+ − 225
+ − 226 #ifdef HAVE_BIGFLOAT
+ − 227 if (BIGFLOATP (num))
+ − 228 return bigfloat_to_double (XBIGFLOAT_DATA (num));
+ − 229 #endif
+ − 230
428
+ − 231 return extract_float (wrong_type_argument (Qnumberp, num));
+ − 232 }
+ − 233
+ − 234 /* Trig functions. */
+ − 235
+ − 236 DEFUN ("acos", Facos, 1, 1, 0, /*
444
+ − 237 Return the inverse cosine of NUMBER.
428
+ − 238 */
444
+ − 239 (number))
428
+ − 240 {
444
+ − 241 double d = extract_float (number);
428
+ − 242 #ifdef FLOAT_CHECK_DOMAIN
+ − 243 if (d > 1.0 || d < -1.0)
444
+ − 244 domain_error ("acos", number);
428
+ − 245 #endif
444
+ − 246 IN_FLOAT (d = acos (d), "acos", number);
428
+ − 247 return make_float (d);
+ − 248 }
+ − 249
+ − 250 DEFUN ("asin", Fasin, 1, 1, 0, /*
444
+ − 251 Return the inverse sine of NUMBER.
428
+ − 252 */
444
+ − 253 (number))
428
+ − 254 {
444
+ − 255 double d = extract_float (number);
428
+ − 256 #ifdef FLOAT_CHECK_DOMAIN
+ − 257 if (d > 1.0 || d < -1.0)
444
+ − 258 domain_error ("asin", number);
428
+ − 259 #endif
444
+ − 260 IN_FLOAT (d = asin (d), "asin", number);
428
+ − 261 return make_float (d);
+ − 262 }
+ − 263
+ − 264 DEFUN ("atan", Fatan, 1, 2, 0, /*
444
+ − 265 Return the inverse tangent of NUMBER.
+ − 266 If optional second argument NUMBER2 is provided,
+ − 267 return atan2 (NUMBER, NUMBER2).
428
+ − 268 */
444
+ − 269 (number, number2))
428
+ − 270 {
444
+ − 271 double d = extract_float (number);
428
+ − 272
444
+ − 273 if (NILP (number2))
+ − 274 IN_FLOAT (d = atan (d), "atan", number);
428
+ − 275 else
+ − 276 {
444
+ − 277 double d2 = extract_float (number2);
428
+ − 278 #ifdef FLOAT_CHECK_DOMAIN
+ − 279 if (d == 0.0 && d2 == 0.0)
444
+ − 280 domain_error2 ("atan", number, number2);
428
+ − 281 #endif
444
+ − 282 IN_FLOAT2 (d = atan2 (d, d2), "atan", number, number2);
428
+ − 283 }
+ − 284 return make_float (d);
+ − 285 }
+ − 286
+ − 287 DEFUN ("cos", Fcos, 1, 1, 0, /*
444
+ − 288 Return the cosine of NUMBER.
428
+ − 289 */
444
+ − 290 (number))
428
+ − 291 {
444
+ − 292 double d = extract_float (number);
+ − 293 IN_FLOAT (d = cos (d), "cos", number);
428
+ − 294 return make_float (d);
+ − 295 }
+ − 296
+ − 297 DEFUN ("sin", Fsin, 1, 1, 0, /*
444
+ − 298 Return the sine of NUMBER.
428
+ − 299 */
444
+ − 300 (number))
428
+ − 301 {
444
+ − 302 double d = extract_float (number);
+ − 303 IN_FLOAT (d = sin (d), "sin", number);
428
+ − 304 return make_float (d);
+ − 305 }
+ − 306
+ − 307 DEFUN ("tan", Ftan, 1, 1, 0, /*
444
+ − 308 Return the tangent of NUMBER.
428
+ − 309 */
444
+ − 310 (number))
428
+ − 311 {
444
+ − 312 double d = extract_float (number);
428
+ − 313 double c = cos (d);
+ − 314 #ifdef FLOAT_CHECK_DOMAIN
+ − 315 if (c == 0.0)
444
+ − 316 domain_error ("tan", number);
428
+ − 317 #endif
444
+ − 318 IN_FLOAT (d = (sin (d) / c), "tan", number);
428
+ − 319 return make_float (d);
+ − 320 }
+ − 321
+ − 322 /* Bessel functions */
+ − 323 #if 0 /* Leave these out unless we find there's a reason for them. */
+ − 324
+ − 325 DEFUN ("bessel-j0", Fbessel_j0, 1, 1, 0, /*
444
+ − 326 Return the bessel function j0 of NUMBER.
428
+ − 327 */
444
+ − 328 (number))
428
+ − 329 {
444
+ − 330 double d = extract_float (number);
+ − 331 IN_FLOAT (d = j0 (d), "bessel-j0", number);
428
+ − 332 return make_float (d);
+ − 333 }
+ − 334
+ − 335 DEFUN ("bessel-j1", Fbessel_j1, 1, 1, 0, /*
444
+ − 336 Return the bessel function j1 of NUMBER.
428
+ − 337 */
444
+ − 338 (number))
428
+ − 339 {
444
+ − 340 double d = extract_float (number);
+ − 341 IN_FLOAT (d = j1 (d), "bessel-j1", number);
428
+ − 342 return make_float (d);
+ − 343 }
+ − 344
+ − 345 DEFUN ("bessel-jn", Fbessel_jn, 2, 2, 0, /*
444
+ − 346 Return the order N bessel function output jn of NUMBER.
+ − 347 The first number (the order) is truncated to an integer.
428
+ − 348 */
444
+ − 349 (number1, number2))
428
+ − 350 {
444
+ − 351 int i1 = extract_float (number1);
+ − 352 double f2 = extract_float (number2);
428
+ − 353
444
+ − 354 IN_FLOAT (f2 = jn (i1, f2), "bessel-jn", number1);
428
+ − 355 return make_float (f2);
+ − 356 }
+ − 357
+ − 358 DEFUN ("bessel-y0", Fbessel_y0, 1, 1, 0, /*
444
+ − 359 Return the bessel function y0 of NUMBER.
428
+ − 360 */
444
+ − 361 (number))
428
+ − 362 {
444
+ − 363 double d = extract_float (number);
+ − 364 IN_FLOAT (d = y0 (d), "bessel-y0", number);
428
+ − 365 return make_float (d);
+ − 366 }
+ − 367
+ − 368 DEFUN ("bessel-y1", Fbessel_y1, 1, 1, 0, /*
444
+ − 369 Return the bessel function y1 of NUMBER.
428
+ − 370 */
444
+ − 371 (number))
428
+ − 372 {
444
+ − 373 double d = extract_float (number);
+ − 374 IN_FLOAT (d = y1 (d), "bessel-y0", number);
428
+ − 375 return make_float (d);
+ − 376 }
+ − 377
+ − 378 DEFUN ("bessel-yn", Fbessel_yn, 2, 2, 0, /*
444
+ − 379 Return the order N bessel function output yn of NUMBER.
+ − 380 The first number (the order) is truncated to an integer.
428
+ − 381 */
444
+ − 382 (number1, number2))
428
+ − 383 {
444
+ − 384 int i1 = extract_float (number1);
+ − 385 double f2 = extract_float (number2);
428
+ − 386
444
+ − 387 IN_FLOAT (f2 = yn (i1, f2), "bessel-yn", number1);
428
+ − 388 return make_float (f2);
+ − 389 }
+ − 390
+ − 391 #endif /* 0 (bessel functions) */
+ − 392
+ − 393 /* Error functions. */
+ − 394 #if 0 /* Leave these out unless we see they are worth having. */
+ − 395
+ − 396 DEFUN ("erf", Ferf, 1, 1, 0, /*
444
+ − 397 Return the mathematical error function of NUMBER.
428
+ − 398 */
444
+ − 399 (number))
428
+ − 400 {
444
+ − 401 double d = extract_float (number);
+ − 402 IN_FLOAT (d = erf (d), "erf", number);
428
+ − 403 return make_float (d);
+ − 404 }
+ − 405
+ − 406 DEFUN ("erfc", Ferfc, 1, 1, 0, /*
444
+ − 407 Return the complementary error function of NUMBER.
428
+ − 408 */
444
+ − 409 (number))
428
+ − 410 {
444
+ − 411 double d = extract_float (number);
+ − 412 IN_FLOAT (d = erfc (d), "erfc", number);
428
+ − 413 return make_float (d);
+ − 414 }
+ − 415
+ − 416 DEFUN ("log-gamma", Flog_gamma, 1, 1, 0, /*
444
+ − 417 Return the log gamma of NUMBER.
428
+ − 418 */
444
+ − 419 (number))
428
+ − 420 {
444
+ − 421 double d = extract_float (number);
+ − 422 IN_FLOAT (d = lgamma (d), "log-gamma", number);
428
+ − 423 return make_float (d);
+ − 424 }
+ − 425
+ − 426 #endif /* 0 (error functions) */
+ − 427
+ − 428
+ − 429 /* Root and Log functions. */
+ − 430
+ − 431 DEFUN ("exp", Fexp, 1, 1, 0, /*
444
+ − 432 Return the exponential base e of NUMBER.
428
+ − 433 */
444
+ − 434 (number))
428
+ − 435 {
444
+ − 436 double d = extract_float (number);
428
+ − 437 #ifdef FLOAT_CHECK_DOMAIN
+ − 438 if (d > 709.7827) /* Assume IEEE doubles here */
444
+ − 439 range_error ("exp", number);
428
+ − 440 else if (d < -709.0)
+ − 441 return make_float (0.0);
+ − 442 else
+ − 443 #endif
444
+ − 444 IN_FLOAT (d = exp (d), "exp", number);
428
+ − 445 return make_float (d);
+ − 446 }
+ − 447
+ − 448 DEFUN ("expt", Fexpt, 2, 2, 0, /*
444
+ − 449 Return the exponential NUMBER1 ** NUMBER2.
428
+ − 450 */
444
+ − 451 (number1, number2))
428
+ − 452 {
1983
+ − 453 #ifdef HAVE_BIGNUM
+ − 454 if (INTEGERP (number1) && INTP (number2))
+ − 455 {
+ − 456 if (INTP (number1))
+ − 457 {
+ − 458 bignum_set_long (scratch_bignum2, XREALINT (number1));
+ − 459 bignum_pow (scratch_bignum, scratch_bignum2, XREALINT (number2));
+ − 460 }
+ − 461 else
+ − 462 bignum_pow (scratch_bignum, XBIGNUM_DATA (number1),
+ − 463 XREALINT (number2));
+ − 464 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ − 465 }
+ − 466 #endif
+ − 467
444
+ − 468 if (INTP (number1) && /* common lisp spec */
+ − 469 INTP (number2)) /* don't promote, if both are ints */
428
+ − 470 {
+ − 471 EMACS_INT retval;
444
+ − 472 EMACS_INT x = XINT (number1);
+ − 473 EMACS_INT y = XINT (number2);
428
+ − 474
+ − 475 if (y < 0)
+ − 476 {
+ − 477 if (x == 1)
+ − 478 retval = 1;
+ − 479 else if (x == -1)
+ − 480 retval = (y & 1) ? -1 : 1;
+ − 481 else
+ − 482 retval = 0;
+ − 483 }
+ − 484 else
+ − 485 {
+ − 486 retval = 1;
+ − 487 while (y > 0)
+ − 488 {
+ − 489 if (y & 1)
+ − 490 retval *= x;
+ − 491 x *= x;
+ − 492 y = (EMACS_UINT) y >> 1;
+ − 493 }
+ − 494 }
+ − 495 return make_int (retval);
+ − 496 }
+ − 497
1983
+ − 498 #if defined(HAVE_BIGFLOAT) && defined(bigfloat_pow)
+ − 499 if (BIGFLOATP (number1) && INTEGERP (number2))
+ − 500 {
2057
+ − 501 unsigned long exponent;
1983
+ − 502
+ − 503 #ifdef HAVE_BIGNUM
+ − 504 if (BIGNUMP (number2))
2057
+ − 505 exponent = bignum_to_ulong (XBIGNUM_DATA (number2));
1983
+ − 506 else
+ − 507 #endif
2057
+ − 508 exponent = XUINT (number2);
1983
+ − 509 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number1));
2057
+ − 510 bigfloat_pow (scratch_bigfloat, XBIGFLOAT_DATA (number1), exponent);
1983
+ − 511 return make_bigfloat_bf (scratch_bigfloat);
+ − 512 }
+ − 513 #endif
+ − 514
428
+ − 515 {
444
+ − 516 double f1 = extract_float (number1);
+ − 517 double f2 = extract_float (number2);
428
+ − 518 /* Really should check for overflow, too */
+ − 519 if (f1 == 0.0 && f2 == 0.0)
+ − 520 f1 = 1.0;
+ − 521 # ifdef FLOAT_CHECK_DOMAIN
+ − 522 else if ((f1 == 0.0 && f2 < 0.0) || (f1 < 0 && f2 != floor(f2)))
444
+ − 523 domain_error2 ("expt", number1, number2);
428
+ − 524 # endif /* FLOAT_CHECK_DOMAIN */
444
+ − 525 IN_FLOAT2 (f1 = pow (f1, f2), "expt", number1, number2);
428
+ − 526 return make_float (f1);
+ − 527 }
+ − 528 }
+ − 529
+ − 530 DEFUN ("log", Flog, 1, 2, 0, /*
444
+ − 531 Return the natural logarithm of NUMBER.
+ − 532 If second optional argument BASE is given, return the logarithm of
+ − 533 NUMBER using that base.
428
+ − 534 */
444
+ − 535 (number, base))
428
+ − 536 {
444
+ − 537 double d = extract_float (number);
428
+ − 538 #ifdef FLOAT_CHECK_DOMAIN
+ − 539 if (d <= 0.0)
444
+ − 540 domain_error2 ("log", number, base);
428
+ − 541 #endif
+ − 542 if (NILP (base))
444
+ − 543 IN_FLOAT (d = log (d), "log", number);
428
+ − 544 else
+ − 545 {
+ − 546 double b = extract_float (base);
+ − 547 #ifdef FLOAT_CHECK_DOMAIN
+ − 548 if (b <= 0.0 || b == 1.0)
444
+ − 549 domain_error2 ("log", number, base);
428
+ − 550 #endif
+ − 551 if (b == 10.0)
444
+ − 552 IN_FLOAT2 (d = log10 (d), "log", number, base);
428
+ − 553 else
444
+ − 554 IN_FLOAT2 (d = (log (d) / log (b)), "log", number, base);
428
+ − 555 }
+ − 556 return make_float (d);
+ − 557 }
+ − 558
+ − 559
+ − 560 DEFUN ("log10", Flog10, 1, 1, 0, /*
444
+ − 561 Return the logarithm base 10 of NUMBER.
428
+ − 562 */
444
+ − 563 (number))
428
+ − 564 {
444
+ − 565 double d = extract_float (number);
428
+ − 566 #ifdef FLOAT_CHECK_DOMAIN
+ − 567 if (d <= 0.0)
444
+ − 568 domain_error ("log10", number);
428
+ − 569 #endif
444
+ − 570 IN_FLOAT (d = log10 (d), "log10", number);
428
+ − 571 return make_float (d);
+ − 572 }
+ − 573
+ − 574
+ − 575 DEFUN ("sqrt", Fsqrt, 1, 1, 0, /*
444
+ − 576 Return the square root of NUMBER.
428
+ − 577 */
444
+ − 578 (number))
428
+ − 579 {
1983
+ − 580 double d;
+ − 581
+ − 582 #if defined(HAVE_BIGFLOAT) && defined(bigfloat_sqrt)
+ − 583 if (BIGFLOATP (number))
+ − 584 {
+ − 585 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
+ − 586 bigfloat_sqrt (scratch_bigfloat, XBIGFLOAT_DATA (number));
+ − 587 return make_bigfloat_bf (scratch_bigfloat);
+ − 588 }
+ − 589 #endif /* HAVE_BIGFLOAT */
+ − 590 d = extract_float (number);
428
+ − 591 #ifdef FLOAT_CHECK_DOMAIN
+ − 592 if (d < 0.0)
444
+ − 593 domain_error ("sqrt", number);
428
+ − 594 #endif
444
+ − 595 IN_FLOAT (d = sqrt (d), "sqrt", number);
428
+ − 596 return make_float (d);
+ − 597 }
+ − 598
+ − 599
+ − 600 DEFUN ("cube-root", Fcube_root, 1, 1, 0, /*
444
+ − 601 Return the cube root of NUMBER.
428
+ − 602 */
444
+ − 603 (number))
428
+ − 604 {
444
+ − 605 double d = extract_float (number);
428
+ − 606 #ifdef HAVE_CBRT
444
+ − 607 IN_FLOAT (d = cbrt (d), "cube-root", number);
428
+ − 608 #else
+ − 609 if (d >= 0.0)
444
+ − 610 IN_FLOAT (d = pow (d, 1.0/3.0), "cube-root", number);
428
+ − 611 else
444
+ − 612 IN_FLOAT (d = -pow (-d, 1.0/3.0), "cube-root", number);
428
+ − 613 #endif
+ − 614 return make_float (d);
+ − 615 }
+ − 616
+ − 617 /* Inverse trig functions. */
+ − 618
+ − 619 DEFUN ("acosh", Facosh, 1, 1, 0, /*
444
+ − 620 Return the inverse hyperbolic cosine of NUMBER.
428
+ − 621 */
444
+ − 622 (number))
428
+ − 623 {
444
+ − 624 double d = extract_float (number);
428
+ − 625 #ifdef FLOAT_CHECK_DOMAIN
+ − 626 if (d < 1.0)
444
+ − 627 domain_error ("acosh", number);
428
+ − 628 #endif
+ − 629 #ifdef HAVE_INVERSE_HYPERBOLIC
444
+ − 630 IN_FLOAT (d = acosh (d), "acosh", number);
428
+ − 631 #else
444
+ − 632 IN_FLOAT (d = log (d + sqrt (d*d - 1.0)), "acosh", number);
428
+ − 633 #endif
+ − 634 return make_float (d);
+ − 635 }
+ − 636
+ − 637 DEFUN ("asinh", Fasinh, 1, 1, 0, /*
444
+ − 638 Return the inverse hyperbolic sine of NUMBER.
428
+ − 639 */
444
+ − 640 (number))
428
+ − 641 {
444
+ − 642 double d = extract_float (number);
428
+ − 643 #ifdef HAVE_INVERSE_HYPERBOLIC
444
+ − 644 IN_FLOAT (d = asinh (d), "asinh", number);
428
+ − 645 #else
444
+ − 646 IN_FLOAT (d = log (d + sqrt (d*d + 1.0)), "asinh", number);
428
+ − 647 #endif
+ − 648 return make_float (d);
+ − 649 }
+ − 650
+ − 651 DEFUN ("atanh", Fatanh, 1, 1, 0, /*
444
+ − 652 Return the inverse hyperbolic tangent of NUMBER.
428
+ − 653 */
444
+ − 654 (number))
428
+ − 655 {
444
+ − 656 double d = extract_float (number);
428
+ − 657 #ifdef FLOAT_CHECK_DOMAIN
+ − 658 if (d >= 1.0 || d <= -1.0)
444
+ − 659 domain_error ("atanh", number);
428
+ − 660 #endif
+ − 661 #ifdef HAVE_INVERSE_HYPERBOLIC
444
+ − 662 IN_FLOAT (d = atanh (d), "atanh", number);
428
+ − 663 #else
444
+ − 664 IN_FLOAT (d = 0.5 * log ((1.0 + d) / (1.0 - d)), "atanh", number);
428
+ − 665 #endif
+ − 666 return make_float (d);
+ − 667 }
+ − 668
+ − 669 DEFUN ("cosh", Fcosh, 1, 1, 0, /*
444
+ − 670 Return the hyperbolic cosine of NUMBER.
428
+ − 671 */
444
+ − 672 (number))
428
+ − 673 {
444
+ − 674 double d = extract_float (number);
428
+ − 675 #ifdef FLOAT_CHECK_DOMAIN
+ − 676 if (d > 710.0 || d < -710.0)
444
+ − 677 range_error ("cosh", number);
428
+ − 678 #endif
444
+ − 679 IN_FLOAT (d = cosh (d), "cosh", number);
428
+ − 680 return make_float (d);
+ − 681 }
+ − 682
+ − 683 DEFUN ("sinh", Fsinh, 1, 1, 0, /*
444
+ − 684 Return the hyperbolic sine of NUMBER.
428
+ − 685 */
444
+ − 686 (number))
428
+ − 687 {
444
+ − 688 double d = extract_float (number);
428
+ − 689 #ifdef FLOAT_CHECK_DOMAIN
+ − 690 if (d > 710.0 || d < -710.0)
444
+ − 691 range_error ("sinh", number);
428
+ − 692 #endif
444
+ − 693 IN_FLOAT (d = sinh (d), "sinh", number);
428
+ − 694 return make_float (d);
+ − 695 }
+ − 696
+ − 697 DEFUN ("tanh", Ftanh, 1, 1, 0, /*
444
+ − 698 Return the hyperbolic tangent of NUMBER.
428
+ − 699 */
444
+ − 700 (number))
428
+ − 701 {
444
+ − 702 double d = extract_float (number);
+ − 703 IN_FLOAT (d = tanh (d), "tanh", number);
428
+ − 704 return make_float (d);
+ − 705 }
+ − 706
+ − 707 /* Rounding functions */
+ − 708
+ − 709 DEFUN ("abs", Fabs, 1, 1, 0, /*
444
+ − 710 Return the absolute value of NUMBER.
428
+ − 711 */
444
+ − 712 (number))
428
+ − 713 {
444
+ − 714 if (FLOATP (number))
428
+ − 715 {
444
+ − 716 IN_FLOAT (number = make_float (fabs (XFLOAT_DATA (number))),
+ − 717 "abs", number);
+ − 718 return number;
428
+ − 719 }
+ − 720
444
+ − 721 if (INTP (number))
1983
+ − 722 #ifdef HAVE_BIGNUM
+ − 723 /* The most negative Lisp fixnum will overflow */
+ − 724 return (XINT (number) >= 0) ? number : make_integer (- XINT (number));
+ − 725 #else
444
+ − 726 return (XINT (number) >= 0) ? number : make_int (- XINT (number));
1983
+ − 727 #endif
+ − 728
+ − 729 #ifdef HAVE_BIGNUM
+ − 730 if (BIGNUMP (number))
+ − 731 {
+ − 732 if (bignum_sign (XBIGNUM_DATA (number)) >= 0)
+ − 733 return number;
+ − 734 bignum_abs (scratch_bignum, XBIGNUM_DATA (number));
+ − 735 return make_bignum_bg (scratch_bignum);
+ − 736 }
+ − 737 #endif
+ − 738
+ − 739 #ifdef HAVE_RATIO
+ − 740 if (RATIOP (number))
+ − 741 {
+ − 742 if (ratio_sign (XRATIO_DATA (number)) >= 0)
+ − 743 return number;
+ − 744 ratio_abs (scratch_ratio, XRATIO_DATA (number));
+ − 745 return make_ratio_rt (scratch_ratio);
+ − 746 }
+ − 747 #endif
+ − 748
+ − 749 #ifdef HAVE_BIGFLOAT
+ − 750 if (BIGFLOATP (number))
+ − 751 {
+ − 752 if (bigfloat_sign (XBIGFLOAT_DATA (number)) >= 0)
+ − 753 return number;
+ − 754 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
+ − 755 bigfloat_abs (scratch_bigfloat, XBIGFLOAT_DATA (number));
+ − 756 return make_bigfloat_bf (scratch_bigfloat);
+ − 757 }
+ − 758 #endif
428
+ − 759
444
+ − 760 return Fabs (wrong_type_argument (Qnumberp, number));
428
+ − 761 }
+ − 762
+ − 763 DEFUN ("float", Ffloat, 1, 1, 0, /*
444
+ − 764 Return the floating point number numerically equal to NUMBER.
428
+ − 765 */
444
+ − 766 (number))
428
+ − 767 {
444
+ − 768 if (INTP (number))
+ − 769 return make_float ((double) XINT (number));
428
+ − 770
1983
+ − 771 #ifdef HAVE_BIGNUM
+ − 772 if (BIGFLOATP (number))
+ − 773 {
+ − 774 #ifdef HAVE_BIGFLOAT
+ − 775 if (ZEROP (Vdefault_float_precision))
+ − 776 #endif
+ − 777 return make_float (bignum_to_double (XBIGNUM_DATA (number)));
+ − 778 #ifdef HAVE_BIGFLOAT
+ − 779 else
+ − 780 {
+ − 781 bigfloat_set_prec (scratch_bigfloat, bigfloat_get_default_prec ());
+ − 782 bigfloat_set_bignum (scratch_bigfloat, XBIGNUM_DATA (number));
+ − 783 return make_bigfloat_bf (scratch_bigfloat);
+ − 784 }
+ − 785 #endif /* HAVE_BIGFLOAT */
+ − 786 }
+ − 787 #endif /* HAVE_BIGNUM */
+ − 788
+ − 789 #ifdef HAVE_RATIO
+ − 790 if (RATIOP (number))
2092
+ − 791 return make_float (ratio_to_double (XRATIO_DATA (number)));
1983
+ − 792 #endif
+ − 793
444
+ − 794 if (FLOATP (number)) /* give 'em the same float back */
+ − 795 return number;
428
+ − 796
444
+ − 797 return Ffloat (wrong_type_argument (Qnumberp, number));
428
+ − 798 }
+ − 799
+ − 800 DEFUN ("logb", Flogb, 1, 1, 0, /*
444
+ − 801 Return largest integer <= the base 2 log of the magnitude of NUMBER.
428
+ − 802 This is the same as the exponent of a float.
+ − 803 */
444
+ − 804 (number))
428
+ − 805 {
444
+ − 806 double f = extract_float (number);
428
+ − 807
+ − 808 if (f == 0.0)
2039
+ − 809 return make_int (EMACS_INT_MIN);
428
+ − 810 #ifdef HAVE_LOGB
+ − 811 {
+ − 812 Lisp_Object val;
444
+ − 813 IN_FLOAT (val = make_int ((EMACS_INT) logb (f)), "logb", number);
434
+ − 814 return val;
428
+ − 815 }
+ − 816 #else
+ − 817 #ifdef HAVE_FREXP
+ − 818 {
+ − 819 int exqp;
444
+ − 820 IN_FLOAT (frexp (f, &exqp), "logb", number);
434
+ − 821 return make_int (exqp - 1);
428
+ − 822 }
+ − 823 #else
+ − 824 {
+ − 825 int i;
+ − 826 double d;
+ − 827 EMACS_INT val;
+ − 828 if (f < 0.0)
+ − 829 f = -f;
+ − 830 val = -1;
+ − 831 while (f < 0.5)
+ − 832 {
+ − 833 for (i = 1, d = 0.5; d * d >= f; i += i)
+ − 834 d *= d;
+ − 835 f /= d;
+ − 836 val -= i;
+ − 837 }
+ − 838 while (f >= 1.0)
+ − 839 {
+ − 840 for (i = 1, d = 2.0; d * d <= f; i += i)
+ − 841 d *= d;
+ − 842 f /= d;
+ − 843 val += i;
+ − 844 }
434
+ − 845 return make_int (val);
428
+ − 846 }
+ − 847 #endif /* ! HAVE_FREXP */
+ − 848 #endif /* ! HAVE_LOGB */
+ − 849 }
+ − 850
+ − 851 DEFUN ("ceiling", Fceiling, 1, 1, 0, /*
444
+ − 852 Return the smallest integer no less than NUMBER. (Round toward +inf.)
428
+ − 853 */
444
+ − 854 (number))
428
+ − 855 {
444
+ − 856 if (FLOATP (number))
428
+ − 857 {
+ − 858 double d;
444
+ − 859 IN_FLOAT ((d = ceil (XFLOAT_DATA (number))), "ceiling", number);
+ − 860 return (float_to_int (d, "ceiling", number, Qunbound));
428
+ − 861 }
+ − 862
1983
+ − 863 #ifdef HAVE_BIGNUM
+ − 864 if (INTEGERP (number))
+ − 865 #else
444
+ − 866 if (INTP (number))
1983
+ − 867 #endif
444
+ − 868 return number;
428
+ − 869
1983
+ − 870 #ifdef HAVE_RATIO
+ − 871 if (RATIOP (number))
+ − 872 {
+ − 873 bignum_ceil (scratch_bignum, XRATIO_NUMERATOR (number),
+ − 874 XRATIO_DENOMINATOR (number));
+ − 875 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ − 876 }
+ − 877 #endif
+ − 878
+ − 879 #ifdef HAVE_BIGFLOAT
+ − 880 if (BIGFLOATP (number))
+ − 881 {
+ − 882 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
+ − 883 bigfloat_ceil (scratch_bigfloat, XBIGFLOAT_DATA (number));
+ − 884 #ifdef HAVE_BIGNUM
+ − 885 bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
+ − 886 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ − 887 #else
+ − 888 return make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
+ − 889 #endif /* HAVE_BIGNUM */
+ − 890 }
+ − 891 #endif /* HAVE_BIGFLOAT */
+ − 892
444
+ − 893 return Fceiling (wrong_type_argument (Qnumberp, number));
428
+ − 894 }
+ − 895
+ − 896
+ − 897 DEFUN ("floor", Ffloor, 1, 2, 0, /*
444
+ − 898 Return the largest integer no greater than NUMBER. (Round towards -inf.)
+ − 899 With optional second argument DIVISOR, return the largest integer no
+ − 900 greater than NUMBER/DIVISOR.
428
+ − 901 */
444
+ − 902 (number, divisor))
428
+ − 903 {
1983
+ − 904 #ifdef WITH_NUMBER_TYPES
+ − 905 CHECK_REAL (number);
+ − 906 if (NILP (divisor))
+ − 907 {
+ − 908 if (FLOATP (number))
+ − 909 {
+ − 910 double d;
+ − 911 IN_FLOAT ((d = floor (XFLOAT_DATA (number))), "floor", number);
+ − 912 return (float_to_int (d, "floor", number, Qunbound));
+ − 913 }
+ − 914 #ifdef HAVE_RATIO
+ − 915 else if (RATIOP (number))
+ − 916 {
+ − 917 bignum_floor (scratch_bignum, XRATIO_NUMERATOR (number),
+ − 918 XRATIO_DENOMINATOR (number));
+ − 919 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ − 920 }
+ − 921 #endif
+ − 922 #ifdef HAVE_BIGFLOAT
+ − 923 else if (BIGFLOATP (number))
+ − 924 {
+ − 925 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
+ − 926 bigfloat_floor (scratch_bigfloat, XBIGFLOAT_DATA (number));
+ − 927 return make_bigfloat_bf (scratch_bigfloat);
+ − 928 }
+ − 929 #endif
+ − 930 return number;
+ − 931 }
+ − 932 else
+ − 933 {
+ − 934 CHECK_REAL (divisor);
+ − 935 switch (promote_args (&number, &divisor))
+ − 936 {
+ − 937 case FIXNUM_T:
+ − 938 {
+ − 939 EMACS_INT i1 = XREALINT (number);
+ − 940 EMACS_INT i2 = XREALINT (divisor);
+ − 941
+ − 942 if (i2 == 0)
+ − 943 Fsignal (Qarith_error, Qnil);
+ − 944
+ − 945 /* With C's /, the result is implementation-defined if either
+ − 946 operand is negative, so use only nonnegative operands. */
+ − 947 i1 = (i2 < 0
+ − 948 ? (i1 <= 0 ? -i1 / -i2 : -1 - ((i1 - 1) / -i2))
+ − 949 : (i1 < 0 ? -1 - ((-1 - i1) / i2) : i1 / i2));
+ − 950
+ − 951 return make_int (i1);
+ − 952 }
+ − 953 #ifdef HAVE_BIGNUM
+ − 954 case BIGNUM_T:
+ − 955 if (bignum_sign (XBIGNUM_DATA (divisor)) == 0)
+ − 956 Fsignal (Qarith_error, Qnil);
+ − 957 bignum_floor (scratch_bignum, XBIGNUM_DATA (number),
+ − 958 XBIGNUM_DATA (divisor));
+ − 959 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ − 960 #endif
+ − 961 #ifdef HAVE_RATIO
+ − 962 case RATIO_T:
+ − 963 if (ratio_sign (XRATIO_DATA (divisor)) == 0)
+ − 964 Fsignal (Qarith_error, Qnil);
+ − 965 ratio_div (scratch_ratio, XRATIO_DATA (number),
+ − 966 XRATIO_DATA (divisor));
+ − 967 bignum_floor (scratch_bignum, ratio_numerator (scratch_ratio),
+ − 968 ratio_denominator (scratch_ratio));
+ − 969 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ − 970 #endif
+ − 971 #ifdef HAVE_BIGFLOAT
+ − 972 case BIGFLOAT_T:
+ − 973 if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0)
+ − 974 Fsignal (Qarith_error, Qnil);
+ − 975 bigfloat_set_prec (scratch_bigfloat,
+ − 976 max (XBIGFLOAT_GET_PREC (number),
+ − 977 XBIGFLOAT_GET_PREC (divisor)));
+ − 978 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (number),
+ − 979 XBIGFLOAT_DATA (divisor));
+ − 980 bigfloat_floor (scratch_bigfloat, scratch_bigfloat);
+ − 981 return make_bigfloat_bf (scratch_bigfloat);
+ − 982 #endif
1995
+ − 983 default: /* FLOAT_T */
+ − 984 {
+ − 985 double f1 = extract_float (number);
+ − 986 double f2 = extract_float (divisor);
+ − 987
+ − 988 if (f2 == 0.0)
+ − 989 Fsignal (Qarith_error, Qnil);
+ − 990
+ − 991 IN_FLOAT2 (f1 = floor (f1 / f2), "floor", number, divisor);
+ − 992 return float_to_int (f1, "floor", number, divisor);
+ − 993 }
1983
+ − 994 }
+ − 995 }
+ − 996 #else /* !WITH_NUMBER_TYPES */
444
+ − 997 CHECK_INT_OR_FLOAT (number);
428
+ − 998
+ − 999 if (! NILP (divisor))
+ − 1000 {
+ − 1001 EMACS_INT i1, i2;
+ − 1002
+ − 1003 CHECK_INT_OR_FLOAT (divisor);
+ − 1004
444
+ − 1005 if (FLOATP (number) || FLOATP (divisor))
428
+ − 1006 {
444
+ − 1007 double f1 = extract_float (number);
428
+ − 1008 double f2 = extract_float (divisor);
+ − 1009
+ − 1010 if (f2 == 0)
+ − 1011 Fsignal (Qarith_error, Qnil);
+ − 1012
444
+ − 1013 IN_FLOAT2 (f1 = floor (f1 / f2), "floor", number, divisor);
+ − 1014 return float_to_int (f1, "floor", number, divisor);
428
+ − 1015 }
+ − 1016
444
+ − 1017 i1 = XINT (number);
428
+ − 1018 i2 = XINT (divisor);
+ − 1019
+ − 1020 if (i2 == 0)
+ − 1021 Fsignal (Qarith_error, Qnil);
+ − 1022
+ − 1023 /* With C's /, the result is implementation-defined if either operand
+ − 1024 is negative, so use only nonnegative operands. */
+ − 1025 i1 = (i2 < 0
+ − 1026 ? (i1 <= 0 ? -i1 / -i2 : -1 - ((i1 - 1) / -i2))
+ − 1027 : (i1 < 0 ? -1 - ((-1 - i1) / i2) : i1 / i2));
+ − 1028
+ − 1029 return (make_int (i1));
+ − 1030 }
+ − 1031
444
+ − 1032 if (FLOATP (number))
428
+ − 1033 {
+ − 1034 double d;
444
+ − 1035 IN_FLOAT ((d = floor (XFLOAT_DATA (number))), "floor", number);
+ − 1036 return (float_to_int (d, "floor", number, Qunbound));
428
+ − 1037 }
+ − 1038
444
+ − 1039 return number;
1983
+ − 1040 #endif /* WITH_NUMBER_TYPES */
428
+ − 1041 }
+ − 1042
+ − 1043 DEFUN ("round", Fround, 1, 1, 0, /*
444
+ − 1044 Return the nearest integer to NUMBER.
428
+ − 1045 */
444
+ − 1046 (number))
428
+ − 1047 {
444
+ − 1048 if (FLOATP (number))
428
+ − 1049 {
+ − 1050 double d;
+ − 1051 /* Screw the prevailing rounding mode. */
444
+ − 1052 IN_FLOAT ((d = emacs_rint (XFLOAT_DATA (number))), "round", number);
+ − 1053 return (float_to_int (d, "round", number, Qunbound));
428
+ − 1054 }
+ − 1055
1983
+ − 1056 #ifdef HAVE_BIGNUM
+ − 1057 if (INTEGERP (number))
+ − 1058 #else
444
+ − 1059 if (INTP (number))
1983
+ − 1060 #endif
444
+ − 1061 return number;
428
+ − 1062
1983
+ − 1063 #ifdef HAVE_RATIO
+ − 1064 if (RATIOP (number))
+ − 1065 {
+ − 1066 if (bignum_divisible_p (XRATIO_NUMERATOR (number),
+ − 1067 XRATIO_DENOMINATOR (number)))
+ − 1068 {
+ − 1069 bignum_div (scratch_bignum, XRATIO_NUMERATOR (number),
+ − 1070 XRATIO_DENOMINATOR (number));
+ − 1071 }
+ − 1072 else
+ − 1073 {
+ − 1074 bignum_add (scratch_bignum2, XRATIO_NUMERATOR (number),
+ − 1075 XRATIO_DENOMINATOR (number));
+ − 1076 bignum_div (scratch_bignum, scratch_bignum2,
+ − 1077 XRATIO_DENOMINATOR (number));
+ − 1078 }
+ − 1079 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ − 1080 }
+ − 1081 #endif
+ − 1082
+ − 1083 #ifdef HAVE_BIGFLOAT
+ − 1084 if (BIGFLOATP (number))
+ − 1085 {
+ − 1086 unsigned long prec = XBIGFLOAT_GET_PREC (number);
+ − 1087 bigfloat_set_prec (scratch_bigfloat, prec);
+ − 1088 bigfloat_set_prec (scratch_bigfloat2, prec);
+ − 1089 bigfloat_set_double (scratch_bigfloat2,
+ − 1090 bigfloat_sign (XBIGFLOAT_DATA (number)) * 0.5);
+ − 1091 bigfloat_floor (scratch_bigfloat, scratch_bigfloat2);
+ − 1092 #ifdef HAVE_BIGNUM
+ − 1093 bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
+ − 1094 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ − 1095 #else
+ − 1096 return make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
+ − 1097 #endif /* HAVE_BIGNUM */
+ − 1098 }
+ − 1099 #endif /* HAVE_BIGFLOAT */
+ − 1100
444
+ − 1101 return Fround (wrong_type_argument (Qnumberp, number));
428
+ − 1102 }
+ − 1103
+ − 1104 DEFUN ("truncate", Ftruncate, 1, 1, 0, /*
+ − 1105 Truncate a floating point number to an integer.
+ − 1106 Rounds the value toward zero.
+ − 1107 */
444
+ − 1108 (number))
428
+ − 1109 {
444
+ − 1110 if (FLOATP (number))
+ − 1111 return float_to_int (XFLOAT_DATA (number), "truncate", number, Qunbound);
428
+ − 1112
1983
+ − 1113 #ifdef HAVE_BIGNUM
+ − 1114 if (INTEGERP (number))
+ − 1115 #else
444
+ − 1116 if (INTP (number))
1983
+ − 1117 #endif
444
+ − 1118 return number;
428
+ − 1119
1983
+ − 1120 #ifdef HAVE_RATIO
+ − 1121 if (RATIOP (number))
+ − 1122 {
+ − 1123 bignum_div (scratch_bignum, XRATIO_NUMERATOR (number),
+ − 1124 XRATIO_DENOMINATOR (number));
+ − 1125 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ − 1126 }
+ − 1127 #endif
+ − 1128
+ − 1129 #ifdef HAVE_BIGFLOAT
+ − 1130 if (BIGFLOATP (number))
+ − 1131 {
+ − 1132 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
+ − 1133 bigfloat_trunc (scratch_bigfloat, XBIGFLOAT_DATA (number));
+ − 1134 #ifdef HAVE_BIGNUM
+ − 1135 bignum_set_bigfloat (scratch_bignum, scratch_bigfloat);
+ − 1136 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ − 1137 #else
+ − 1138 return make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat));
+ − 1139 #endif /* HAVE_BIGNUM */
+ − 1140 }
+ − 1141 #endif /* HAVE_BIGFLOAT */
+ − 1142
444
+ − 1143 return Ftruncate (wrong_type_argument (Qnumberp, number));
428
+ − 1144 }
+ − 1145
+ − 1146 /* Float-rounding functions. */
+ − 1147
+ − 1148 DEFUN ("fceiling", Ffceiling, 1, 1, 0, /*
444
+ − 1149 Return the smallest integer no less than NUMBER, as a float.
428
+ − 1150 \(Round toward +inf.\)
+ − 1151 */
444
+ − 1152 (number))
428
+ − 1153 {
444
+ − 1154 double d = extract_float (number);
+ − 1155 IN_FLOAT (d = ceil (d), "fceiling", number);
428
+ − 1156 return make_float (d);
+ − 1157 }
+ − 1158
+ − 1159 DEFUN ("ffloor", Fffloor, 1, 1, 0, /*
444
+ − 1160 Return the largest integer no greater than NUMBER, as a float.
428
+ − 1161 \(Round towards -inf.\)
+ − 1162 */
444
+ − 1163 (number))
428
+ − 1164 {
444
+ − 1165 double d = extract_float (number);
+ − 1166 IN_FLOAT (d = floor (d), "ffloor", number);
428
+ − 1167 return make_float (d);
+ − 1168 }
+ − 1169
+ − 1170 DEFUN ("fround", Ffround, 1, 1, 0, /*
444
+ − 1171 Return the nearest integer to NUMBER, as a float.
428
+ − 1172 */
444
+ − 1173 (number))
428
+ − 1174 {
444
+ − 1175 double d = extract_float (number);
+ − 1176 IN_FLOAT (d = emacs_rint (d), "fround", number);
428
+ − 1177 return make_float (d);
+ − 1178 }
+ − 1179
+ − 1180 DEFUN ("ftruncate", Fftruncate, 1, 1, 0, /*
+ − 1181 Truncate a floating point number to an integral float value.
+ − 1182 Rounds the value toward zero.
+ − 1183 */
444
+ − 1184 (number))
428
+ − 1185 {
444
+ − 1186 double d = extract_float (number);
428
+ − 1187 if (d >= 0.0)
444
+ − 1188 IN_FLOAT (d = floor (d), "ftruncate", number);
428
+ − 1189 else
444
+ − 1190 IN_FLOAT (d = ceil (d), "ftruncate", number);
428
+ − 1191 return make_float (d);
+ − 1192 }
+ − 1193
+ − 1194 #ifdef FLOAT_CATCH_SIGILL
+ − 1195 static SIGTYPE
+ − 1196 float_error (int signo)
+ − 1197 {
+ − 1198 if (! in_float)
+ − 1199 fatal_error_signal (signo);
+ − 1200
+ − 1201 EMACS_REESTABLISH_SIGNAL (signo, arith_error);
+ − 1202 EMACS_UNBLOCK_SIGNAL (signo);
+ − 1203
+ − 1204 in_float = 0;
+ − 1205
+ − 1206 /* Was Fsignal(), but it just doesn't make sense for an error
+ − 1207 occurring inside a signal handler to be restartable, considering
+ − 1208 that anything could happen when the error is signaled and trapped
+ − 1209 and considering the asynchronous nature of signal handlers. */
563
+ − 1210 signal_error (Qarith_error, 0, float_error_arg);
428
+ − 1211 }
+ − 1212
+ − 1213 /* Another idea was to replace the library function `infnan'
+ − 1214 where SIGILL is signaled. */
+ − 1215
+ − 1216 #endif /* FLOAT_CATCH_SIGILL */
+ − 1217
+ − 1218 /* In C++, it is impossible to determine what type matherr expects
+ − 1219 without some more configure magic.
+ − 1220 We shouldn't be using matherr anyways - it's a non-standard SYSVism. */
+ − 1221 #if defined (HAVE_MATHERR) && !defined(__cplusplus)
+ − 1222 int
+ − 1223 matherr (struct exception *x)
+ − 1224 {
+ − 1225 Lisp_Object args;
+ − 1226 if (! in_float)
+ − 1227 /* Not called from emacs-lisp float routines; do the default thing. */
+ − 1228 return 0;
+ − 1229
+ − 1230 /* if (!strcmp (x->name, "pow")) x->name = "expt"; */
+ − 1231
+ − 1232 args = Fcons (build_string (x->name),
+ − 1233 Fcons (make_float (x->arg1),
+ − 1234 ((in_float == 2)
+ − 1235 ? Fcons (make_float (x->arg2), Qnil)
+ − 1236 : Qnil)));
+ − 1237 switch (x->type)
+ − 1238 {
+ − 1239 case DOMAIN: Fsignal (Qdomain_error, args); break;
+ − 1240 case SING: Fsignal (Qsingularity_error, args); break;
+ − 1241 case OVERFLOW: Fsignal (Qoverflow_error, args); break;
+ − 1242 case UNDERFLOW: Fsignal (Qunderflow_error, args); break;
+ − 1243 default: Fsignal (Qarith_error, args); break;
+ − 1244 }
+ − 1245 return 1; /* don't set errno or print a message */
+ − 1246 }
+ − 1247 #endif /* HAVE_MATHERR */
+ − 1248
+ − 1249 void
+ − 1250 init_floatfns_very_early (void)
+ − 1251 {
+ − 1252 # ifdef FLOAT_CATCH_SIGILL
613
+ − 1253 EMACS_SIGNAL (SIGILL, float_error);
428
+ − 1254 # endif
+ − 1255 in_float = 0;
+ − 1256 }
+ − 1257
+ − 1258 void
+ − 1259 syms_of_floatfns (void)
+ − 1260 {
442
+ − 1261 INIT_LRECORD_IMPLEMENTATION (float);
428
+ − 1262
+ − 1263 /* Trig functions. */
+ − 1264
+ − 1265 DEFSUBR (Facos);
+ − 1266 DEFSUBR (Fasin);
+ − 1267 DEFSUBR (Fatan);
+ − 1268 DEFSUBR (Fcos);
+ − 1269 DEFSUBR (Fsin);
+ − 1270 DEFSUBR (Ftan);
+ − 1271
+ − 1272 /* Bessel functions */
+ − 1273
+ − 1274 #if 0
+ − 1275 DEFSUBR (Fbessel_y0);
+ − 1276 DEFSUBR (Fbessel_y1);
+ − 1277 DEFSUBR (Fbessel_yn);
+ − 1278 DEFSUBR (Fbessel_j0);
+ − 1279 DEFSUBR (Fbessel_j1);
+ − 1280 DEFSUBR (Fbessel_jn);
+ − 1281 #endif /* 0 */
+ − 1282
+ − 1283 /* Error functions. */
+ − 1284
+ − 1285 #if 0
+ − 1286 DEFSUBR (Ferf);
+ − 1287 DEFSUBR (Ferfc);
+ − 1288 DEFSUBR (Flog_gamma);
+ − 1289 #endif /* 0 */
+ − 1290
+ − 1291 /* Root and Log functions. */
+ − 1292
+ − 1293 DEFSUBR (Fexp);
+ − 1294 DEFSUBR (Fexpt);
+ − 1295 DEFSUBR (Flog);
+ − 1296 DEFSUBR (Flog10);
+ − 1297 DEFSUBR (Fsqrt);
+ − 1298 DEFSUBR (Fcube_root);
+ − 1299
+ − 1300 /* Inverse trig functions. */
+ − 1301
+ − 1302 DEFSUBR (Facosh);
+ − 1303 DEFSUBR (Fasinh);
+ − 1304 DEFSUBR (Fatanh);
+ − 1305 DEFSUBR (Fcosh);
+ − 1306 DEFSUBR (Fsinh);
+ − 1307 DEFSUBR (Ftanh);
+ − 1308
+ − 1309 /* Rounding functions */
+ − 1310
+ − 1311 DEFSUBR (Fabs);
+ − 1312 DEFSUBR (Ffloat);
+ − 1313 DEFSUBR (Flogb);
+ − 1314 DEFSUBR (Fceiling);
+ − 1315 DEFSUBR (Ffloor);
+ − 1316 DEFSUBR (Fround);
+ − 1317 DEFSUBR (Ftruncate);
+ − 1318
+ − 1319 /* Float-rounding functions. */
+ − 1320
+ − 1321 DEFSUBR (Ffceiling);
+ − 1322 DEFSUBR (Fffloor);
+ − 1323 DEFSUBR (Ffround);
+ − 1324 DEFSUBR (Fftruncate);
+ − 1325 }
+ − 1326
+ − 1327 void
+ − 1328 vars_of_floatfns (void)
+ − 1329 {
+ − 1330 Fprovide (intern ("lisp-float-type"));
+ − 1331 }
