-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+ * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012,
+ * 2013 Free Software Foundation, Inc.
*
* Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
* and Bellcore. See scm_divide.
#endif
#include <verify.h>
+#include <assert.h>
#include <math.h>
#include <string.h>
#include <complex.h>
#endif
+#include <stdarg.h>
+
#include "libguile/_scm.h"
#include "libguile/feature.h"
#include "libguile/ports.h"
typedef scm_t_signed_bits scm_t_inum;
#define scm_from_inum(x) (scm_from_signed_integer (x))
-/* Tests to see if a C double is neither infinite nor a NaN.
- TODO: if it's available, use C99's isfinite(x) instead */
-#define DOUBLE_IS_FINITE(x) (!isinf(x) && !isnan(x))
+/* Test an inum to see if it can be converted to a double without loss
+ of precision. Note that this will sometimes return 0 even when 1
+ could have been returned, e.g. for large powers of 2. It is designed
+ to be a fast check to optimize common cases. */
+#define INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE(n) \
+ (SCM_I_FIXNUM_BIT-1 <= DBL_MANT_DIG \
+ || ((n) ^ ((n) >> (SCM_I_FIXNUM_BIT-1))) < (1L << DBL_MANT_DIG))
+
+#if ! HAVE_DECL_MPZ_INITS
+
+/* GMP < 5.0.0 lacks `mpz_inits' and `mpz_clears'. Provide them. */
+
+#define VARARG_MPZ_ITERATOR(func) \
+ static void \
+ func ## s (mpz_t x, ...) \
+ { \
+ va_list ap; \
+ \
+ va_start (ap, x); \
+ while (x != NULL) \
+ { \
+ func (x); \
+ x = va_arg (ap, mpz_ptr); \
+ } \
+ va_end (ap); \
+ }
+
+VARARG_MPZ_ITERATOR (mpz_init)
+VARARG_MPZ_ITERATOR (mpz_clear)
-/* On some platforms, isinf(x) returns 0, 1 or -1, indicating the sign
- of the infinity, but other platforms return a boolean only. */
-#define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
-#define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0))
+#endif
\f
}
}
-/* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
-static SCM scm_divide2real (SCM x, SCM y);
-
/* Make the ratio NUMERATOR/DENOMINATOR, where:
1. NUMERATOR and DENOMINATOR are exact integers
2. NUMERATOR and DENOMINATOR are reduced to lowest terms: gcd(n,d) == 1 */
}
#undef FUNC_NAME
+static mpz_t scm_i_divide2double_lo2b;
+
+/* Return the double that is closest to the exact rational N/D, with
+ ties rounded toward even mantissas. N and D must be exact
+ integers. */
+static double
+scm_i_divide2double (SCM n, SCM d)
+{
+ int neg;
+ mpz_t nn, dd, lo, hi, x;
+ ssize_t e;
+
+ if (SCM_LIKELY (SCM_I_INUMP (d)))
+ {
+ if (SCM_LIKELY
+ (SCM_I_INUMP (n)
+ && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (n))
+ && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (d))))
+ /* If both N and D can be losslessly converted to doubles, then
+ we can rely on IEEE floating point to do proper rounding much
+ faster than we can. */
+ return ((double) SCM_I_INUM (n)) / ((double) SCM_I_INUM (d));
+
+ if (SCM_UNLIKELY (scm_is_eq (d, SCM_INUM0)))
+ {
+ if (scm_is_true (scm_positive_p (n)))
+ return 1.0 / 0.0;
+ else if (scm_is_true (scm_negative_p (n)))
+ return -1.0 / 0.0;
+ else
+ return 0.0 / 0.0;
+ }
+
+ mpz_init_set_si (dd, SCM_I_INUM (d));
+ }
+ else
+ mpz_init_set (dd, SCM_I_BIG_MPZ (d));
+
+ if (SCM_I_INUMP (n))
+ mpz_init_set_si (nn, SCM_I_INUM (n));
+ else
+ mpz_init_set (nn, SCM_I_BIG_MPZ (n));
+
+ neg = (mpz_sgn (nn) < 0) ^ (mpz_sgn (dd) < 0);
+ mpz_abs (nn, nn);
+ mpz_abs (dd, dd);
+
+ /* Now we need to find the value of e such that:
+
+ For e <= 0:
+ b^{p-1} - 1/2b <= b^-e n / d < b^p - 1/2 [1A]
+ (2 b^p - 1) <= 2 b b^-e n / d < (2 b^p - 1) b [2A]
+ (2 b^p - 1) d <= 2 b b^-e n < (2 b^p - 1) d b [3A]
+
+ For e >= 0:
+ b^{p-1} - 1/2b <= n / b^e d < b^p - 1/2 [1B]
+ (2 b^p - 1) <= 2 b n / b^e d < (2 b^p - 1) b [2B]
+ (2 b^p - 1) d b^e <= 2 b n < (2 b^p - 1) d b b^e [3B]
+
+ where: p = DBL_MANT_DIG
+ b = FLT_RADIX (here assumed to be 2)
+
+ After rounding, the mantissa must be an integer between b^{p-1} and
+ (b^p - 1), except for subnormal numbers. In the inequations [1A]
+ and [1B], the middle expression represents the mantissa *before*
+ rounding, and therefore is bounded by the range of values that will
+ round to a floating-point number with the exponent e. The upper
+ bound is (b^p - 1 + 1/2) = (b^p - 1/2), and is exclusive because
+ ties will round up to the next power of b. The lower bound is
+ (b^{p-1} - 1/2b), and is inclusive because ties will round toward
+ this power of b. Here we subtract 1/2b instead of 1/2 because it
+ is in the range of the next smaller exponent, where the
+ representable numbers are closer together by a factor of b.
+
+ Inequations [2A] and [2B] are derived from [1A] and [1B] by
+ multiplying by 2b, and in [3A] and [3B] we multiply by the
+ denominator of the middle value to obtain integer expressions.
+
+ In the code below, we refer to the three expressions in [3A] or
+ [3B] as lo, x, and hi. If the number is normalizable, we will
+ achieve the goal: lo <= x < hi */
+
+ /* Make an initial guess for e */
+ e = mpz_sizeinbase (nn, 2) - mpz_sizeinbase (dd, 2) - (DBL_MANT_DIG-1);
+ if (e < DBL_MIN_EXP - DBL_MANT_DIG)
+ e = DBL_MIN_EXP - DBL_MANT_DIG;
+
+ /* Compute the initial values of lo, x, and hi
+ based on the initial guess of e */
+ mpz_inits (lo, hi, x, NULL);
+ mpz_mul_2exp (x, nn, 2 + ((e < 0) ? -e : 0));
+ mpz_mul (lo, dd, scm_i_divide2double_lo2b);
+ if (e > 0)
+ mpz_mul_2exp (lo, lo, e);
+ mpz_mul_2exp (hi, lo, 1);
+
+ /* Adjust e as needed to satisfy the inequality lo <= x < hi,
+ (but without making e less then the minimum exponent) */
+ while (mpz_cmp (x, lo) < 0 && e > DBL_MIN_EXP - DBL_MANT_DIG)
+ {
+ mpz_mul_2exp (x, x, 1);
+ e--;
+ }
+ while (mpz_cmp (x, hi) >= 0)
+ {
+ /* If we ever used lo's value again,
+ we would need to double lo here. */
+ mpz_mul_2exp (hi, hi, 1);
+ e++;
+ }
+
+ /* Now compute the rounded mantissa:
+ n / b^e d (if e >= 0)
+ n b^-e / d (if e <= 0) */
+ {
+ int cmp;
+ double result;
+
+ if (e < 0)
+ mpz_mul_2exp (nn, nn, -e);
+ else
+ mpz_mul_2exp (dd, dd, e);
+
+ /* mpz does not directly support rounded right
+ shifts, so we have to do it the hard way.
+ For efficiency, we reuse lo and hi.
+ hi == quotient, lo == remainder */
+ mpz_fdiv_qr (hi, lo, nn, dd);
+
+ /* The fractional part of the unrounded mantissa would be
+ remainder/dividend, i.e. lo/dd. So we have a tie if
+ lo/dd = 1/2. Multiplying both sides by 2*dd yields the
+ integer expression 2*lo = dd. Here we do that comparison
+ to decide whether to round up or down. */
+ mpz_mul_2exp (lo, lo, 1);
+ cmp = mpz_cmp (lo, dd);
+ if (cmp > 0 || (cmp == 0 && mpz_odd_p (hi)))
+ mpz_add_ui (hi, hi, 1);
+
+ result = ldexp (mpz_get_d (hi), e);
+ if (neg)
+ result = -result;
+
+ mpz_clears (nn, dd, lo, hi, x, NULL);
+ return result;
+ }
+}
+
double
scm_i_fraction2double (SCM z)
{
- return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z),
- SCM_FRACTION_DENOMINATOR (z)));
+ return scm_i_divide2double (SCM_FRACTION_NUMERATOR (z),
+ SCM_FRACTION_DENOMINATOR (z));
}
-static int
-double_is_non_negative_zero (double x)
+static SCM
+scm_i_from_double (double val)
{
- static double zero = 0.0;
+ SCM z;
+
+ z = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double), "real"));
- return !memcmp (&x, &zero, sizeof(double));
+ SCM_SET_CELL_TYPE (z, scm_tc16_real);
+ SCM_REAL_VALUE (z) = val;
+
+ return z;
}
SCM_PRIMITIVE_GENERIC (scm_exact_p, "exact?", 1, 0, 0,
else if (SCM_REALP (n))
{
double val = SCM_REAL_VALUE (n);
- if (DOUBLE_IS_FINITE (val))
+ if (isfinite (val))
{
double rem = fabs (fmod (val, 2.0));
if (rem == 1.0)
else if (SCM_REALP (n))
{
double val = SCM_REAL_VALUE (n);
- if (DOUBLE_IS_FINITE (val))
+ if (isfinite (val))
{
double rem = fabs (fmod (val, 2.0));
if (rem == 1.0)
#define FUNC_NAME s_scm_finite_p
{
if (SCM_REALP (x))
- return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x)));
+ return scm_from_bool (isfinite (SCM_REAL_VALUE (x)));
else if (scm_is_real (x))
return SCM_BOOL_T;
else
guile_ieee_init ();
initialized = 1;
}
- return scm_from_double (guile_Inf);
+ return scm_i_from_double (guile_Inf);
}
#undef FUNC_NAME
guile_ieee_init ();
initialized = 1;
}
- return scm_from_double (guile_NaN);
+ return scm_i_from_double (guile_NaN);
}
#undef FUNC_NAME
double xx = SCM_REAL_VALUE (x);
/* If x is a NaN then xx<0 is false so we return x unchanged */
if (xx < 0.0)
- return scm_from_double (-xx);
+ return scm_i_from_double (-xx);
/* Handle signed zeroes properly */
else if (SCM_UNLIKELY (xx == 0.0))
return flo0;
if (SCM_UNLIKELY (y == 0))
scm_num_overflow (s_scm_floor_quotient); /* or return a NaN? */
else
- return scm_from_double (floor (x / y));
+ return scm_i_from_double (floor (x / y));
}
static SCM
if (SCM_UNLIKELY (y == 0))
scm_num_overflow (s_scm_floor_remainder); /* or return a NaN? */
else
- return scm_from_double (x - y * floor (x / y));
+ return scm_i_from_double (x - y * floor (x / y));
}
static SCM
{
double q = floor (x / y);
double r = x - q * y;
- *qp = scm_from_double (q);
- *rp = scm_from_double (r);
+ *qp = scm_i_from_double (q);
+ *rp = scm_i_from_double (r);
}
}
if (SCM_UNLIKELY (y == 0))
scm_num_overflow (s_scm_ceiling_quotient); /* or return a NaN? */
else
- return scm_from_double (ceil (x / y));
+ return scm_i_from_double (ceil (x / y));
}
static SCM
if (SCM_UNLIKELY (y == 0))
scm_num_overflow (s_scm_ceiling_remainder); /* or return a NaN? */
else
- return scm_from_double (x - y * ceil (x / y));
+ return scm_i_from_double (x - y * ceil (x / y));
}
static SCM
{
double q = ceil (x / y);
double r = x - q * y;
- *qp = scm_from_double (q);
- *rp = scm_from_double (r);
+ *qp = scm_i_from_double (q);
+ *rp = scm_i_from_double (r);
}
}
if (SCM_UNLIKELY (y == 0))
scm_num_overflow (s_scm_truncate_quotient); /* or return a NaN? */
else
- return scm_from_double (trunc (x / y));
+ return scm_i_from_double (trunc (x / y));
}
static SCM
if (SCM_UNLIKELY (y == 0))
scm_num_overflow (s_scm_truncate_remainder); /* or return a NaN? */
else
- return scm_from_double (x - y * trunc (x / y));
+ return scm_i_from_double (x - y * trunc (x / y));
}
static SCM
{
double q = trunc (x / y);
double r = x - q * y;
- *qp = scm_from_double (q);
- *rp = scm_from_double (r);
+ *qp = scm_i_from_double (q);
+ *rp = scm_i_from_double (r);
}
}
scm_i_inexact_centered_quotient (double x, double y)
{
if (SCM_LIKELY (y > 0))
- return scm_from_double (floor (x/y + 0.5));
+ return scm_i_from_double (floor (x/y + 0.5));
else if (SCM_LIKELY (y < 0))
- return scm_from_double (ceil (x/y - 0.5));
+ return scm_i_from_double (ceil (x/y - 0.5));
else if (y == 0)
scm_num_overflow (s_scm_centered_quotient); /* or return a NaN? */
else
scm_num_overflow (s_scm_centered_remainder); /* or return a NaN? */
else
return scm_nan ();
- return scm_from_double (x - q * y);
+ return scm_i_from_double (x - q * y);
}
/* Assumes that both x and y are bigints, though
else
q = guile_NaN;
r = x - q * y;
- *qp = scm_from_double (q);
- *rp = scm_from_double (r);
+ *qp = scm_i_from_double (q);
+ *rp = scm_i_from_double (r);
}
/* Assumes that both x and y are bigints, though
if (SCM_UNLIKELY (y == 0))
scm_num_overflow (s_scm_round_quotient); /* or return a NaN? */
else
- return scm_from_double (scm_c_round (x / y));
+ return scm_i_from_double (scm_c_round (x / y));
}
/* Assumes that both x and y are bigints, though
else
{
double q = scm_c_round (x / y);
- return scm_from_double (x - q * y);
+ return scm_i_from_double (x - q * y);
}
}
{
double q = scm_c_round (x / y);
double r = x - q * y;
- *qp = scm_from_double (q);
- *rp = scm_from_double (r);
+ *qp = scm_i_from_double (q);
+ *rp = scm_i_from_double (r);
}
}
SCM_SWAP (x, y);
goto big_inum;
}
+ else if (SCM_REALP (y) && scm_is_integer (y))
+ goto handle_inexacts;
else
SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
}
scm_remember_upto_here_2 (x, y);
return scm_i_normbig (result);
}
+ else if (SCM_REALP (y) && scm_is_integer (y))
+ goto handle_inexacts;
+ else
+ SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
+ }
+ else if (SCM_REALP (x) && scm_is_integer (x))
+ {
+ if (SCM_I_INUMP (y) || SCM_BIGP (y)
+ || (SCM_REALP (y) && scm_is_integer (y)))
+ {
+ handle_inexacts:
+ return scm_exact_to_inexact (scm_gcd (scm_inexact_to_exact (x),
+ scm_inexact_to_exact (y)));
+ }
else
SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
}
SCM
scm_lcm (SCM n1, SCM n2)
{
- if (SCM_UNBNDP (n2))
- {
- if (SCM_UNBNDP (n1))
- return SCM_I_MAKINUM (1L);
- n2 = SCM_I_MAKINUM (1L);
- }
-
- SCM_GASSERT2 (SCM_I_INUMP (n1) || SCM_BIGP (n1),
- g_lcm, n1, n2, SCM_ARG1, s_lcm);
- SCM_GASSERT2 (SCM_I_INUMP (n2) || SCM_BIGP (n2),
- g_lcm, n1, n2, SCM_ARGn, s_lcm);
+ if (SCM_UNLIKELY (SCM_UNBNDP (n2)))
+ return SCM_UNBNDP (n1) ? SCM_INUM1 : scm_abs (n1);
- if (SCM_I_INUMP (n1))
+ if (SCM_LIKELY (SCM_I_INUMP (n1)))
{
- if (SCM_I_INUMP (n2))
+ if (SCM_LIKELY (SCM_I_INUMP (n2)))
{
SCM d = scm_gcd (n1, n2);
if (scm_is_eq (d, SCM_INUM0))
else
return scm_abs (scm_product (n1, scm_quotient (n2, d)));
}
- else
+ else if (SCM_LIKELY (SCM_BIGP (n2)))
{
/* inum n1, big n2 */
inumbig:
return result;
}
}
+ else if (SCM_REALP (n2) && scm_is_integer (n2))
+ goto handle_inexacts;
+ else
+ SCM_WTA_DISPATCH_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
}
- else
+ else if (SCM_LIKELY (SCM_BIGP (n1)))
{
/* big n1 */
if (SCM_I_INUMP (n2))
SCM_SWAP (n1, n2);
goto inumbig;
}
- else
+ else if (SCM_LIKELY (SCM_BIGP (n2)))
{
SCM result = scm_i_mkbig ();
mpz_lcm(SCM_I_BIG_MPZ (result),
/* shouldn't need to normalize b/c lcm of 2 bigs should be big */
return result;
}
+ else if (SCM_REALP (n2) && scm_is_integer (n2))
+ goto handle_inexacts;
+ else
+ SCM_WTA_DISPATCH_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
+ }
+ else if (SCM_REALP (n1) && scm_is_integer (n1))
+ {
+ if (SCM_I_INUMP (n2) || SCM_BIGP (n2)
+ || (SCM_REALP (n2) && scm_is_integer (n2)))
+ {
+ handle_inexacts:
+ return scm_exact_to_inexact (scm_lcm (scm_inexact_to_exact (n1),
+ scm_inexact_to_exact (n2)));
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
}
+ else
+ SCM_WTA_DISPATCH_2 (g_lcm, n1, n2, SCM_ARG1, s_lcm);
}
/* Emulating 2's complement bignums with sign magnitude arithmetic:
{
scm_t_inum nn = SCM_I_INUM (n);
- /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will always
+ /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will almost[*] always
overflow a non-zero fixnum. For smaller shifts we check the
bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
- Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)". */
+ Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)".
+
+ [*] There's one exception:
+ (-1) << SCM_I_FIXNUM_BIT-1 == SCM_MOST_NEGATIVE_FIXNUM */
if (nn == 0)
return n;
SCM result = scm_i_inum2big (nn);
mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
count);
- return result;
- }
+ return scm_i_normbig (result);
+ }
}
else if (SCM_BIGP (n))
{
return result;
}
else
- scm_syserror ("left_shift_exact_integer");
+ assert (0);
}
/* Efficiently compute floor (N / 2^COUNT),
return scm_i_normbig (result);
}
else
- scm_syserror ("floor_right_shift_exact_integer");
+ assert (0);
}
/* Efficiently compute round (N / 2^COUNT),
return scm_i_normbig (q);
}
else
- scm_syserror ("round_right_shift_exact_integer");
+ assert (0);
}
SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
#undef FUNC_NAME
/*** NUMBERS -> STRINGS ***/
-#define SCM_MAX_DBL_PREC 60
#define SCM_MAX_DBL_RADIX 36
-/* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
-static int scm_dblprec[SCM_MAX_DBL_RADIX - 1];
-static double fx_per_radix[SCM_MAX_DBL_RADIX - 1][SCM_MAX_DBL_PREC];
-
-static
-void init_dblprec(int *prec, int radix) {
- /* determine floating point precision by adding successively
- smaller increments to 1.0 until it is considered == 1.0 */
- double f = ((double)1.0)/radix;
- double fsum = 1.0 + f;
-
- *prec = 0;
- while (fsum != 1.0)
- {
- if (++(*prec) > SCM_MAX_DBL_PREC)
- fsum = 1.0;
- else
- {
- f /= radix;
- fsum = f + 1.0;
- }
- }
- (*prec) -= 1;
-}
-
-static
-void init_fx_radix(double *fx_list, int radix)
-{
- /* initialize a per-radix list of tolerances. When added
- to a number < 1.0, we can determine if we should raund
- up and quit converting a number to a string. */
- int i;
- fx_list[0] = 0.0;
- fx_list[1] = 0.5;
- for( i = 2 ; i < SCM_MAX_DBL_PREC; ++i )
- fx_list[i] = (fx_list[i-1] / radix);
-}
-
/* use this array as a way to generate a single digit */
static const char number_chars[] = "0123456789abcdefghijklmnopqrstuvwxyz";
+static mpz_t dbl_minimum_normal_mantissa;
+
static size_t
-idbl2str (double f, char *a, int radix)
+idbl2str (double dbl, char *a, int radix)
{
- int efmt, dpt, d, i, wp;
- double *fx;
-#ifdef DBL_MIN_10_EXP
- double f_cpy;
- int exp_cpy;
-#endif /* DBL_MIN_10_EXP */
- size_t ch = 0;
- int exp = 0;
-
- if(radix < 2 ||
- radix > SCM_MAX_DBL_RADIX)
- {
- /* revert to existing behavior */
- radix = 10;
- }
+ int ch = 0;
- wp = scm_dblprec[radix-2];
- fx = fx_per_radix[radix-2];
+ if (radix < 2 || radix > SCM_MAX_DBL_RADIX)
+ /* revert to existing behavior */
+ radix = 10;
- if (f == 0.0)
+ if (isinf (dbl))
{
-#ifdef HAVE_COPYSIGN
- double sgn = copysign (1.0, f);
-
- if (sgn < 0.0)
- a[ch++] = '-';
-#endif
- goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
+ strcpy (a, (dbl > 0.0) ? "+inf.0" : "-inf.0");
+ return 6;
}
-
- if (isinf (f))
+ else if (dbl > 0.0)
+ ;
+ else if (dbl < 0.0)
{
- if (f < 0)
- strcpy (a, "-inf.0");
- else
- strcpy (a, "+inf.0");
- return ch+6;
+ dbl = -dbl;
+ a[ch++] = '-';
}
- else if (isnan (f))
+ else if (dbl == 0.0)
{
- strcpy (a, "+nan.0");
- return ch+6;
+ if (copysign (1.0, dbl) < 0.0)
+ a[ch++] = '-';
+ strcpy (a + ch, "0.0");
+ return ch + 3;
}
-
- if (f < 0.0)
+ else if (isnan (dbl))
{
- f = -f;
- a[ch++] = '-';
+ strcpy (a, "+nan.0");
+ return 6;
}
-#ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
- make-uniform-vector, from causing infinite loops. */
- /* just do the checking...if it passes, we do the conversion for our
- radix again below */
- f_cpy = f;
- exp_cpy = exp;
+ /* Algorithm taken from "Printing Floating-Point Numbers Quickly and
+ Accurately" by Robert G. Burger and R. Kent Dybvig */
+ {
+ int e, k;
+ mpz_t f, r, s, mplus, mminus, hi, digit;
+ int f_is_even, f_is_odd;
+ int expon;
+ int show_exp = 0;
+
+ mpz_inits (f, r, s, mplus, mminus, hi, digit, NULL);
+ mpz_set_d (f, ldexp (frexp (dbl, &e), DBL_MANT_DIG));
+ if (e < DBL_MIN_EXP)
+ {
+ mpz_tdiv_q_2exp (f, f, DBL_MIN_EXP - e);
+ e = DBL_MIN_EXP;
+ }
+ e -= DBL_MANT_DIG;
- while (f_cpy < 1.0)
- {
- f_cpy *= 10.0;
- if (exp_cpy-- < DBL_MIN_10_EXP)
- {
- a[ch++] = '#';
- a[ch++] = '.';
- a[ch++] = '#';
- return ch;
- }
- }
- while (f_cpy > 10.0)
- {
- f_cpy *= 0.10;
- if (exp_cpy++ > DBL_MAX_10_EXP)
- {
- a[ch++] = '#';
- a[ch++] = '.';
- a[ch++] = '#';
- return ch;
- }
- }
-#endif
+ f_is_even = !mpz_odd_p (f);
+ f_is_odd = !f_is_even;
- while (f < 1.0)
- {
- f *= radix;
- exp--;
- }
- while (f > radix)
- {
- f /= radix;
- exp++;
- }
+ /* Initialize r, s, mplus, and mminus according
+ to Table 1 from the paper. */
+ if (e < 0)
+ {
+ mpz_set_ui (mminus, 1);
+ if (mpz_cmp (f, dbl_minimum_normal_mantissa) != 0
+ || e == DBL_MIN_EXP - DBL_MANT_DIG)
+ {
+ mpz_set_ui (mplus, 1);
+ mpz_mul_2exp (r, f, 1);
+ mpz_mul_2exp (s, mminus, 1 - e);
+ }
+ else
+ {
+ mpz_set_ui (mplus, 2);
+ mpz_mul_2exp (r, f, 2);
+ mpz_mul_2exp (s, mminus, 2 - e);
+ }
+ }
+ else
+ {
+ mpz_set_ui (mminus, 1);
+ mpz_mul_2exp (mminus, mminus, e);
+ if (mpz_cmp (f, dbl_minimum_normal_mantissa) != 0)
+ {
+ mpz_set (mplus, mminus);
+ mpz_mul_2exp (r, f, 1 + e);
+ mpz_set_ui (s, 2);
+ }
+ else
+ {
+ mpz_mul_2exp (mplus, mminus, 1);
+ mpz_mul_2exp (r, f, 2 + e);
+ mpz_set_ui (s, 4);
+ }
+ }
- if (f + fx[wp] >= radix)
+ /* Find the smallest k such that:
+ (r + mplus) / s < radix^k (if f is even)
+ (r + mplus) / s <= radix^k (if f is odd) */
{
- f = 1.0;
- exp++;
- }
- zero:
-#ifdef ENGNOT
- /* adding 9999 makes this equivalent to abs(x) % 3 */
- dpt = (exp + 9999) % 3;
- exp -= dpt++;
- efmt = 1;
-#else
- efmt = (exp < -3) || (exp > wp + 2);
- if (!efmt)
- {
- if (exp < 0)
- {
- a[ch++] = '0';
- a[ch++] = '.';
- dpt = exp;
- while (++dpt)
- a[ch++] = '0';
- }
- else
- dpt = exp + 1;
+ /* IMPROVE-ME: Make an initial guess to speed this up */
+ mpz_add (hi, r, mplus);
+ k = 0;
+ while (mpz_cmp (hi, s) >= f_is_odd)
+ {
+ mpz_mul_ui (s, s, radix);
+ k++;
+ }
+ if (k == 0)
+ {
+ mpz_mul_ui (hi, hi, radix);
+ while (mpz_cmp (hi, s) < f_is_odd)
+ {
+ mpz_mul_ui (r, r, radix);
+ mpz_mul_ui (mplus, mplus, radix);
+ mpz_mul_ui (mminus, mminus, radix);
+ mpz_mul_ui (hi, hi, radix);
+ k--;
+ }
+ }
}
- else
- dpt = 1;
-#endif
- do
- {
- d = f;
- f -= d;
- a[ch++] = number_chars[d];
- if (f < fx[wp])
- break;
- if (f + fx[wp] >= 1.0)
- {
- a[ch - 1] = number_chars[d+1];
- break;
- }
- f *= radix;
- if (!(--dpt))
- a[ch++] = '.';
- }
- while (wp--);
+ expon = k - 1;
+ if (k <= 0)
+ {
+ if (k <= -3)
+ {
+ /* Use scientific notation */
+ show_exp = 1;
+ k = 1;
+ }
+ else
+ {
+ int i;
- if (dpt > 0)
- {
-#ifndef ENGNOT
- if ((dpt > 4) && (exp > 6))
- {
- d = (a[0] == '-' ? 2 : 1);
- for (i = ch++; i > d; i--)
- a[i] = a[i - 1];
- a[d] = '.';
- efmt = 1;
- }
- else
-#endif
- {
- while (--dpt)
- a[ch++] = '0';
- a[ch++] = '.';
- }
- }
- if (a[ch - 1] == '.')
- a[ch++] = '0'; /* trailing zero */
- if (efmt && exp)
- {
- a[ch++] = 'e';
- if (exp < 0)
- {
- exp = -exp;
- a[ch++] = '-';
- }
- for (i = radix; i <= exp; i *= radix);
- for (i /= radix; i; i /= radix)
- {
- a[ch++] = number_chars[exp / i];
- exp %= i;
- }
- }
+ /* Print leading zeroes */
+ a[ch++] = '0';
+ a[ch++] = '.';
+ for (i = 0; i > k; i--)
+ a[ch++] = '0';
+ }
+ }
+
+ for (;;)
+ {
+ int end_1_p, end_2_p;
+ int d;
+
+ mpz_mul_ui (mplus, mplus, radix);
+ mpz_mul_ui (mminus, mminus, radix);
+ mpz_mul_ui (r, r, radix);
+ mpz_fdiv_qr (digit, r, r, s);
+ d = mpz_get_ui (digit);
+
+ mpz_add (hi, r, mplus);
+ end_1_p = (mpz_cmp (r, mminus) < f_is_even);
+ end_2_p = (mpz_cmp (s, hi) < f_is_even);
+ if (end_1_p || end_2_p)
+ {
+ mpz_mul_2exp (r, r, 1);
+ if (!end_2_p)
+ ;
+ else if (!end_1_p)
+ d++;
+ else if (mpz_cmp (r, s) >= !(d & 1))
+ d++;
+ a[ch++] = number_chars[d];
+ if (--k == 0)
+ a[ch++] = '.';
+ break;
+ }
+ else
+ {
+ a[ch++] = number_chars[d];
+ if (--k == 0)
+ a[ch++] = '.';
+ }
+ }
+
+ if (k > 0)
+ {
+ if (expon >= 7 && k >= 4 && expon >= k)
+ {
+ /* Here we would have to print more than three zeroes
+ followed by a decimal point and another zero. It
+ makes more sense to use scientific notation. */
+
+ /* Adjust k to what it would have been if we had chosen
+ scientific notation from the beginning. */
+ k -= expon;
+
+ /* k will now be <= 0, with magnitude equal to the number of
+ digits that we printed which should now be put after the
+ decimal point. */
+
+ /* Insert a decimal point */
+ memmove (a + ch + k + 1, a + ch + k, -k);
+ a[ch + k] = '.';
+ ch++;
+
+ show_exp = 1;
+ }
+ else
+ {
+ for (; k > 0; k--)
+ a[ch++] = '0';
+ a[ch++] = '.';
+ }
+ }
+
+ if (k == 0)
+ a[ch++] = '0';
+
+ if (show_exp)
+ {
+ a[ch++] = 'e';
+ ch += scm_iint2str (expon, radix, a + ch);
+ }
+
+ mpz_clears (f, r, s, mplus, mminus, hi, digit, NULL);
+ }
return ch;
}
#endif
/* Don't output a '+' for negative numbers or for Inf and
NaN. They will provide their own sign. */
- if (sgn >= 0 && DOUBLE_IS_FINITE (imag))
+ if (sgn >= 0 && isfinite (imag))
str[i++] = '+';
i += idbl2str (imag, &str[i], radix);
str[i++] = 'i';
break;
}
- if (exponent > SCM_MAXEXP)
+ if (exponent > ((sign == 1) ? SCM_MAXEXP : SCM_MAXEXP + DBL_DIG + 1))
{
size_t exp_len = idx - start;
SCM exp_string = scm_i_substring_copy (mem, start, start + exp_len);
}
/* We should never get here */
- scm_syserror ("mem2ureal");
+ assert (0);
}
else if (SCM_REALP (x))
/* due to their limited precision, finite floating point numbers are
rational as well. (finite means neither infinity nor a NaN) */
- return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x)));
+ return scm_from_bool (isfinite (SCM_REAL_VALUE (x)));
else
return SCM_BOOL_F;
}
to a double and compare.
But on a 64-bit system an inum is bigger than a double and
- casting it to a double (call that dxx) will round. dxx is at
- worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
- an integer and fits a long. So we cast yy to a long and
+ casting it to a double (call that dxx) will round.
+ Although dxx will not in general be equal to xx, dxx will
+ always be an integer and within a factor of 2 of xx, so if
+ dxx==yy, we know that yy is an integer and fits in
+ scm_t_signed_bits. So we cast yy to scm_t_signed_bits and
compare with plain xx.
An alternative (for any size system actually) would be to check
|| xx == (scm_t_signed_bits) yy));
}
else if (SCM_COMPLEXP (y))
- return scm_from_bool (((double) xx == SCM_COMPLEX_REAL (y))
- && (0.0 == SCM_COMPLEX_IMAG (y)));
+ {
+ /* see comments with inum/real above */
+ double ry = SCM_COMPLEX_REAL (y);
+ return scm_from_bool ((double) xx == ry
+ && 0.0 == SCM_COMPLEX_IMAG (y)
+ && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1
+ || xx == (scm_t_signed_bits) ry));
+ }
else if (SCM_FRACTIONP (y))
return SCM_BOOL_F;
else
else if (SCM_BIGP (y))
{
int cmp;
- if (isnan (SCM_REAL_VALUE (x)))
+ if (isnan (xx))
return SCM_BOOL_F;
- cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
+ cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx);
scm_remember_upto_here_1 (y);
return scm_from_bool (0 == cmp);
}
else if (SCM_REALP (y))
- return scm_from_bool (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
+ return scm_from_bool (xx == SCM_REAL_VALUE (y));
else if (SCM_COMPLEXP (y))
- return scm_from_bool ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y))
- && (0.0 == SCM_COMPLEX_IMAG (y)));
+ return scm_from_bool ((xx == SCM_COMPLEX_REAL (y))
+ && (0.0 == SCM_COMPLEX_IMAG (y)));
else if (SCM_FRACTIONP (y))
{
- double xx = SCM_REAL_VALUE (x);
- if (isnan (xx))
+ if (isnan (xx) || isinf (xx))
return SCM_BOOL_F;
- if (isinf (xx))
- return scm_from_bool (xx < 0.0);
x = scm_inexact_to_exact (x); /* with x as frac or int */
goto again;
}
else if (SCM_COMPLEXP (x))
{
if (SCM_I_INUMP (y))
- return scm_from_bool ((SCM_COMPLEX_REAL (x) == (double) SCM_I_INUM (y))
- && (SCM_COMPLEX_IMAG (x) == 0.0));
+ {
+ /* see comments with inum/real above */
+ double rx = SCM_COMPLEX_REAL (x);
+ scm_t_signed_bits yy = SCM_I_INUM (y);
+ return scm_from_bool (rx == (double) yy
+ && 0.0 == SCM_COMPLEX_IMAG (x)
+ && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1
+ || (scm_t_signed_bits) rx == yy));
+ }
else if (SCM_BIGP (y))
{
int cmp;
}
else if (SCM_REALP (y))
return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y))
- && (SCM_COMPLEX_IMAG (x) == 0.0));
+ && (SCM_COMPLEX_IMAG (x) == 0.0));
else if (SCM_COMPLEXP (y))
return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y))
- && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y)));
+ && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y)));
else if (SCM_FRACTIONP (y))
{
double xx;
if (SCM_COMPLEX_IMAG (x) != 0.0)
return SCM_BOOL_F;
xx = SCM_COMPLEX_REAL (x);
- if (isnan (xx))
+ if (isnan (xx) || isinf (xx))
return SCM_BOOL_F;
- if (isinf (xx))
- return scm_from_bool (xx < 0.0);
x = scm_inexact_to_exact (x); /* with x as frac or int */
goto again;
}
else if (SCM_REALP (y))
{
double yy = SCM_REAL_VALUE (y);
- if (isnan (yy))
+ if (isnan (yy) || isinf (yy))
return SCM_BOOL_F;
- if (isinf (yy))
- return scm_from_bool (0.0 < yy);
y = scm_inexact_to_exact (y); /* with y as frac or int */
goto again;
}
if (SCM_COMPLEX_IMAG (y) != 0.0)
return SCM_BOOL_F;
yy = SCM_COMPLEX_REAL (y);
- if (isnan (yy))
+ if (isnan (yy) || isinf(yy))
return SCM_BOOL_F;
- if (isinf (yy))
- return scm_from_bool (0.0 < yy);
y = scm_inexact_to_exact (y); /* with y as frac or int */
goto again;
}
return scm_from_bool (sgn > 0);
}
else if (SCM_REALP (y))
- return scm_from_bool ((double) xx < SCM_REAL_VALUE (y));
+ {
+ /* We can safely take the ceiling of y without changing the
+ result of x<y, given that x is an integer. */
+ double yy = ceil (SCM_REAL_VALUE (y));
+
+ /* In the following comparisons, it's important that the right
+ hand side always be a power of 2, so that it can be
+ losslessly converted to a double even on 64-bit
+ machines. */
+ if (yy >= (double) (SCM_MOST_POSITIVE_FIXNUM+1))
+ return SCM_BOOL_T;
+ else if (!(yy > (double) SCM_MOST_NEGATIVE_FIXNUM))
+ /* The condition above is carefully written to include the
+ case where yy==NaN. */
+ return SCM_BOOL_F;
+ else
+ /* yy is a finite integer that fits in an inum. */
+ return scm_from_bool (xx < (scm_t_inum) yy);
+ }
else if (SCM_FRACTIONP (y))
{
/* "x < a/b" becomes "x*b < a" */
else if (SCM_REALP (x))
{
if (SCM_I_INUMP (y))
- return scm_from_bool (SCM_REAL_VALUE (x) < (double) SCM_I_INUM (y));
+ {
+ /* We can safely take the floor of x without changing the
+ result of x<y, given that y is an integer. */
+ double xx = floor (SCM_REAL_VALUE (x));
+
+ /* In the following comparisons, it's important that the right
+ hand side always be a power of 2, so that it can be
+ losslessly converted to a double even on 64-bit
+ machines. */
+ if (xx < (double) SCM_MOST_NEGATIVE_FIXNUM)
+ return SCM_BOOL_T;
+ else if (!(xx < (double) (SCM_MOST_POSITIVE_FIXNUM+1)))
+ /* The condition above is carefully written to include the
+ case where xx==NaN. */
+ return SCM_BOOL_F;
+ else
+ /* xx is a finite integer that fits in an inum. */
+ return scm_from_bool ((scm_t_inum) xx < SCM_I_INUM (y));
+ }
else if (SCM_BIGP (y))
{
int cmp;
double yyd = SCM_REAL_VALUE (y);
if (xxd > yyd)
- return scm_from_double (xxd);
+ return scm_i_from_double (xxd);
/* If y is a NaN, then "==" is false and we return the NaN */
else if (SCM_LIKELY (!(xxd == yyd)))
return y;
big_real:
xx = scm_i_big2dbl (x);
yy = SCM_REAL_VALUE (y);
- return (xx > yy ? scm_from_double (xx) : y);
+ return (xx > yy ? scm_i_from_double (xx) : y);
}
else if (SCM_FRACTIONP (y))
{
double yyd = yy;
if (yyd > xxd)
- return scm_from_double (yyd);
+ return scm_i_from_double (yyd);
/* If x is a NaN, then "==" is false and we return the NaN */
else if (SCM_LIKELY (!(xxd == yyd)))
return x;
double xx = SCM_REAL_VALUE (x);
double yy = SCM_REAL_VALUE (y);
- /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
+ /* For purposes of max: nan > +inf.0 > everything else,
+ per the R6RS errata */
if (xx > yy)
return x;
else if (SCM_LIKELY (xx < yy))
return y;
/* If neither (xx > yy) nor (xx < yy), then
either they're equal or one is a NaN */
- else if (SCM_UNLIKELY (isnan (xx)))
- return DOUBLE_IS_POSITIVE_INFINITY (yy) ? y : x;
- else if (SCM_UNLIKELY (isnan (yy)))
- return DOUBLE_IS_POSITIVE_INFINITY (xx) ? x : y;
+ else if (SCM_UNLIKELY (xx != yy))
+ return (xx != xx) ? x : y; /* Return the NaN */
/* xx == yy, but handle signed zeroes properly */
- else if (double_is_non_negative_zero (yy))
- return y;
- else
+ else if (copysign (1.0, yy) < 0.0)
return x;
+ else
+ return y;
}
else if (SCM_FRACTIONP (y))
{
double yy = scm_i_fraction2double (y);
double xx = SCM_REAL_VALUE (x);
- return (xx < yy) ? scm_from_double (yy) : x;
+ return (xx < yy) ? scm_i_from_double (yy) : x;
}
else
SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
{
double xx = scm_i_fraction2double (x);
/* if y==NaN then ">" is false, so we return the NaN y */
- return (xx > SCM_REAL_VALUE (y)) ? scm_from_double (xx) : y;
+ return (xx > SCM_REAL_VALUE (y)) ? scm_i_from_double (xx) : y;
}
else if (SCM_FRACTIONP (y))
{
{
double z = xx;
/* if y==NaN then "<" is false and we return NaN */
- return (z < SCM_REAL_VALUE (y)) ? scm_from_double (z) : y;
+ return (z < SCM_REAL_VALUE (y)) ? scm_i_from_double (z) : y;
}
else if (SCM_FRACTIONP (y))
{
big_real:
xx = scm_i_big2dbl (x);
yy = SCM_REAL_VALUE (y);
- return (xx < yy ? scm_from_double (xx) : y);
+ return (xx < yy ? scm_i_from_double (xx) : y);
}
else if (SCM_FRACTIONP (y))
{
{
double z = SCM_I_INUM (y);
/* if x==NaN then "<" is false and we return NaN */
- return (z < SCM_REAL_VALUE (x)) ? scm_from_double (z) : x;
+ return (z < SCM_REAL_VALUE (x)) ? scm_i_from_double (z) : x;
}
else if (SCM_BIGP (y))
{
double xx = SCM_REAL_VALUE (x);
double yy = SCM_REAL_VALUE (y);
- /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
+ /* For purposes of min: nan < -inf.0 < everything else,
+ per the R6RS errata */
if (xx < yy)
return x;
else if (SCM_LIKELY (xx > yy))
return y;
/* If neither (xx < yy) nor (xx > yy), then
either they're equal or one is a NaN */
- else if (SCM_UNLIKELY (isnan (xx)))
- return DOUBLE_IS_NEGATIVE_INFINITY (yy) ? y : x;
- else if (SCM_UNLIKELY (isnan (yy)))
- return DOUBLE_IS_NEGATIVE_INFINITY (xx) ? x : y;
+ else if (SCM_UNLIKELY (xx != yy))
+ return (xx != xx) ? x : y; /* Return the NaN */
/* xx == yy, but handle signed zeroes properly */
- else if (double_is_non_negative_zero (xx))
- return y;
- else
+ else if (copysign (1.0, xx) < 0.0)
return x;
+ else
+ return y;
}
else if (SCM_FRACTIONP (y))
{
double yy = scm_i_fraction2double (y);
double xx = SCM_REAL_VALUE (x);
- return (yy < xx) ? scm_from_double (yy) : x;
+ return (yy < xx) ? scm_i_from_double (yy) : x;
}
else
SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
{
double xx = scm_i_fraction2double (x);
/* if y==NaN then "<" is false, so we return the NaN y */
- return (xx < SCM_REAL_VALUE (y)) ? scm_from_double (xx) : y;
+ return (xx < SCM_REAL_VALUE (y)) ? scm_i_from_double (xx) : y;
}
else if (SCM_FRACTIONP (y))
{
else if (SCM_REALP (y))
{
scm_t_inum xx = SCM_I_INUM (x);
- return scm_from_double (xx + SCM_REAL_VALUE (y));
+ return scm_i_from_double (xx + SCM_REAL_VALUE (y));
}
else if (SCM_COMPLEXP (y))
{
{
double result = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_REAL_VALUE (y);
scm_remember_upto_here_1 (x);
- return scm_from_double (result);
+ return scm_i_from_double (result);
}
else if (SCM_COMPLEXP (y))
{
else if (SCM_REALP (x))
{
if (SCM_I_INUMP (y))
- return scm_from_double (SCM_REAL_VALUE (x) + SCM_I_INUM (y));
+ return scm_i_from_double (SCM_REAL_VALUE (x) + SCM_I_INUM (y));
else if (SCM_BIGP (y))
{
double result = mpz_get_d (SCM_I_BIG_MPZ (y)) + SCM_REAL_VALUE (x);
scm_remember_upto_here_1 (y);
- return scm_from_double (result);
+ return scm_i_from_double (result);
}
else if (SCM_REALP (y))
- return scm_from_double (SCM_REAL_VALUE (x) + SCM_REAL_VALUE (y));
+ return scm_i_from_double (SCM_REAL_VALUE (x) + SCM_REAL_VALUE (y));
else if (SCM_COMPLEXP (y))
return scm_c_make_rectangular (SCM_REAL_VALUE (x) + SCM_COMPLEX_REAL (y),
SCM_COMPLEX_IMAG (y));
else if (SCM_FRACTIONP (y))
- return scm_from_double (SCM_REAL_VALUE (x) + scm_i_fraction2double (y));
+ return scm_i_from_double (SCM_REAL_VALUE (x) + scm_i_fraction2double (y));
else
SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
scm_product (y, SCM_FRACTION_DENOMINATOR (x))),
SCM_FRACTION_DENOMINATOR (x));
else if (SCM_REALP (y))
- return scm_from_double (SCM_REAL_VALUE (y) + scm_i_fraction2double (x));
+ return scm_i_from_double (SCM_REAL_VALUE (y) + scm_i_fraction2double (x));
else if (SCM_COMPLEXP (y))
return scm_c_make_rectangular (SCM_COMPLEX_REAL (y) + scm_i_fraction2double (x),
SCM_COMPLEX_IMAG (y));
bignum, but negating that gives a fixnum. */
return scm_i_normbig (scm_i_clonebig (x, 0));
else if (SCM_REALP (x))
- return scm_from_double (-SCM_REAL_VALUE (x));
+ return scm_i_from_double (-SCM_REAL_VALUE (x));
else if (SCM_COMPLEXP (x))
return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x),
-SCM_COMPLEX_IMAG (x));
* (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
*/
if (xx == 0)
- return scm_from_double (- SCM_REAL_VALUE (y));
+ return scm_i_from_double (- SCM_REAL_VALUE (y));
else
- return scm_from_double (xx - SCM_REAL_VALUE (y));
+ return scm_i_from_double (xx - SCM_REAL_VALUE (y));
}
else if (SCM_COMPLEXP (y))
{
{
double result = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_REAL_VALUE (y);
scm_remember_upto_here_1 (x);
- return scm_from_double (result);
+ return scm_i_from_double (result);
}
else if (SCM_COMPLEXP (y))
{
else if (SCM_REALP (x))
{
if (SCM_I_INUMP (y))
- return scm_from_double (SCM_REAL_VALUE (x) - SCM_I_INUM (y));
+ return scm_i_from_double (SCM_REAL_VALUE (x) - SCM_I_INUM (y));
else if (SCM_BIGP (y))
{
double result = SCM_REAL_VALUE (x) - mpz_get_d (SCM_I_BIG_MPZ (y));
scm_remember_upto_here_1 (x);
- return scm_from_double (result);
+ return scm_i_from_double (result);
}
else if (SCM_REALP (y))
- return scm_from_double (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y));
+ return scm_i_from_double (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y));
else if (SCM_COMPLEXP (y))
return scm_c_make_rectangular (SCM_REAL_VALUE (x) - SCM_COMPLEX_REAL (y),
-SCM_COMPLEX_IMAG (y));
else if (SCM_FRACTIONP (y))
- return scm_from_double (SCM_REAL_VALUE (x) - scm_i_fraction2double (y));
+ return scm_i_from_double (SCM_REAL_VALUE (x) - scm_i_fraction2double (y));
else
SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
scm_product(y, SCM_FRACTION_DENOMINATOR (x))),
SCM_FRACTION_DENOMINATOR (x));
else if (SCM_REALP (y))
- return scm_from_double (scm_i_fraction2double (x) - SCM_REAL_VALUE (y));
+ return scm_i_from_double (scm_i_fraction2double (x) - SCM_REAL_VALUE (y));
else if (SCM_COMPLEXP (y))
return scm_c_make_rectangular (scm_i_fraction2double (x) - SCM_COMPLEX_REAL (y),
-SCM_COMPLEX_IMAG (y));
and we must do the multiplication in order to handle
infinities and NaNs properly. */
else if (SCM_REALP (y))
- return scm_from_double (0.0 * SCM_REAL_VALUE (y));
+ return scm_i_from_double (0.0 * SCM_REAL_VALUE (y));
else if (SCM_COMPLEXP (y))
return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y),
0.0 * SCM_COMPLEX_IMAG (y));
return result;
}
else if (SCM_REALP (y))
- return scm_from_double (xx * SCM_REAL_VALUE (y));
+ return scm_i_from_double (xx * SCM_REAL_VALUE (y));
else if (SCM_COMPLEXP (y))
return scm_c_make_rectangular (xx * SCM_COMPLEX_REAL (y),
xx * SCM_COMPLEX_IMAG (y));
{
double result = mpz_get_d (SCM_I_BIG_MPZ (x)) * SCM_REAL_VALUE (y);
scm_remember_upto_here_1 (x);
- return scm_from_double (result);
+ return scm_i_from_double (result);
}
else if (SCM_COMPLEXP (y))
{
{
double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x);
scm_remember_upto_here_1 (y);
- return scm_from_double (result);
+ return scm_i_from_double (result);
}
else if (SCM_REALP (y))
- return scm_from_double (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y));
+ return scm_i_from_double (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y));
else if (SCM_COMPLEXP (y))
return scm_c_make_rectangular (SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y),
SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y));
else if (SCM_FRACTIONP (y))
- return scm_from_double (SCM_REAL_VALUE (x) * scm_i_fraction2double (y));
+ return scm_i_from_double (SCM_REAL_VALUE (x) * scm_i_fraction2double (y));
else
SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
}
return scm_i_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)),
SCM_FRACTION_DENOMINATOR (x));
else if (SCM_REALP (y))
- return scm_from_double (scm_i_fraction2double (x) * SCM_REAL_VALUE (y));
+ return scm_i_from_double (scm_i_fraction2double (x) * SCM_REAL_VALUE (y));
else if (SCM_COMPLEXP (y))
{
double xx = scm_i_fraction2double (x);
#define s_divide s_scm_i_divide
#define g_divide g_scm_i_divide
-static SCM
-do_divide (SCM x, SCM y, int inexact)
+SCM
+scm_divide (SCM x, SCM y)
#define FUNC_NAME s_divide
{
double a;
scm_num_overflow (s_divide);
#endif
else
- {
- if (inexact)
- return scm_from_double (1.0 / (double) xx);
- else return scm_i_make_ratio_already_reduced (SCM_INUM1, x);
- }
+ return scm_i_make_ratio_already_reduced (SCM_INUM1, x);
}
else if (SCM_BIGP (x))
- {
- if (inexact)
- return scm_from_double (1.0 / scm_i_big2dbl (x));
- else return scm_i_make_ratio_already_reduced (SCM_INUM1, x);
- }
+ return scm_i_make_ratio_already_reduced (SCM_INUM1, x);
else if (SCM_REALP (x))
{
double xx = SCM_REAL_VALUE (x);
scm_num_overflow (s_divide);
else
#endif
- return scm_from_double (1.0 / xx);
+ return scm_i_from_double (1.0 / xx);
}
else if (SCM_COMPLEXP (x))
{
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
scm_num_overflow (s_divide);
#else
- return scm_from_double ((double) xx / (double) yy);
+ return scm_i_from_double ((double) xx / (double) yy);
#endif
}
else if (xx % yy != 0)
- {
- if (inexact)
- return scm_from_double ((double) xx / (double) yy);
- else return scm_i_make_ratio (x, y);
- }
+ return scm_i_make_ratio (x, y);
else
{
scm_t_inum z = xx / yy;
}
}
else if (SCM_BIGP (y))
- {
- if (inexact)
- return scm_from_double ((double) xx / scm_i_big2dbl (y));
- else return scm_i_make_ratio (x, y);
- }
+ return scm_i_make_ratio (x, y);
else if (SCM_REALP (y))
{
double yy = SCM_REAL_VALUE (y);
scm_num_overflow (s_divide);
else
#endif
- return scm_from_double ((double) xx / yy);
+ /* FIXME: Precision may be lost here due to:
+ (1) The cast from 'scm_t_inum' to 'double'
+ (2) Double rounding */
+ return scm_i_from_double ((double) xx / yy);
}
else if (SCM_COMPLEXP (y))
{
else if (SCM_FRACTIONP (y))
/* a / b/c = ac / b */
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
- SCM_FRACTION_NUMERATOR (y));
+ SCM_FRACTION_NUMERATOR (y));
else
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
return scm_i_normbig (result);
}
else
- {
- if (inexact)
- return scm_from_double (scm_i_big2dbl (x) / (double) yy);
- else return scm_i_make_ratio (x, y);
- }
+ return scm_i_make_ratio (x, y);
}
}
else if (SCM_BIGP (y))
{
- /* big_x / big_y */
- if (inexact)
- {
- /* It's easily possible for the ratio x/y to fit a double
- but one or both x and y be too big to fit a double,
- hence the use of mpq_get_d rather than converting and
- dividing. */
- mpq_t q;
- *mpq_numref(q) = *SCM_I_BIG_MPZ (x);
- *mpq_denref(q) = *SCM_I_BIG_MPZ (y);
- return scm_from_double (mpq_get_d (q));
- }
- else
- {
- int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x),
- SCM_I_BIG_MPZ (y));
- if (divisible_p)
- {
- SCM result = scm_i_mkbig ();
- mpz_divexact (SCM_I_BIG_MPZ (result),
- SCM_I_BIG_MPZ (x),
- SCM_I_BIG_MPZ (y));
- scm_remember_upto_here_2 (x, y);
- return scm_i_normbig (result);
- }
- else
- return scm_i_make_ratio (x, y);
- }
+ int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ if (divisible_p)
+ {
+ SCM result = scm_i_mkbig ();
+ mpz_divexact (SCM_I_BIG_MPZ (result),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (result);
+ }
+ else
+ return scm_i_make_ratio (x, y);
}
else if (SCM_REALP (y))
{
scm_num_overflow (s_divide);
else
#endif
- return scm_from_double (scm_i_big2dbl (x) / yy);
+ /* FIXME: Precision may be lost here due to:
+ (1) scm_i_big2dbl (2) Double rounding */
+ return scm_i_from_double (scm_i_big2dbl (x) / yy);
}
else if (SCM_COMPLEXP (y))
{
}
else if (SCM_FRACTIONP (y))
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
- SCM_FRACTION_NUMERATOR (y));
+ SCM_FRACTION_NUMERATOR (y));
else
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
scm_num_overflow (s_divide);
else
#endif
- return scm_from_double (rx / (double) yy);
+ /* FIXME: Precision may be lost here due to:
+ (1) The cast from 'scm_t_inum' to 'double'
+ (2) Double rounding */
+ return scm_i_from_double (rx / (double) yy);
}
else if (SCM_BIGP (y))
{
+ /* FIXME: Precision may be lost here due to:
+ (1) The conversion from bignum to double
+ (2) Double rounding */
double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
scm_remember_upto_here_1 (y);
- return scm_from_double (rx / dby);
+ return scm_i_from_double (rx / dby);
}
else if (SCM_REALP (y))
{
scm_num_overflow (s_divide);
else
#endif
- return scm_from_double (rx / yy);
+ return scm_i_from_double (rx / yy);
}
else if (SCM_COMPLEXP (y))
{
goto complex_div;
}
else if (SCM_FRACTIONP (y))
- return scm_from_double (rx / scm_i_fraction2double (y));
+ return scm_i_from_double (rx / scm_i_fraction2double (y));
else
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else
#endif
{
+ /* FIXME: Precision may be lost here due to:
+ (1) The conversion from 'scm_t_inum' to double
+ (2) Double rounding */
double d = yy;
return scm_c_make_rectangular (rx / d, ix / d);
}
}
else if (SCM_BIGP (y))
{
+ /* FIXME: Precision may be lost here due to:
+ (1) The conversion from bignum to double
+ (2) Double rounding */
double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
scm_remember_upto_here_1 (y);
return scm_c_make_rectangular (rx / dby, ix / dby);
}
else if (SCM_FRACTIONP (y))
{
+ /* FIXME: Precision may be lost here due to:
+ (1) The conversion from fraction to double
+ (2) Double rounding */
double yy = scm_i_fraction2double (y);
return scm_c_make_rectangular (rx / yy, ix / yy);
}
else
#endif
return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x),
- scm_product (SCM_FRACTION_DENOMINATOR (x), y));
+ scm_product (SCM_FRACTION_DENOMINATOR (x), y));
}
else if (SCM_BIGP (y))
{
return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x),
- scm_product (SCM_FRACTION_DENOMINATOR (x), y));
+ scm_product (SCM_FRACTION_DENOMINATOR (x), y));
}
else if (SCM_REALP (y))
{
scm_num_overflow (s_divide);
else
#endif
- return scm_from_double (scm_i_fraction2double (x) / yy);
+ /* FIXME: Precision may be lost here due to:
+ (1) The conversion from fraction to double
+ (2) Double rounding */
+ return scm_i_from_double (scm_i_fraction2double (x) / yy);
}
else if (SCM_COMPLEXP (y))
{
+ /* FIXME: Precision may be lost here due to:
+ (1) The conversion from fraction to double
+ (2) Double rounding */
a = scm_i_fraction2double (x);
goto complex_div;
}
else if (SCM_FRACTIONP (y))
return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
- scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x)));
+ scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x)));
else
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide);
}
-
-SCM
-scm_divide (SCM x, SCM y)
-{
- return do_divide (x, y, 0);
-}
-
-static SCM scm_divide2real (SCM x, SCM y)
-{
- return do_divide (x, y, 1);
-}
#undef FUNC_NAME
if (SCM_I_INUMP (x) || SCM_BIGP (x))
return x;
else if (SCM_REALP (x))
- return scm_from_double (trunc (SCM_REAL_VALUE (x)));
+ return scm_i_from_double (trunc (SCM_REAL_VALUE (x)));
else if (SCM_FRACTIONP (x))
return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
if (SCM_I_INUMP (x) || SCM_BIGP (x))
return x;
else if (SCM_REALP (x))
- return scm_from_double (scm_c_round (SCM_REAL_VALUE (x)));
+ return scm_i_from_double (scm_c_round (SCM_REAL_VALUE (x)));
else if (SCM_FRACTIONP (x))
return scm_round_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
if (SCM_I_INUMP (x) || SCM_BIGP (x))
return x;
else if (SCM_REALP (x))
- return scm_from_double (floor (SCM_REAL_VALUE (x)));
+ return scm_i_from_double (floor (SCM_REAL_VALUE (x)));
else if (SCM_FRACTIONP (x))
return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
if (SCM_I_INUMP (x) || SCM_BIGP (x))
return x;
else if (SCM_REALP (x))
- return scm_from_double (ceil (SCM_REAL_VALUE (x)));
+ return scm_i_from_double (ceil (SCM_REAL_VALUE (x)));
else if (SCM_FRACTIONP (x))
return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
}
else if (scm_is_real (x) && scm_is_real (y) && scm_to_double (x) >= 0.0)
{
- return scm_from_double (pow (scm_to_double (x), scm_to_double (y)));
+ return scm_i_from_double (pow (scm_to_double (x), scm_to_double (y)));
}
else if (scm_is_complex (x) && scm_is_complex (y))
return scm_exp (scm_product (scm_log (x), y));
if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
return z; /* sin(exact0) = exact0 */
else if (scm_is_real (z))
- return scm_from_double (sin (scm_to_double (z)));
+ return scm_i_from_double (sin (scm_to_double (z)));
else if (SCM_COMPLEXP (z))
{ double x, y;
x = SCM_COMPLEX_REAL (z);
if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
return SCM_INUM1; /* cos(exact0) = exact1 */
else if (scm_is_real (z))
- return scm_from_double (cos (scm_to_double (z)));
+ return scm_i_from_double (cos (scm_to_double (z)));
else if (SCM_COMPLEXP (z))
{ double x, y;
x = SCM_COMPLEX_REAL (z);
if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
return z; /* tan(exact0) = exact0 */
else if (scm_is_real (z))
- return scm_from_double (tan (scm_to_double (z)));
+ return scm_i_from_double (tan (scm_to_double (z)));
else if (SCM_COMPLEXP (z))
{ double x, y, w;
x = 2.0 * SCM_COMPLEX_REAL (z);
if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
return z; /* sinh(exact0) = exact0 */
else if (scm_is_real (z))
- return scm_from_double (sinh (scm_to_double (z)));
+ return scm_i_from_double (sinh (scm_to_double (z)));
else if (SCM_COMPLEXP (z))
{ double x, y;
x = SCM_COMPLEX_REAL (z);
if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
return SCM_INUM1; /* cosh(exact0) = exact1 */
else if (scm_is_real (z))
- return scm_from_double (cosh (scm_to_double (z)));
+ return scm_i_from_double (cosh (scm_to_double (z)));
else if (SCM_COMPLEXP (z))
{ double x, y;
x = SCM_COMPLEX_REAL (z);
if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
return z; /* tanh(exact0) = exact0 */
else if (scm_is_real (z))
- return scm_from_double (tanh (scm_to_double (z)));
+ return scm_i_from_double (tanh (scm_to_double (z)));
else if (SCM_COMPLEXP (z))
{ double x, y, w;
x = 2.0 * SCM_COMPLEX_REAL (z);
{
double w = scm_to_double (z);
if (w >= -1.0 && w <= 1.0)
- return scm_from_double (asin (w));
+ return scm_i_from_double (asin (w));
else
return scm_product (scm_c_make_rectangular (0, -1),
scm_sys_asinh (scm_c_make_rectangular (0, w)));
{
double w = scm_to_double (z);
if (w >= -1.0 && w <= 1.0)
- return scm_from_double (acos (w));
+ return scm_i_from_double (acos (w));
else
- return scm_sum (scm_from_double (acos (0.0)),
+ return scm_sum (scm_i_from_double (acos (0.0)),
scm_product (scm_c_make_rectangular (0, 1),
scm_sys_asinh (scm_c_make_rectangular (0, w))));
}
{ double x, y;
x = SCM_COMPLEX_REAL (z);
y = SCM_COMPLEX_IMAG (z);
- return scm_sum (scm_from_double (acos (0.0)),
+ return scm_sum (scm_i_from_double (acos (0.0)),
scm_product (scm_c_make_rectangular (0, 1),
scm_sys_asinh (scm_c_make_rectangular (-y, x))));
}
if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
return z; /* atan(exact0) = exact0 */
else if (scm_is_real (z))
- return scm_from_double (atan (scm_to_double (z)));
+ return scm_i_from_double (atan (scm_to_double (z)));
else if (SCM_COMPLEXP (z))
{
double v, w;
else if (scm_is_real (z))
{
if (scm_is_real (y))
- return scm_from_double (atan2 (scm_to_double (z), scm_to_double (y)));
+ return scm_i_from_double (atan2 (scm_to_double (z), scm_to_double (y)));
else
SCM_WTA_DISPATCH_2 (g_scm_atan, z, y, SCM_ARG2, s_scm_atan);
}
if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
return z; /* asinh(exact0) = exact0 */
else if (scm_is_real (z))
- return scm_from_double (asinh (scm_to_double (z)));
+ return scm_i_from_double (asinh (scm_to_double (z)));
else if (scm_is_number (z))
return scm_log (scm_sum (z,
scm_sqrt (scm_sum (scm_product (z, z),
if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM1)))
return SCM_INUM0; /* acosh(exact1) = exact0 */
else if (scm_is_real (z) && scm_to_double (z) >= 1.0)
- return scm_from_double (acosh (scm_to_double (z)));
+ return scm_i_from_double (acosh (scm_to_double (z)));
else if (scm_is_number (z))
return scm_log (scm_sum (z,
scm_sqrt (scm_difference (scm_product (z, z),
if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
return z; /* atanh(exact0) = exact0 */
else if (scm_is_real (z) && scm_to_double (z) >= -1.0 && scm_to_double (z) <= 1.0)
- return scm_from_double (atanh (scm_to_double (z)));
+ return scm_i_from_double (atanh (scm_to_double (z)));
else if (scm_is_number (z))
return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1, z),
scm_difference (SCM_INUM1, z))),
#define FUNC_NAME s_scm_real_part
{
if (SCM_COMPLEXP (z))
- return scm_from_double (SCM_COMPLEX_REAL (z));
+ return scm_i_from_double (SCM_COMPLEX_REAL (z));
else if (SCM_I_INUMP (z) || SCM_BIGP (z) || SCM_REALP (z) || SCM_FRACTIONP (z))
return z;
else
#define FUNC_NAME s_scm_imag_part
{
if (SCM_COMPLEXP (z))
- return scm_from_double (SCM_COMPLEX_IMAG (z));
+ return scm_i_from_double (SCM_COMPLEX_IMAG (z));
else if (SCM_I_INUMP (z) || SCM_REALP (z) || SCM_BIGP (z) || SCM_FRACTIONP (z))
return SCM_INUM0;
else
else if (SCM_FRACTIONP (z))
return SCM_FRACTION_NUMERATOR (z);
else if (SCM_REALP (z))
- return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
+ {
+ double zz = SCM_REAL_VALUE (z);
+ if (zz == floor (zz))
+ /* Handle -0.0 and infinities in accordance with R6RS
+ flnumerator, and optimize handling of integers. */
+ return z;
+ else
+ return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
+ }
else
SCM_WTA_DISPATCH_1 (g_scm_numerator, z, SCM_ARG1, s_scm_numerator);
}
else if (SCM_FRACTIONP (z))
return SCM_FRACTION_DENOMINATOR (z);
else if (SCM_REALP (z))
- return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z)));
+ {
+ double zz = SCM_REAL_VALUE (z);
+ if (zz == floor (zz))
+ /* Handle infinities in accordance with R6RS fldenominator, and
+ optimize handling of integers. */
+ return scm_i_from_double (1.0);
+ else
+ return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z)));
+ }
else
SCM_WTA_DISPATCH_1 (g_scm_denominator, z, SCM_ARG1, s_scm_denominator);
}
return z;
}
else if (SCM_REALP (z))
- return scm_from_double (fabs (SCM_REAL_VALUE (z)));
+ return scm_i_from_double (fabs (SCM_REAL_VALUE (z)));
else if (SCM_COMPLEXP (z))
- return scm_from_double (hypot (SCM_COMPLEX_REAL (z), SCM_COMPLEX_IMAG (z)));
+ return scm_i_from_double (hypot (SCM_COMPLEX_REAL (z), SCM_COMPLEX_IMAG (z)));
else if (SCM_FRACTIONP (z))
{
if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
#define FUNC_NAME s_scm_angle
{
/* atan(0,-1) is pi and it'd be possible to have that as a constant like
- flo0 to save allocating a new flonum with scm_from_double each time.
+ flo0 to save allocating a new flonum with scm_i_from_double each time.
But if atan2 follows the floating point rounding mode, then the value
is not a constant. Maybe it'd be close enough though. */
if (SCM_I_INUMP (z))
if (SCM_I_INUM (z) >= 0)
return flo0;
else
- return scm_from_double (atan2 (0.0, -1.0));
+ return scm_i_from_double (atan2 (0.0, -1.0));
}
else if (SCM_BIGP (z))
{
int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
scm_remember_upto_here_1 (z);
if (sgn < 0)
- return scm_from_double (atan2 (0.0, -1.0));
+ return scm_i_from_double (atan2 (0.0, -1.0));
else
return flo0;
}
else if (SCM_REALP (z))
{
double x = SCM_REAL_VALUE (z);
- if (x > 0.0 || double_is_non_negative_zero (x))
+ if (copysign (1.0, x) > 0.0)
return flo0;
else
- return scm_from_double (atan2 (0.0, -1.0));
+ return scm_i_from_double (atan2 (0.0, -1.0));
}
else if (SCM_COMPLEXP (z))
- return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z)));
+ return scm_i_from_double (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z)));
else if (SCM_FRACTIONP (z))
{
if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
return flo0;
- else return scm_from_double (atan2 (0.0, -1.0));
+ else return scm_i_from_double (atan2 (0.0, -1.0));
}
else
SCM_WTA_DISPATCH_1 (g_scm_angle, z, SCM_ARG1, s_scm_angle);
#define FUNC_NAME s_scm_exact_to_inexact
{
if (SCM_I_INUMP (z))
- return scm_from_double ((double) SCM_I_INUM (z));
+ return scm_i_from_double ((double) SCM_I_INUM (z));
else if (SCM_BIGP (z))
- return scm_from_double (scm_i_big2dbl (z));
+ return scm_i_from_double (scm_i_big2dbl (z));
else if (SCM_FRACTIONP (z))
- return scm_from_double (scm_i_fraction2double (z));
+ return scm_i_from_double (scm_i_fraction2double (z));
else if (SCM_INEXACTP (z))
return z;
else
else
SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact, z, 1, s_scm_inexact_to_exact);
- if (!SCM_LIKELY (DOUBLE_IS_FINITE (val)))
+ if (!SCM_LIKELY (isfinite (val)))
SCM_OUT_OF_RANGE (1, z);
else if (val == 0.0)
return SCM_INUM0;
{
SCM_ASSERT_TYPE (scm_is_real (x), x, SCM_ARG1, FUNC_NAME, "real");
SCM_ASSERT_TYPE (scm_is_real (eps), eps, SCM_ARG2, FUNC_NAME, "real");
- eps = scm_abs (eps);
- if (scm_is_false (scm_positive_p (eps)))
- {
- /* eps is either zero or a NaN */
- if (scm_is_true (scm_nan_p (eps)))
- return scm_nan ();
- else if (SCM_INEXACTP (eps))
- return scm_exact_to_inexact (x);
- else
- return x;
- }
- else if (scm_is_false (scm_finite_p (eps)))
- {
- if (scm_is_true (scm_finite_p (x)))
- return flo0;
- else
- return scm_nan ();
- }
- else if (scm_is_false (scm_finite_p (x))) /* checks for both inf and nan */
- return x;
- else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x, eps)),
- scm_ceiling (scm_difference (x, eps)))))
+
+ if (SCM_UNLIKELY (!scm_is_exact (eps) || !scm_is_exact (x)))
{
- /* There's an integer within range; we want the one closest to zero */
- if (scm_is_false (scm_less_p (eps, scm_abs (x))))
- {
- /* zero is within range */
- if (SCM_INEXACTP (x) || SCM_INEXACTP (eps))
- return flo0;
- else
- return SCM_INUM0;
- }
- else if (scm_is_true (scm_positive_p (x)))
- return scm_ceiling (scm_difference (x, eps));
+ if (SCM_UNLIKELY (scm_is_false (scm_finite_p (eps))))
+ {
+ if (scm_is_false (scm_nan_p (eps)) && scm_is_true (scm_finite_p (x)))
+ return flo0;
+ else
+ return scm_nan ();
+ }
+ else if (SCM_UNLIKELY (scm_is_false (scm_finite_p (x))))
+ return x;
else
- return scm_floor (scm_sum (x, eps));
- }
- else
- {
- /* Use continued fractions to find closest ratio. All
- arithmetic is done with exact numbers.
+ return scm_exact_to_inexact
+ (scm_rationalize (scm_inexact_to_exact (x),
+ scm_inexact_to_exact (eps)));
+ }
+ else
+ {
+ /* X and EPS are exact rationals.
+
+ The code that follows is equivalent to the following Scheme code:
+
+ (define (exact-rationalize x eps)
+ (let ((n1 (if (negative? x) -1 1))
+ (x (abs x))
+ (eps (abs eps)))
+ (let ((lo (- x eps))
+ (hi (+ x eps)))
+ (if (<= lo 0)
+ 0
+ (let loop ((nlo (numerator lo)) (dlo (denominator lo))
+ (nhi (numerator hi)) (dhi (denominator hi))
+ (n1 n1) (d1 0) (n2 0) (d2 1))
+ (let-values (((qlo rlo) (floor/ nlo dlo))
+ ((qhi rhi) (floor/ nhi dhi)))
+ (let ((n0 (+ n2 (* n1 qlo)))
+ (d0 (+ d2 (* d1 qlo))))
+ (cond ((zero? rlo) (/ n0 d0))
+ ((< qlo qhi) (/ (+ n0 n1) (+ d0 d1)))
+ (else (loop dhi rhi dlo rlo n0 d0 n1 d1))))))))))
*/
- SCM ex = scm_inexact_to_exact (x);
- SCM int_part = scm_floor (ex);
- SCM tt = SCM_INUM1;
- SCM a1 = SCM_INUM0, a2 = SCM_INUM1, a = SCM_INUM0;
- SCM b1 = SCM_INUM1, b2 = SCM_INUM0, b = SCM_INUM0;
- SCM rx;
- int i = 0;
+ int n1_init = 1;
+ SCM lo, hi;
- ex = scm_difference (ex, int_part); /* x = x-int_part */
- rx = scm_divide (ex, SCM_UNDEFINED); /* rx = 1/x */
+ eps = scm_abs (eps);
+ if (scm_is_true (scm_negative_p (x)))
+ {
+ n1_init = -1;
+ x = scm_difference (x, SCM_UNDEFINED);
+ }
- /* We stop after a million iterations just to be absolutely sure
- that we don't go into an infinite loop. The process normally
- converges after less than a dozen iterations.
- */
+ /* X and EPS are non-negative exact rationals. */
- while (++i < 1000000)
- {
- a = scm_sum (scm_product (a1, tt), a2); /* a = a1*tt + a2 */
- b = scm_sum (scm_product (b1, tt), b2); /* b = b1*tt + b2 */
- if (scm_is_false (scm_zero_p (b)) && /* b != 0 */
- scm_is_false
- (scm_gr_p (scm_abs (scm_difference (ex, scm_divide (a, b))),
- eps))) /* abs(x-a/b) <= eps */
- {
- SCM res = scm_sum (int_part, scm_divide (a, b));
- if (SCM_INEXACTP (x) || SCM_INEXACTP (eps))
- return scm_exact_to_inexact (res);
- else
- return res;
- }
- rx = scm_divide (scm_difference (rx, tt), /* rx = 1/(rx - tt) */
- SCM_UNDEFINED);
- tt = scm_floor (rx); /* tt = floor (rx) */
- a2 = a1;
- b2 = b1;
- a1 = a;
- b1 = b;
- }
- scm_num_overflow (s_scm_rationalize);
+ lo = scm_difference (x, eps);
+ hi = scm_sum (x, eps);
+
+ if (scm_is_false (scm_positive_p (lo)))
+ /* If zero is included in the interval, return it.
+ It is the simplest rational of all. */
+ return SCM_INUM0;
+ else
+ {
+ SCM result;
+ mpz_t n0, d0, n1, d1, n2, d2;
+ mpz_t nlo, dlo, nhi, dhi;
+ mpz_t qlo, rlo, qhi, rhi;
+
+ /* LO and HI are positive exact rationals. */
+
+ /* Our approach here follows the method described by Alan
+ Bawden in a message entitled "(rationalize x y)" on the
+ rrrs-authors mailing list, dated 16 Feb 1988 14:08:28 EST:
+
+ http://groups.csail.mit.edu/mac/ftpdir/scheme-mail/HTML/rrrs-1988/msg00063.html
+
+ In brief, we compute the continued fractions of the two
+ endpoints of the interval (LO and HI). The continued
+ fraction of the result consists of the common prefix of the
+ continued fractions of LO and HI, plus one final term. The
+ final term of the result is the smallest integer contained
+ in the interval between the remainders of LO and HI after
+ the common prefix has been removed.
+
+ The following code lazily computes the continued fraction
+ representations of LO and HI, and simultaneously converts
+ the continued fraction of the result into a rational
+ number. We use MPZ functions directly to avoid type
+ dispatch and GC allocation during the loop. */
+
+ mpz_inits (n0, d0, n1, d1, n2, d2,
+ nlo, dlo, nhi, dhi,
+ qlo, rlo, qhi, rhi,
+ NULL);
+
+ /* The variables N1, D1, N2 and D2 are used to compute the
+ resulting rational from its continued fraction. At each
+ step, N2/D2 and N1/D1 are the last two convergents. They
+ are normally initialized to 0/1 and 1/0, respectively.
+ However, if we negated X then we must negate the result as
+ well, and we do that by initializing N1/D1 to -1/0. */
+ mpz_set_si (n1, n1_init);
+ mpz_set_ui (d1, 0);
+ mpz_set_ui (n2, 0);
+ mpz_set_ui (d2, 1);
+
+ /* The variables NLO, DLO, NHI, and DHI are used to lazily
+ compute the continued fraction representations of LO and HI
+ using Euclid's algorithm. Initially, NLO/DLO == LO and
+ NHI/DHI == HI. */
+ scm_to_mpz (scm_numerator (lo), nlo);
+ scm_to_mpz (scm_denominator (lo), dlo);
+ scm_to_mpz (scm_numerator (hi), nhi);
+ scm_to_mpz (scm_denominator (hi), dhi);
+
+ /* As long as we're using exact arithmetic, the following loop
+ is guaranteed to terminate. */
+ for (;;)
+ {
+ /* Compute the next terms (QLO and QHI) of the continued
+ fractions of LO and HI. */
+ mpz_fdiv_qr (qlo, rlo, nlo, dlo); /* QLO <-- floor (NLO/DLO), RLO <-- NLO - QLO * DLO */
+ mpz_fdiv_qr (qhi, rhi, nhi, dhi); /* QHI <-- floor (NHI/DHI), RHI <-- NHI - QHI * DHI */
+
+ /* The next term of the result will be either QLO or
+ QLO+1. Here we compute the next convergent of the
+ result based on the assumption that QLO is the next
+ term. If that turns out to be wrong, we'll adjust
+ these later by adding N1 to N0 and D1 to D0. */
+ mpz_set (n0, n2); mpz_addmul (n0, n1, qlo); /* N0 <-- N2 + (QLO * N1) */
+ mpz_set (d0, d2); mpz_addmul (d0, d1, qlo); /* D0 <-- D2 + (QLO * D1) */
+
+ /* We stop iterating when an integer is contained in the
+ interval between the remainders NLO/DLO and NHI/DHI.
+ There are two cases to consider: either NLO/DLO == QLO
+ is an integer (indicated by RLO == 0), or QLO < QHI. */
+ if (mpz_sgn (rlo) == 0 || mpz_cmp (qlo, qhi) != 0)
+ break;
+
+ /* Efficiently shuffle variables around for the next
+ iteration. First we shift the recent convergents. */
+ mpz_swap (n2, n1); mpz_swap (n1, n0); /* N2 <-- N1 <-- N0 */
+ mpz_swap (d2, d1); mpz_swap (d1, d0); /* D2 <-- D1 <-- D0 */
+
+ /* The following shuffling is a bit confusing, so some
+ explanation is in order. Conceptually, we're doing a
+ couple of things here. After substracting the floor of
+ NLO/DLO, the remainder is RLO/DLO. The rest of the
+ continued fraction will represent the remainder's
+ reciprocal DLO/RLO. Similarly for the HI endpoint.
+ So in the next iteration, the new endpoints will be
+ DLO/RLO and DHI/RHI. However, when we take the
+ reciprocals of these endpoints, their order is
+ switched. So in summary, we want NLO/DLO <-- DHI/RHI
+ and NHI/DHI <-- DLO/RLO. */
+ mpz_swap (nlo, dhi); mpz_swap (dhi, rlo); /* NLO <-- DHI <-- RLO */
+ mpz_swap (nhi, dlo); mpz_swap (dlo, rhi); /* NHI <-- DLO <-- RHI */
+ }
+
+ /* There is now an integer in the interval [NLO/DLO NHI/DHI].
+ The last term of the result will be the smallest integer in
+ that interval, which is ceiling(NLO/DLO). We have already
+ computed floor(NLO/DLO) in QLO, so now we adjust QLO to be
+ equal to the ceiling. */
+ if (mpz_sgn (rlo) != 0)
+ {
+ /* If RLO is non-zero, then NLO/DLO is not an integer and
+ the next term will be QLO+1. QLO was used in the
+ computation of N0 and D0 above. Here we adjust N0 and
+ D0 to be based on QLO+1 instead of QLO. */
+ mpz_add (n0, n0, n1); /* N0 <-- N0 + N1 */
+ mpz_add (d0, d0, d1); /* D0 <-- D0 + D1 */
+ }
+
+ /* The simplest rational in the interval is N0/D0 */
+ result = scm_i_make_ratio_already_reduced (scm_from_mpz (n0),
+ scm_from_mpz (d0));
+ mpz_clears (n0, d0, n1, d1, n2, d2,
+ nlo, dlo, nhi, dhi,
+ qlo, rlo, qhi, rhi,
+ NULL);
+ return result;
+ }
}
}
#undef FUNC_NAME
SCM
scm_from_double (double val)
{
- SCM z;
-
- z = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double), "real"));
-
- SCM_SET_CELL_TYPE (z, scm_tc16_real);
- SCM_REAL_VALUE (z) = val;
-
- return z;
+ return scm_i_from_double (val);
}
#if SCM_ENABLE_DEPRECATED == 1
{
double ans = log (fabs (x)) + shift * M_LN2;
- if (x > 0.0 || double_is_non_negative_zero (x))
- return scm_from_double (ans);
+ if (copysign (1.0, x) > 0.0)
+ return scm_i_from_double (ans);
else
return scm_c_make_rectangular (ans, M_PI);
}
return (scm_difference (log_of_exact_integer (n),
log_of_exact_integer (d)));
else if (scm_is_false (scm_negative_p (n)))
- return scm_from_double
- (log1p (scm_to_double (scm_divide2real (scm_difference (n, d), d))));
+ return scm_i_from_double
+ (log1p (scm_i_divide2double (scm_difference (n, d), d)));
else
return scm_c_make_rectangular
- (log1p (scm_to_double (scm_divide2real
- (scm_difference (scm_abs (n), d),
- d))),
+ (log1p (scm_i_divide2double (scm_difference (scm_abs (n), d),
+ d)),
M_PI);
}
{
double re = scm_to_double (z);
double l = log10 (fabs (re));
- if (re > 0.0 || double_is_non_negative_zero (re))
- return scm_from_double (l);
+ if (copysign (1.0, re) > 0.0)
+ return scm_i_from_double (l);
else
return scm_c_make_rectangular (l, M_LOG10E * M_PI);
}
{
/* When z is a negative bignum the conversion to double overflows,
giving -infinity, but that's ok, the exp is still 0.0. */
- return scm_from_double (exp (scm_to_double (z)));
+ return scm_i_from_double (exp (scm_to_double (z)));
}
else
SCM_WTA_DISPATCH_1 (g_scm_exp, z, 1, s_scm_exp);
{
if (SCM_LIKELY (SCM_I_INUMP (k)))
{
- scm_t_inum kk = SCM_I_INUM (k);
- scm_t_inum uu = kk;
- scm_t_inum ss;
+ mpz_t kk, ss, rr;
- if (SCM_LIKELY (kk > 0))
- {
- do
- {
- ss = uu;
- uu = (ss + kk/ss) / 2;
- } while (uu < ss);
- *sp = SCM_I_MAKINUM (ss);
- *rp = SCM_I_MAKINUM (kk - ss*ss);
- }
- else if (SCM_LIKELY (kk == 0))
- *sp = *rp = SCM_INUM0;
- else
+ if (SCM_I_INUM (k) < 0)
scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k,
"exact non-negative integer");
+ mpz_init_set_ui (kk, SCM_I_INUM (k));
+ mpz_inits (ss, rr, NULL);
+ mpz_sqrtrem (ss, rr, kk);
+ *sp = SCM_I_MAKINUM (mpz_get_ui (ss));
+ *rp = SCM_I_MAKINUM (mpz_get_ui (rr));
+ mpz_clears (kk, ss, rr, NULL);
}
else if (SCM_LIKELY (SCM_BIGP (k)))
{
"exact non-negative integer");
}
+/* Return true iff K is a perfect square.
+ K must be an exact integer. */
+static int
+exact_integer_is_perfect_square (SCM k)
+{
+ int result;
+
+ if (SCM_LIKELY (SCM_I_INUMP (k)))
+ {
+ mpz_t kk;
+
+ mpz_init_set_si (kk, SCM_I_INUM (k));
+ result = mpz_perfect_square_p (kk);
+ mpz_clear (kk);
+ }
+ else
+ {
+ result = mpz_perfect_square_p (SCM_I_BIG_MPZ (k));
+ scm_remember_upto_here_1 (k);
+ }
+ return result;
+}
+
+/* Return the floor of the square root of K.
+ K must be an exact integer. */
+static SCM
+exact_integer_floor_square_root (SCM k)
+{
+ if (SCM_LIKELY (SCM_I_INUMP (k)))
+ {
+ mpz_t kk;
+ scm_t_inum ss;
+
+ mpz_init_set_ui (kk, SCM_I_INUM (k));
+ mpz_sqrt (kk, kk);
+ ss = mpz_get_ui (kk);
+ mpz_clear (kk);
+ return SCM_I_MAKINUM (ss);
+ }
+ else
+ {
+ SCM s;
+
+ s = scm_i_mkbig ();
+ mpz_sqrt (SCM_I_BIG_MPZ (s), SCM_I_BIG_MPZ (k));
+ scm_remember_upto_here_1 (k);
+ return scm_i_normbig (s);
+ }
+}
+
SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0,
(SCM z),
}
else if (SCM_NUMBERP (z))
{
- double xx = scm_to_double (z);
- if (xx < 0)
- return scm_c_make_rectangular (0.0, sqrt (-xx));
- else
- return scm_from_double (sqrt (xx));
+ if (SCM_I_INUMP (z))
+ {
+ scm_t_inum x = SCM_I_INUM (z);
+
+ if (SCM_LIKELY (x >= 0))
+ {
+ if (SCM_LIKELY (SCM_I_FIXNUM_BIT < DBL_MANT_DIG
+ || x < (1L << (DBL_MANT_DIG - 1))))
+ {
+ double root = sqrt (x);
+
+ /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an
+ integer, then the result is exact. */
+ if (root == floor (root))
+ return SCM_I_MAKINUM ((scm_t_inum) root);
+ else
+ return scm_i_from_double (root);
+ }
+ else
+ {
+ mpz_t xx;
+ scm_t_inum root;
+
+ mpz_init_set_ui (xx, x);
+ if (mpz_perfect_square_p (xx))
+ {
+ mpz_sqrt (xx, xx);
+ root = mpz_get_ui (xx);
+ mpz_clear (xx);
+ return SCM_I_MAKINUM (root);
+ }
+ else
+ mpz_clear (xx);
+ }
+ }
+ }
+ else if (SCM_BIGP (z))
+ {
+ if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z)))
+ {
+ SCM root = scm_i_mkbig ();
+
+ mpz_sqrt (SCM_I_BIG_MPZ (root), SCM_I_BIG_MPZ (z));
+ scm_remember_upto_here_1 (z);
+ return scm_i_normbig (root);
+ }
+ else
+ {
+ long expon;
+ double signif = scm_i_big2dbl_2exp (z, &expon);
+
+ if (expon & 1)
+ {
+ signif *= 2;
+ expon--;
+ }
+ if (signif < 0)
+ return scm_c_make_rectangular
+ (0.0, ldexp (sqrt (-signif), expon / 2));
+ else
+ return scm_i_from_double (ldexp (sqrt (signif), expon / 2));
+ }
+ }
+ else if (SCM_FRACTIONP (z))
+ {
+ SCM n = SCM_FRACTION_NUMERATOR (z);
+ SCM d = SCM_FRACTION_DENOMINATOR (z);
+
+ if (exact_integer_is_perfect_square (n)
+ && exact_integer_is_perfect_square (d))
+ return scm_i_make_ratio_already_reduced
+ (exact_integer_floor_square_root (n),
+ exact_integer_floor_square_root (d));
+ else
+ {
+ double xx = scm_i_divide2double (n, d);
+ double abs_xx = fabs (xx);
+ long shift = 0;
+
+ if (SCM_UNLIKELY (abs_xx > DBL_MAX || abs_xx < DBL_MIN))
+ {
+ shift = (scm_to_long (scm_integer_length (n))
+ - scm_to_long (scm_integer_length (d))) / 2;
+ if (shift > 0)
+ d = left_shift_exact_integer (d, 2 * shift);
+ else
+ n = left_shift_exact_integer (n, -2 * shift);
+ xx = scm_i_divide2double (n, d);
+ }
+
+ if (xx < 0)
+ return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx), shift));
+ else
+ return scm_i_from_double (ldexp (sqrt (xx), shift));
+ }
+ }
+
+ /* Fallback method, when the cases above do not apply. */
+ {
+ double xx = scm_to_double (z);
+ if (xx < 0)
+ return scm_c_make_rectangular (0.0, sqrt (-xx));
+ else
+ return scm_i_from_double (sqrt (xx));
+ }
}
else
SCM_WTA_DISPATCH_1 (g_scm_sqrt, z, 1, s_scm_sqrt);
void
scm_init_numbers ()
{
- int i;
-
if (scm_install_gmp_memory_functions)
mp_set_memory_functions (custom_gmp_malloc,
custom_gmp_realloc,
scm_add_feature ("complex");
scm_add_feature ("inexact");
- flo0 = scm_from_double (0.0);
- flo_log10e = scm_from_double (M_LOG10E);
-
- /* determine floating point precision */
- for (i=2; i <= SCM_MAX_DBL_RADIX; ++i)
- {
- init_dblprec(&scm_dblprec[i-2],i);
- init_fx_radix(fx_per_radix[i-2],i);
- }
-#ifdef DBL_DIG
- /* hard code precision for base 10 if the preprocessor tells us to... */
- scm_dblprec[10-2] = (DBL_DIG > 20) ? 20 : DBL_DIG;
-#endif
+ flo0 = scm_i_from_double (0.0);
+ flo_log10e = scm_i_from_double (M_LOG10E);
exactly_one_half = scm_divide (SCM_INUM1, SCM_I_MAKINUM (2));
+
+ {
+ /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
+ mpz_init_set_ui (scm_i_divide2double_lo2b, 1);
+ mpz_mul_2exp (scm_i_divide2double_lo2b,
+ scm_i_divide2double_lo2b,
+ DBL_MANT_DIG + 1); /* 2 b^p */
+ mpz_sub_ui (scm_i_divide2double_lo2b, scm_i_divide2double_lo2b, 1);
+ }
+
+ {
+ /* Set dbl_minimum_normal_mantissa to b^{p-1} */
+ mpz_init_set_ui (dbl_minimum_normal_mantissa, 1);
+ mpz_mul_2exp (dbl_minimum_normal_mantissa,
+ dbl_minimum_normal_mantissa,
+ DBL_MANT_DIG - 1);
+ }
+
#include "libguile/numbers.x"
}
HCoop / bpt / guile.git / blobdiff