-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010, 2011 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.
# include <config.h>
#endif
+#include <verify.h>
+
#include <math.h>
#include <string.h>
#include <unicase.h>
#include <complex.h>
#endif
+#include <stdarg.h>
+
#include "libguile/_scm.h"
#include "libguile/feature.h"
#include "libguile/ports.h"
#ifndef M_LOG10E
#define M_LOG10E 0.43429448190325182765
#endif
+#ifndef M_LN2
+#define M_LN2 0.69314718055994530942
+#endif
#ifndef M_PI
#define M_PI 3.14159265358979323846
#endif
+/* FIXME: We assume that FLT_RADIX is 2 */
+verify (FLT_RADIX == 2);
+
typedef scm_t_signed_bits scm_t_inum;
#define scm_from_inum(x) (scm_from_signed_integer (x))
#define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
#define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0))
+/* 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)
+
+#endif
+
\f
/*
/* the macro above will not work as is with fractions */
+/* Default to 1, because as we used to hard-code `free' as the
+ deallocator, we know that overriding these functions with
+ instrumented `malloc' / `free' is OK. */
+int scm_install_gmp_memory_functions = 1;
static SCM flo0;
static SCM exactly_one_half;
+static SCM flo_log10e;
#define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
static double atanh (double x) { return 0.5 * log ((1 + x) / (1 - x)); }
#endif
-/* mpz_cmp_d in gmp 4.1.3 doesn't recognise infinities, so xmpz_cmp_d uses
- an explicit check. In some future gmp (don't know what version number),
- mpz_cmp_d is supposed to do this itself. */
+/* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
+ xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
+ in March 2006), mpz_cmp_d now handles infinities properly. */
#if 1
#define xmpz_cmp_d(z, d) \
(isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
#if defined (GUILE_I)
-#if HAVE_COMPLEX_DOUBLE
+#if defined HAVE_COMPLEX_DOUBLE
/* For an SCM object Z which is a complex number (ie. satisfies
SCM_COMPLEXP), return its value as a C level "complex double". */
static mpz_t z_negative_one;
\f
+
/* Clear the `mpz_t' embedded in bignum PTR. */
static void
-finalize_bignum (GC_PTR ptr, GC_PTR data)
+finalize_bignum (void *ptr, void *data)
{
SCM bignum;
- bignum = PTR2SCM (ptr);
+ bignum = SCM_PACK_POINTER (ptr);
mpz_clear (SCM_I_BIG_MPZ (bignum));
}
+/* The next three functions (custom_libgmp_*) are passed to
+ mp_set_memory_functions (in GMP) so that memory used by the digits
+ themselves is known to the garbage collector. This is needed so
+ that GC will be run at appropriate times. Otherwise, a program which
+ creates many large bignums would malloc a huge amount of memory
+ before the GC runs. */
+static void *
+custom_gmp_malloc (size_t alloc_size)
+{
+ return scm_malloc (alloc_size);
+}
+
+static void *
+custom_gmp_realloc (void *old_ptr, size_t old_size, size_t new_size)
+{
+ return scm_realloc (old_ptr, new_size);
+}
+
+static void
+custom_gmp_free (void *ptr, size_t size)
+{
+ free (ptr);
+}
+
+
/* Return a new uninitialized bignum. */
static inline SCM
make_bignum (void)
{
scm_t_bits *p;
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalizer_data;
/* Allocate one word for the type tag and enough room for an `mpz_t'. */
p = scm_gc_malloc_pointerless (sizeof (scm_t_bits) + sizeof (mpz_t),
"bignum");
p[0] = scm_tc16_big;
- GC_REGISTER_FINALIZER_NO_ORDER (p, finalize_bignum, NULL,
- &prev_finalizer,
- &prev_finalizer_data);
+ scm_i_set_finalizer (p, finalize_bignum, NULL);
return SCM_PACK (p);
}
return scm_i_dbl2big (u);
}
-/* scm_i_big2dbl() rounds to the closest representable double, in accordance
- with R5RS exact->inexact.
-
- The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
- (ie. truncate towards zero), then adjust to get the closest double by
- examining the next lower bit and adding 1 (to the absolute value) if
- necessary.
-
- Bignums exactly half way between representable doubles are rounded to the
- next higher absolute value (ie. away from zero). This seems like an
- adequate interpretation of R5RS "numerically closest", and it's easier
- and faster than a full "nearest-even" style.
-
- The bit test must be done on the absolute value of the mpz_t, which means
- we need to use mpz_getlimbn. mpz_tstbit is not right, it treats
- negatives as twos complement.
+static SCM round_right_shift_exact_integer (SCM n, long count);
- In current gmp 4.1.3, mpz_get_d rounding is unspecified. It ends up
- following the hardware rounding mode, but applied to the absolute value
- of the mpz_t operand. This is not what we want so we put the high
- DBL_MANT_DIG bits into a temporary. In some future gmp, don't know when,
- mpz_get_d is supposed to always truncate towards zero.
+/* scm_i_big2dbl_2exp() is like frexp for bignums: it converts the
+ bignum b into a normalized significand and exponent such that
+ b = significand * 2^exponent and 1/2 <= abs(significand) < 1.
+ The return value is the significand rounded to the closest
+ representable double, and the exponent is placed into *expon_p.
+ If b is zero, then the returned exponent and significand are both
+ zero. */
- ENHANCE-ME: The temporary init+clear to force the rounding in gmp 4.1.3
- is a slowdown. It'd be faster to pick out the relevant high bits with
- mpz_getlimbn if we could be bothered coding that, and if the new
- truncating gmp doesn't come out. */
-
-double
-scm_i_big2dbl (SCM b)
+static double
+scm_i_big2dbl_2exp (SCM b, long *expon_p)
{
- double result;
- size_t bits;
-
- bits = mpz_sizeinbase (SCM_I_BIG_MPZ (b), 2);
-
-#if 1
- {
- /* Current GMP, eg. 4.1.3, force truncation towards zero */
- mpz_t tmp;
- if (bits > DBL_MANT_DIG)
- {
- size_t shift = bits - DBL_MANT_DIG;
- mpz_init2 (tmp, DBL_MANT_DIG);
- mpz_tdiv_q_2exp (tmp, SCM_I_BIG_MPZ (b), shift);
- result = ldexp (mpz_get_d (tmp), shift);
- mpz_clear (tmp);
- }
- else
- {
- result = mpz_get_d (SCM_I_BIG_MPZ (b));
- }
- }
-#else
- /* Future GMP */
- result = mpz_get_d (SCM_I_BIG_MPZ (b));
-#endif
+ size_t bits = mpz_sizeinbase (SCM_I_BIG_MPZ (b), 2);
+ size_t shift = 0;
if (bits > DBL_MANT_DIG)
{
- unsigned long pos = bits - DBL_MANT_DIG - 1;
- /* test bit number "pos" in absolute value */
- if (mpz_getlimbn (SCM_I_BIG_MPZ (b), pos / GMP_NUMB_BITS)
- & ((mp_limb_t) 1 << (pos % GMP_NUMB_BITS)))
+ shift = bits - DBL_MANT_DIG;
+ b = round_right_shift_exact_integer (b, shift);
+ if (SCM_I_INUMP (b))
{
- result += ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b)), pos + 1);
+ int expon;
+ double signif = frexp (SCM_I_INUM (b), &expon);
+ *expon_p = expon + shift;
+ return signif;
}
}
- scm_remember_upto_here_1 (b);
- return result;
+ {
+ long expon;
+ double signif = mpz_get_d_2exp (&expon, SCM_I_BIG_MPZ (b));
+ scm_remember_upto_here_1 (b);
+ *expon_p = expon + shift;
+ return signif;
+ }
+}
+
+/* scm_i_big2dbl() rounds to the closest representable double,
+ in accordance with R5RS exact->inexact. */
+double
+scm_i_big2dbl (SCM b)
+{
+ long expon;
+ double signif = scm_i_big2dbl_2exp (b, &expon);
+ return ldexp (signif, expon);
}
SCM
}
}
-/* 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 */
static SCM
-scm_i_make_ratio (SCM numerator, SCM denominator)
-#define FUNC_NAME "make-ratio"
+scm_i_make_ratio_already_reduced (SCM numerator, SCM denominator)
{
- /* First make sure the arguments are proper.
- */
- if (SCM_I_INUMP (denominator))
+ /* Flip signs so that the denominator is positive. */
+ if (scm_is_false (scm_positive_p (denominator)))
{
- if (scm_is_eq (denominator, SCM_INUM0))
+ if (SCM_UNLIKELY (scm_is_eq (denominator, SCM_INUM0)))
scm_num_overflow ("make-ratio");
- if (scm_is_eq (denominator, SCM_INUM1))
- return numerator;
- }
- else
- {
- if (!(SCM_BIGP(denominator)))
- SCM_WRONG_TYPE_ARG (2, denominator);
+ else
+ {
+ numerator = scm_difference (numerator, SCM_UNDEFINED);
+ denominator = scm_difference (denominator, SCM_UNDEFINED);
+ }
}
- if (!SCM_I_INUMP (numerator) && !SCM_BIGP (numerator))
- SCM_WRONG_TYPE_ARG (1, numerator);
- /* Then flip signs so that the denominator is positive.
- */
- if (scm_is_true (scm_negative_p (denominator)))
- {
- numerator = scm_difference (numerator, SCM_UNDEFINED);
- denominator = scm_difference (denominator, SCM_UNDEFINED);
- }
+ /* Check for the integer case */
+ if (scm_is_eq (denominator, SCM_INUM1))
+ return numerator;
- /* Now consider for each of the four fixnum/bignum combinations
- whether the rational number is really an integer.
- */
- if (SCM_I_INUMP (numerator))
+ return scm_double_cell (scm_tc16_fraction,
+ SCM_UNPACK (numerator),
+ SCM_UNPACK (denominator), 0);
+}
+
+static SCM scm_exact_integer_quotient (SCM x, SCM y);
+
+/* Make the ratio NUMERATOR/DENOMINATOR */
+static SCM
+scm_i_make_ratio (SCM numerator, SCM denominator)
+#define FUNC_NAME "make-ratio"
+{
+ /* Make sure the arguments are proper */
+ if (!SCM_LIKELY (SCM_I_INUMP (numerator) || SCM_BIGP (numerator)))
+ SCM_WRONG_TYPE_ARG (1, numerator);
+ else if (!SCM_LIKELY (SCM_I_INUMP (denominator) || SCM_BIGP (denominator)))
+ SCM_WRONG_TYPE_ARG (2, denominator);
+ else
{
- scm_t_inum x = SCM_I_INUM (numerator);
- if (scm_is_eq (numerator, SCM_INUM0))
- return SCM_INUM0;
- if (SCM_I_INUMP (denominator))
+ SCM the_gcd = scm_gcd (numerator, denominator);
+ if (!(scm_is_eq (the_gcd, SCM_INUM1)))
{
- scm_t_inum y;
- y = SCM_I_INUM (denominator);
- if (x == y)
- return SCM_INUM1;
- if ((x % y) == 0)
- return SCM_I_MAKINUM (x / y);
+ /* Reduce to lowest terms */
+ numerator = scm_exact_integer_quotient (numerator, the_gcd);
+ denominator = scm_exact_integer_quotient (denominator, the_gcd);
}
- else
- {
- /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative
- of that value for the denominator, as a bignum. Apart from
- that case, abs(bignum) > abs(inum) so inum/bignum is not an
- integer. */
- if (x == SCM_MOST_NEGATIVE_FIXNUM
- && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator),
- - SCM_MOST_NEGATIVE_FIXNUM) == 0)
- return SCM_I_MAKINUM(-1);
- }
+ return scm_i_make_ratio_already_reduced (numerator, denominator);
}
- else if (SCM_BIGP (numerator))
+}
+#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_I_INUMP (denominator))
- {
- scm_t_inum yy = SCM_I_INUM (denominator);
- if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator), yy))
- return scm_divide (numerator, denominator);
- }
- else
- {
- if (scm_is_eq (numerator, denominator))
- return SCM_INUM1;
- if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator),
- SCM_I_BIG_MPZ (denominator)))
- return scm_divide(numerator, denominator);
- }
+ 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));
- /* No, it's a proper fraction.
- */
+ 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) */
{
- SCM divisor = scm_gcd (numerator, denominator);
- if (!(scm_is_eq (divisor, SCM_INUM1)))
- {
- numerator = scm_divide (numerator, divisor);
- denominator = scm_divide (denominator, divisor);
- }
-
- return scm_double_cell (scm_tc16_fraction,
- SCM_UNPACK (numerator),
- SCM_UNPACK (denominator), 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;
}
}
-#undef FUNC_NAME
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
else if (SCM_NUMBERP (x))
return SCM_BOOL_T;
else
- SCM_WTA_DISPATCH_1 (g_scm_exact_p, x, 1, s_scm_exact_p);
+ return scm_wta_dispatch_1 (g_scm_exact_p, x, 1, s_scm_exact_p);
}
#undef FUNC_NAME
+int
+scm_is_exact (SCM val)
+{
+ return scm_is_true (scm_exact_p (val));
+}
SCM_PRIMITIVE_GENERIC (scm_inexact_p, "inexact?", 1, 0, 0,
(SCM x),
else if (SCM_NUMBERP (x))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_1 (g_scm_inexact_p, x, 1, s_scm_inexact_p);
+ return scm_wta_dispatch_1 (g_scm_inexact_p, x, 1, s_scm_inexact_p);
}
#undef FUNC_NAME
+int
+scm_is_inexact (SCM val)
+{
+ return scm_is_true (scm_inexact_p (val));
+}
SCM_PRIMITIVE_GENERIC (scm_odd_p, "odd?", 1, 0, 0,
(SCM n),
return SCM_BOOL_F;
}
}
- SCM_WTA_DISPATCH_1 (g_scm_odd_p, n, 1, s_scm_odd_p);
+ return scm_wta_dispatch_1 (g_scm_odd_p, n, 1, s_scm_odd_p);
}
#undef FUNC_NAME
return SCM_BOOL_T;
}
}
- SCM_WTA_DISPATCH_1 (g_scm_even_p, n, 1, s_scm_even_p);
+ return scm_wta_dispatch_1 (g_scm_even_p, n, 1, s_scm_even_p);
}
#undef FUNC_NAME
else if (scm_is_real (x))
return SCM_BOOL_T;
else
- SCM_WTA_DISPATCH_1 (g_scm_finite_p, x, 1, s_scm_finite_p);
+ return scm_wta_dispatch_1 (g_scm_finite_p, x, 1, s_scm_finite_p);
}
#undef FUNC_NAME
else if (scm_is_real (x))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_1 (g_scm_inf_p, x, 1, s_scm_inf_p);
+ return scm_wta_dispatch_1 (g_scm_inf_p, x, 1, s_scm_inf_p);
}
#undef FUNC_NAME
else if (scm_is_real (x))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_1 (g_scm_nan_p, x, 1, s_scm_nan_p);
+ return scm_wta_dispatch_1 (g_scm_nan_p, x, 1, s_scm_nan_p);
}
#undef FUNC_NAME
{
if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x))))
return x;
- return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
- SCM_FRACTION_DENOMINATOR (x));
+ return scm_i_make_ratio_already_reduced
+ (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
+ SCM_FRACTION_DENOMINATOR (x));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_abs, x, 1, s_scm_abs);
+ return scm_wta_dispatch_1 (g_scm_abs, x, 1, s_scm_abs);
}
#undef FUNC_NAME
"Return the quotient of the numbers @var{x} and @var{y}.")
#define FUNC_NAME s_scm_quotient
{
- if (SCM_LIKELY (SCM_I_INUMP (x)))
- {
- scm_t_inum xx = SCM_I_INUM (x);
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_quotient);
- else
- {
- scm_t_inum z = xx / yy;
- if (SCM_LIKELY (SCM_FIXABLE (z)))
- return SCM_I_MAKINUM (z);
- else
- return scm_i_inum2big (z);
- }
- }
- else if (SCM_BIGP (y))
- {
- if ((SCM_I_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM)
- && (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
- - SCM_MOST_NEGATIVE_FIXNUM) == 0))
- {
- /* Special case: x == fixnum-min && y == abs (fixnum-min) */
- scm_remember_upto_here_1 (y);
- return SCM_I_MAKINUM (-1);
- }
- else
- return SCM_INUM0;
- }
- else
- SCM_WTA_DISPATCH_2 (g_scm_quotient, x, y, SCM_ARG2, s_scm_quotient);
- }
- else if (SCM_BIGP (x))
+ if (SCM_LIKELY (scm_is_integer (x)))
{
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_quotient);
- else if (SCM_UNLIKELY (yy == 1))
- return x;
- else
- {
- SCM result = scm_i_mkbig ();
- if (yy < 0)
- {
- mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result),
- SCM_I_BIG_MPZ (x),
- - yy);
- mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
- }
- else
- mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);
- scm_remember_upto_here_1 (x);
- return scm_i_normbig (result);
- }
- }
- else if (SCM_BIGP (y))
- {
- SCM result = scm_i_mkbig ();
- mpz_tdiv_q (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);
- }
+ if (SCM_LIKELY (scm_is_integer (y)))
+ return scm_truncate_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_quotient, x, y, SCM_ARG2, s_scm_quotient);
+ return scm_wta_dispatch_2 (g_scm_quotient, x, y, SCM_ARG2, s_scm_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_quotient, x, y, SCM_ARG1, s_scm_quotient);
+ return scm_wta_dispatch_2 (g_scm_quotient, x, y, SCM_ARG1, s_scm_quotient);
}
#undef FUNC_NAME
"@end lisp")
#define FUNC_NAME s_scm_remainder
{
- if (SCM_LIKELY (SCM_I_INUMP (x)))
- {
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_remainder);
- else
- {
- /* C99 specifies that "%" is the remainder corresponding to a
- quotient rounded towards zero, and that's also traditional
- for machine division, so z here should be well defined. */
- scm_t_inum z = SCM_I_INUM (x) % yy;
- return SCM_I_MAKINUM (z);
- }
- }
- else if (SCM_BIGP (y))
- {
- if ((SCM_I_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM)
- && (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
- - SCM_MOST_NEGATIVE_FIXNUM) == 0))
- {
- /* Special case: x == fixnum-min && y == abs (fixnum-min) */
- scm_remember_upto_here_1 (y);
- return SCM_INUM0;
- }
- else
- return x;
- }
- else
- SCM_WTA_DISPATCH_2 (g_scm_remainder, x, y, SCM_ARG2, s_scm_remainder);
- }
- else if (SCM_BIGP (x))
+ if (SCM_LIKELY (scm_is_integer (x)))
{
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_remainder);
- else
- {
- SCM result = scm_i_mkbig ();
- if (yy < 0)
- yy = - yy;
- mpz_tdiv_r_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ(x), yy);
- scm_remember_upto_here_1 (x);
- return scm_i_normbig (result);
- }
- }
- else if (SCM_BIGP (y))
- {
- SCM result = scm_i_mkbig ();
- mpz_tdiv_r (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);
- }
+ if (SCM_LIKELY (scm_is_integer (y)))
+ return scm_truncate_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_remainder, x, y, SCM_ARG2, s_scm_remainder);
+ return scm_wta_dispatch_2 (g_scm_remainder, x, y, SCM_ARG2, s_scm_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_remainder, x, y, SCM_ARG1, s_scm_remainder);
+ return scm_wta_dispatch_2 (g_scm_remainder, x, y, SCM_ARG1, s_scm_remainder);
}
#undef FUNC_NAME
"@end lisp")
#define FUNC_NAME s_scm_modulo
{
- if (SCM_LIKELY (SCM_I_INUMP (x)))
+ if (SCM_LIKELY (scm_is_integer (x)))
{
- scm_t_inum xx = SCM_I_INUM (x);
- if (SCM_LIKELY (SCM_I_INUMP (y)))
+ if (SCM_LIKELY (scm_is_integer (y)))
+ return scm_floor_remainder (x, y);
+ else
+ return scm_wta_dispatch_2 (g_scm_modulo, x, y, SCM_ARG2, s_scm_modulo);
+ }
+ else
+ return scm_wta_dispatch_2 (g_scm_modulo, x, y, SCM_ARG1, s_scm_modulo);
+}
+#undef FUNC_NAME
+
+/* Return the exact integer q such that n = q*d, for exact integers n
+ and d, where d is known in advance to divide n evenly (with zero
+ remainder). For large integers, this can be computed more
+ efficiently than when the remainder is unknown. */
+static SCM
+scm_exact_integer_quotient (SCM n, SCM d)
+#define FUNC_NAME "exact-integer-quotient"
+{
+ if (SCM_LIKELY (SCM_I_INUMP (n)))
+ {
+ scm_t_inum nn = SCM_I_INUM (n);
+ if (SCM_LIKELY (SCM_I_INUMP (d)))
{
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_modulo);
+ scm_t_inum dd = SCM_I_INUM (d);
+ if (SCM_UNLIKELY (dd == 0))
+ scm_num_overflow ("exact-integer-quotient");
else
{
- /* C99 specifies that "%" is the remainder corresponding to a
- quotient rounded towards zero, and that's also traditional
- for machine division, so z here should be well defined. */
- scm_t_inum z = xx % yy;
- scm_t_inum result;
-
- if (yy < 0)
- {
- if (z > 0)
- result = z + yy;
- else
- result = z;
- }
+ scm_t_inum qq = nn / dd;
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ return SCM_I_MAKINUM (qq);
else
- {
- if (z < 0)
- result = z + yy;
- else
- result = z;
- }
- return SCM_I_MAKINUM (result);
+ return scm_i_inum2big (qq);
}
}
- else if (SCM_BIGP (y))
+ else if (SCM_LIKELY (SCM_BIGP (d)))
{
- int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
- {
- mpz_t z_x;
- SCM result;
-
- if (sgn_y < 0)
- {
- SCM pos_y = scm_i_clonebig (y, 0);
- /* do this after the last scm_op */
- mpz_init_set_si (z_x, xx);
- result = pos_y; /* re-use this bignum */
- mpz_mod (SCM_I_BIG_MPZ (result),
- z_x,
- SCM_I_BIG_MPZ (pos_y));
- scm_remember_upto_here_1 (pos_y);
- }
- else
- {
- result = scm_i_mkbig ();
- /* do this after the last scm_op */
- mpz_init_set_si (z_x, xx);
- mpz_mod (SCM_I_BIG_MPZ (result),
- z_x,
- SCM_I_BIG_MPZ (y));
- scm_remember_upto_here_1 (y);
- }
-
- if ((sgn_y < 0) && mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)
- mpz_add (SCM_I_BIG_MPZ (result),
- SCM_I_BIG_MPZ (y),
- SCM_I_BIG_MPZ (result));
- scm_remember_upto_here_1 (y);
- /* and do this before the next one */
- mpz_clear (z_x);
- return scm_i_normbig (result);
- }
+ /* n is an inum and d is a bignum. Given that d is known to
+ divide n evenly, there are only two possibilities: n is 0,
+ or else n is fixnum-min and d is abs(fixnum-min). */
+ if (nn == 0)
+ return SCM_INUM0;
+ else
+ return SCM_I_MAKINUM (-1);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_modulo, x, y, SCM_ARG2, s_scm_modulo);
+ SCM_WRONG_TYPE_ARG (2, d);
}
- else if (SCM_BIGP (x))
+ else if (SCM_LIKELY (SCM_BIGP (n)))
{
- if (SCM_LIKELY (SCM_I_INUMP (y)))
+ if (SCM_LIKELY (SCM_I_INUMP (d)))
{
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_modulo);
+ scm_t_inum dd = SCM_I_INUM (d);
+ if (SCM_UNLIKELY (dd == 0))
+ scm_num_overflow ("exact-integer-quotient");
+ else if (SCM_UNLIKELY (dd == 1))
+ return n;
else
{
- SCM result = scm_i_mkbig ();
- mpz_mod_ui (SCM_I_BIG_MPZ (result),
- SCM_I_BIG_MPZ (x),
- (yy < 0) ? - yy : yy);
- scm_remember_upto_here_1 (x);
- if ((yy < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0))
- mpz_sub_ui (SCM_I_BIG_MPZ (result),
- SCM_I_BIG_MPZ (result),
- - yy);
- return scm_i_normbig (result);
+ SCM q = scm_i_mkbig ();
+ if (dd > 0)
+ mpz_divexact_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (n), dd);
+ else
+ {
+ mpz_divexact_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (n), -dd);
+ mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
+ }
+ scm_remember_upto_here_1 (n);
+ return scm_i_normbig (q);
}
}
- else if (SCM_BIGP (y))
+ else if (SCM_LIKELY (SCM_BIGP (d)))
{
- SCM result = scm_i_mkbig ();
- int y_sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
- SCM pos_y = scm_i_clonebig (y, y_sgn >= 0);
- mpz_mod (SCM_I_BIG_MPZ (result),
- SCM_I_BIG_MPZ (x),
- SCM_I_BIG_MPZ (pos_y));
-
- scm_remember_upto_here_1 (x);
- if ((y_sgn < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0))
- mpz_add (SCM_I_BIG_MPZ (result),
- SCM_I_BIG_MPZ (y),
- SCM_I_BIG_MPZ (result));
- scm_remember_upto_here_2 (y, pos_y);
- return scm_i_normbig (result);
- }
+ SCM q = scm_i_mkbig ();
+ mpz_divexact (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (n),
+ SCM_I_BIG_MPZ (d));
+ scm_remember_upto_here_2 (n, d);
+ return scm_i_normbig (q);
+ }
else
- SCM_WTA_DISPATCH_2 (g_scm_modulo, x, y, SCM_ARG2, s_scm_modulo);
+ SCM_WRONG_TYPE_ARG (2, d);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_modulo, x, y, SCM_ARG1, s_scm_modulo);
+ SCM_WRONG_TYPE_ARG (1, n);
}
#undef FUNC_NAME
static void
two_valued_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos,
const char *subr, SCM *rp1, SCM *rp2)
-{
- if (SCM_UNPACK (gf))
- scm_i_extract_values_2 (scm_call_generic_2 (gf, a1, a2), rp1, rp2);
- else
- scm_wrong_type_arg (subr, pos, (pos == SCM_ARG1) ? a1 : a2);
-}
-
-static SCM scm_i_inexact_euclidean_quotient (double x, double y);
-static SCM scm_i_exact_rational_euclidean_quotient (SCM x, SCM y);
-
-SCM_PRIMITIVE_GENERIC (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
- (SCM x, SCM y),
- "Return the integer @var{q} such that\n"
- "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
- "where @math{0 <= @var{r} < abs(@var{y})}.\n"
- "@lisp\n"
- "(euclidean-quotient 123 10) @result{} 12\n"
- "(euclidean-quotient 123 -10) @result{} -12\n"
- "(euclidean-quotient -123 10) @result{} -13\n"
- "(euclidean-quotient -123 -10) @result{} 13\n"
- "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
- "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
- "@end lisp")
-#define FUNC_NAME s_scm_euclidean_quotient
-{
- if (SCM_LIKELY (SCM_I_INUMP (x)))
- {
- scm_t_inum xx = SCM_I_INUM (x);
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_euclidean_quotient);
- else
- {
- scm_t_inum qq = xx / yy;
- if (xx < qq * yy)
- {
- if (yy > 0)
- qq--;
- else
- qq++;
- }
- if (SCM_LIKELY (SCM_FIXABLE (qq)))
- return SCM_I_MAKINUM (qq);
- else
- return scm_i_inum2big (qq);
- }
- }
- else if (SCM_BIGP (y))
- {
- if (xx >= 0)
- return SCM_INUM0;
- else
- {
- scm_t_inum qq = - mpz_sgn (SCM_I_BIG_MPZ (y));
- scm_remember_upto_here_1 (y);
- return SCM_I_MAKINUM (qq);
- }
- }
- else if (SCM_REALP (y))
- return scm_i_inexact_euclidean_quotient (xx, SCM_REAL_VALUE (y));
- else if (SCM_FRACTIONP (y))
- return scm_i_exact_rational_euclidean_quotient (x, y);
- else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG2,
- s_scm_euclidean_quotient);
- }
- else if (SCM_BIGP (x))
- {
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_euclidean_quotient);
- else if (SCM_UNLIKELY (yy == 1))
- return x;
- else
- {
- SCM q = scm_i_mkbig ();
- if (yy > 0)
- mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
- else
- {
- mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy);
- mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
- }
- scm_remember_upto_here_1 (x);
- return scm_i_normbig (q);
- }
- }
- else if (SCM_BIGP (y))
- {
- SCM q = scm_i_mkbig ();
- if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
- mpz_fdiv_q (SCM_I_BIG_MPZ (q),
- SCM_I_BIG_MPZ (x),
- SCM_I_BIG_MPZ (y));
- else
- mpz_cdiv_q (SCM_I_BIG_MPZ (q),
- SCM_I_BIG_MPZ (x),
- SCM_I_BIG_MPZ (y));
- scm_remember_upto_here_2 (x, y);
- return scm_i_normbig (q);
- }
- else if (SCM_REALP (y))
- return scm_i_inexact_euclidean_quotient
- (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
- else if (SCM_FRACTIONP (y))
- return scm_i_exact_rational_euclidean_quotient (x, y);
- else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG2,
- s_scm_euclidean_quotient);
- }
- else if (SCM_REALP (x))
- {
- if (SCM_REALP (y) || SCM_I_INUMP (y) ||
- SCM_BIGP (y) || SCM_FRACTIONP (y))
- return scm_i_inexact_euclidean_quotient
- (SCM_REAL_VALUE (x), scm_to_double (y));
- else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG2,
- s_scm_euclidean_quotient);
- }
- else if (SCM_FRACTIONP (x))
- {
- if (SCM_REALP (y))
- return scm_i_inexact_euclidean_quotient
- (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
- else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
- return scm_i_exact_rational_euclidean_quotient (x, y);
- else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG2,
- s_scm_euclidean_quotient);
- }
- else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG1,
- s_scm_euclidean_quotient);
-}
-#undef FUNC_NAME
-
-static SCM
-scm_i_inexact_euclidean_quotient (double x, double y)
-{
- if (SCM_LIKELY (y > 0))
- return scm_from_double (floor (x / y));
- else if (SCM_LIKELY (y < 0))
- return scm_from_double (ceil (x / y));
- else if (y == 0)
- scm_num_overflow (s_scm_euclidean_quotient); /* or return a NaN? */
- else
- return scm_nan ();
-}
-
-static SCM
-scm_i_exact_rational_euclidean_quotient (SCM x, SCM y)
-{
- return scm_euclidean_quotient
- (scm_product (scm_numerator (x), scm_denominator (y)),
- scm_product (scm_numerator (y), scm_denominator (x)));
-}
-
-static SCM scm_i_inexact_euclidean_remainder (double x, double y);
-static SCM scm_i_exact_rational_euclidean_remainder (SCM x, SCM y);
-
-SCM_PRIMITIVE_GENERIC (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
- (SCM x, SCM y),
- "Return the real number @var{r} such that\n"
- "@math{0 <= @var{r} < abs(@var{y})} and\n"
- "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
- "for some integer @var{q}.\n"
- "@lisp\n"
- "(euclidean-remainder 123 10) @result{} 3\n"
- "(euclidean-remainder 123 -10) @result{} 3\n"
- "(euclidean-remainder -123 10) @result{} 7\n"
- "(euclidean-remainder -123 -10) @result{} 7\n"
- "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
- "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
- "@end lisp")
-#define FUNC_NAME s_scm_euclidean_remainder
-{
- if (SCM_LIKELY (SCM_I_INUMP (x)))
- {
- scm_t_inum xx = SCM_I_INUM (x);
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_euclidean_remainder);
- else
- {
- scm_t_inum rr = xx % yy;
- if (rr >= 0)
- return SCM_I_MAKINUM (rr);
- else if (yy > 0)
- return SCM_I_MAKINUM (rr + yy);
- else
- return SCM_I_MAKINUM (rr - yy);
- }
- }
- else if (SCM_BIGP (y))
- {
- if (xx >= 0)
- return x;
- else if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
- {
- SCM r = scm_i_mkbig ();
- mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
- scm_remember_upto_here_1 (y);
- return scm_i_normbig (r);
- }
- else
- {
- SCM r = scm_i_mkbig ();
- mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
- scm_remember_upto_here_1 (y);
- mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
- return scm_i_normbig (r);
- }
- }
- else if (SCM_REALP (y))
- return scm_i_inexact_euclidean_remainder (xx, SCM_REAL_VALUE (y));
- else if (SCM_FRACTIONP (y))
- return scm_i_exact_rational_euclidean_remainder (x, y);
- else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG2,
- s_scm_euclidean_remainder);
- }
- else if (SCM_BIGP (x))
- {
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_euclidean_remainder);
- else
- {
- scm_t_inum rr;
- if (yy < 0)
- yy = -yy;
- rr = mpz_fdiv_ui (SCM_I_BIG_MPZ (x), yy);
- scm_remember_upto_here_1 (x);
- return SCM_I_MAKINUM (rr);
- }
- }
- else if (SCM_BIGP (y))
- {
- SCM r = scm_i_mkbig ();
- mpz_mod (SCM_I_BIG_MPZ (r),
- SCM_I_BIG_MPZ (x),
- SCM_I_BIG_MPZ (y));
- scm_remember_upto_here_2 (x, y);
- return scm_i_normbig (r);
- }
- else if (SCM_REALP (y))
- return scm_i_inexact_euclidean_remainder
- (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
- else if (SCM_FRACTIONP (y))
- return scm_i_exact_rational_euclidean_remainder (x, y);
- else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG2,
- s_scm_euclidean_remainder);
- }
- else if (SCM_REALP (x))
- {
- if (SCM_REALP (y) || SCM_I_INUMP (y) ||
- SCM_BIGP (y) || SCM_FRACTIONP (y))
- return scm_i_inexact_euclidean_remainder
- (SCM_REAL_VALUE (x), scm_to_double (y));
- else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG2,
- s_scm_euclidean_remainder);
- }
- else if (SCM_FRACTIONP (x))
- {
- if (SCM_REALP (y))
- return scm_i_inexact_euclidean_remainder
- (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
- else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
- return scm_i_exact_rational_euclidean_remainder (x, y);
- else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG2,
- s_scm_euclidean_remainder);
- }
- else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG1,
- s_scm_euclidean_remainder);
-}
-#undef FUNC_NAME
-
-static SCM
-scm_i_inexact_euclidean_remainder (double x, double y)
-{
- double q;
-
- /* Although it would be more efficient to use fmod here, we can't
- because it would in some cases produce results inconsistent with
- scm_i_inexact_euclidean_quotient, such that x != q * y + r (not
- even close). In particular, when x is very close to a multiple of
- y, then r might be either 0.0 or abs(y)-epsilon, but those two
- cases must correspond to different choices of q. If r = 0.0 then q
- must be x/y, and if r = abs(y) then q must be (x-r)/y. If quotient
- chooses one and remainder chooses the other, it would be bad. This
- problem was observed with x = 130.0 and y = 10/7. */
- if (SCM_LIKELY (y > 0))
- q = floor (x / y);
- else if (SCM_LIKELY (y < 0))
- q = ceil (x / y);
- else if (y == 0)
- scm_num_overflow (s_scm_euclidean_remainder); /* or return a NaN? */
- else
- return scm_nan ();
- return scm_from_double (x - q * y);
-}
-
-static SCM
-scm_i_exact_rational_euclidean_remainder (SCM x, SCM y)
-{
- SCM xd = scm_denominator (x);
- SCM yd = scm_denominator (y);
- SCM r1 = scm_euclidean_remainder (scm_product (scm_numerator (x), yd),
- scm_product (scm_numerator (y), xd));
- return scm_divide (r1, scm_product (xd, yd));
-}
-
-
-static void scm_i_inexact_euclidean_divide (double x, double y,
- SCM *qp, SCM *rp);
-static void scm_i_exact_rational_euclidean_divide (SCM x, SCM y,
- SCM *qp, SCM *rp);
-
-SCM_PRIMITIVE_GENERIC (scm_i_euclidean_divide, "euclidean/", 2, 0, 0,
- (SCM x, SCM y),
- "Return the integer @var{q} and the real number @var{r}\n"
- "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
- "and @math{0 <= @var{r} < abs(@var{y})}.\n"
- "@lisp\n"
- "(euclidean/ 123 10) @result{} 12 and 3\n"
- "(euclidean/ 123 -10) @result{} -12 and 3\n"
- "(euclidean/ -123 10) @result{} -13 and 7\n"
- "(euclidean/ -123 -10) @result{} 13 and 7\n"
- "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
- "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
- "@end lisp")
-#define FUNC_NAME s_scm_i_euclidean_divide
-{
- SCM q, r;
-
- scm_euclidean_divide(x, y, &q, &r);
- return scm_values (scm_list_2 (q, r));
-}
-#undef FUNC_NAME
-
-#define s_scm_euclidean_divide s_scm_i_euclidean_divide
-#define g_scm_euclidean_divide g_scm_i_euclidean_divide
-
-void
-scm_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp)
-{
- if (SCM_LIKELY (SCM_I_INUMP (x)))
- {
- scm_t_inum xx = SCM_I_INUM (x);
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_euclidean_divide);
- else
- {
- scm_t_inum qq = xx / yy;
- scm_t_inum rr = xx % yy;
- if (rr < 0)
- {
- if (yy > 0)
- { rr += yy; qq--; }
- else
- { rr -= yy; qq++; }
- }
- if (SCM_LIKELY (SCM_FIXABLE (qq)))
- *qp = SCM_I_MAKINUM (qq);
- else
- *qp = scm_i_inum2big (qq);
- *rp = SCM_I_MAKINUM (rr);
- }
- return;
- }
- else if (SCM_BIGP (y))
- {
- if (xx >= 0)
- {
- *qp = SCM_INUM0;
- *rp = x;
- }
- else if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
- {
- SCM r = scm_i_mkbig ();
- mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
- scm_remember_upto_here_1 (y);
- *qp = SCM_I_MAKINUM (-1);
- *rp = scm_i_normbig (r);
- }
- else
- {
- SCM r = scm_i_mkbig ();
- mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
- scm_remember_upto_here_1 (y);
- mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
- *qp = SCM_INUM1;
- *rp = scm_i_normbig (r);
- }
- return;
- }
- else if (SCM_REALP (y))
- return scm_i_inexact_euclidean_divide (xx, SCM_REAL_VALUE (y), qp, rp);
- else if (SCM_FRACTIONP (y))
- return scm_i_exact_rational_euclidean_divide (x, y, qp, rp);
- else
- return two_valued_wta_dispatch_2
- (g_scm_euclidean_divide, x, y, SCM_ARG2,
- s_scm_euclidean_divide, qp, rp);
- }
- else if (SCM_BIGP (x))
- {
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_euclidean_divide);
- else
- {
- SCM q = scm_i_mkbig ();
- scm_t_inum rr;
- if (yy > 0)
- rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
- SCM_I_BIG_MPZ (x), yy);
- else
- {
- rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
- SCM_I_BIG_MPZ (x), -yy);
- mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
- }
- scm_remember_upto_here_1 (x);
- *qp = scm_i_normbig (q);
- *rp = SCM_I_MAKINUM (rr);
- }
- return;
- }
- else if (SCM_BIGP (y))
- {
- SCM q = scm_i_mkbig ();
- SCM r = scm_i_mkbig ();
- if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
- mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
- SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
- else
- mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
- SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
- scm_remember_upto_here_2 (x, y);
- *qp = scm_i_normbig (q);
- *rp = scm_i_normbig (r);
- return;
- }
- else if (SCM_REALP (y))
- return scm_i_inexact_euclidean_divide
- (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
- else if (SCM_FRACTIONP (y))
- return scm_i_exact_rational_euclidean_divide (x, y, qp, rp);
- else
- return two_valued_wta_dispatch_2
- (g_scm_euclidean_divide, x, y, SCM_ARG2,
- s_scm_euclidean_divide, qp, rp);
- }
- else if (SCM_REALP (x))
- {
- if (SCM_REALP (y) || SCM_I_INUMP (y) ||
- SCM_BIGP (y) || SCM_FRACTIONP (y))
- return scm_i_inexact_euclidean_divide
- (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
- else
- return two_valued_wta_dispatch_2
- (g_scm_euclidean_divide, x, y, SCM_ARG2,
- s_scm_euclidean_divide, qp, rp);
- }
- else if (SCM_FRACTIONP (x))
- {
- if (SCM_REALP (y))
- return scm_i_inexact_euclidean_divide
- (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
- else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
- return scm_i_exact_rational_euclidean_divide (x, y, qp, rp);
- else
- return two_valued_wta_dispatch_2
- (g_scm_euclidean_divide, x, y, SCM_ARG2,
- s_scm_euclidean_divide, qp, rp);
- }
- else
- return two_valued_wta_dispatch_2 (g_scm_euclidean_divide, x, y, SCM_ARG1,
- s_scm_euclidean_divide, qp, rp);
+{
+ SCM vals = scm_wta_dispatch_2 (gf, a1, a2, pos, subr);
+
+ scm_i_extract_values_2 (vals, rp1, rp2);
}
-static void
-scm_i_inexact_euclidean_divide (double x, double y, SCM *qp, SCM *rp)
+SCM_DEFINE (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the integer @var{q} such that\n"
+ "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "where @math{0 <= @var{r} < abs(@var{y})}.\n"
+ "@lisp\n"
+ "(euclidean-quotient 123 10) @result{} 12\n"
+ "(euclidean-quotient 123 -10) @result{} -12\n"
+ "(euclidean-quotient -123 10) @result{} -13\n"
+ "(euclidean-quotient -123 -10) @result{} 13\n"
+ "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
+ "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_euclidean_quotient
{
- double q, r;
+ if (scm_is_false (scm_negative_p (y)))
+ return scm_floor_quotient (x, y);
+ else
+ return scm_ceiling_quotient (x, y);
+}
+#undef FUNC_NAME
- if (SCM_LIKELY (y > 0))
- q = floor (x / y);
- else if (SCM_LIKELY (y < 0))
- q = ceil (x / y);
- else if (y == 0)
- scm_num_overflow (s_scm_euclidean_divide); /* or return a NaN? */
+SCM_DEFINE (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the real number @var{r} such that\n"
+ "@math{0 <= @var{r} < abs(@var{y})} and\n"
+ "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "for some integer @var{q}.\n"
+ "@lisp\n"
+ "(euclidean-remainder 123 10) @result{} 3\n"
+ "(euclidean-remainder 123 -10) @result{} 3\n"
+ "(euclidean-remainder -123 10) @result{} 7\n"
+ "(euclidean-remainder -123 -10) @result{} 7\n"
+ "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
+ "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_euclidean_remainder
+{
+ if (scm_is_false (scm_negative_p (y)))
+ return scm_floor_remainder (x, y);
else
- q = guile_NaN;
- r = x - q * y;
- *qp = scm_from_double (q);
- *rp = scm_from_double (r);
+ return scm_ceiling_remainder (x, y);
}
+#undef FUNC_NAME
-static void
-scm_i_exact_rational_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp)
+SCM_DEFINE (scm_i_euclidean_divide, "euclidean/", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the integer @var{q} and the real number @var{r}\n"
+ "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "and @math{0 <= @var{r} < abs(@var{y})}.\n"
+ "@lisp\n"
+ "(euclidean/ 123 10) @result{} 12 and 3\n"
+ "(euclidean/ 123 -10) @result{} -12 and 3\n"
+ "(euclidean/ -123 10) @result{} -13 and 7\n"
+ "(euclidean/ -123 -10) @result{} 13 and 7\n"
+ "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
+ "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_i_euclidean_divide
{
- SCM r1;
- SCM xd = scm_denominator (x);
- SCM yd = scm_denominator (y);
+ if (scm_is_false (scm_negative_p (y)))
+ return scm_i_floor_divide (x, y);
+ else
+ return scm_i_ceiling_divide (x, y);
+}
+#undef FUNC_NAME
- scm_euclidean_divide (scm_product (scm_numerator (x), yd),
- scm_product (scm_numerator (y), xd),
- qp, &r1);
- *rp = scm_divide (r1, scm_product (xd, yd));
+void
+scm_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp)
+{
+ if (scm_is_false (scm_negative_p (y)))
+ return scm_floor_divide (x, y, qp, rp);
+ else
+ return scm_ceiling_divide (x, y, qp, rp);
}
static SCM scm_i_inexact_floor_quotient (double x, double y);
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_floor_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG1,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG1,
+ s_scm_floor_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_floor_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG1,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG1,
+ s_scm_floor_remainder);
}
#undef FUNC_NAME
if (SCM_LIKELY (xx >= 0))
xx1 = xx + yy - 1;
}
- else if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_ceiling_quotient);
else if (xx < 0)
xx1 = xx + yy + 1;
qq = xx1 / yy;
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_ceiling_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG1,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG1,
+ s_scm_ceiling_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_ceiling_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG1,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG1,
+ s_scm_ceiling_remainder);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_truncate_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG1,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG1,
+ s_scm_truncate_quotient);
}
#undef FUNC_NAME
if (SCM_UNLIKELY (y == 0))
scm_num_overflow (s_scm_truncate_quotient); /* or return a NaN? */
else
- return scm_from_double (scm_c_truncate (x / y));
+ return scm_from_double (trunc (x / y));
}
static SCM
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_truncate_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG1,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG1,
+ s_scm_truncate_remainder);
}
#undef FUNC_NAME
if (SCM_UNLIKELY (y == 0))
scm_num_overflow (s_scm_truncate_remainder); /* or return a NaN? */
else
- return scm_from_double (x - y * scm_c_truncate (x / y));
+ return scm_from_double (x - y * trunc (x / y));
}
static SCM
scm_num_overflow (s_scm_truncate_divide); /* or return a NaN? */
else
{
- double q, r, q1;
- /* FIXME: Use trunc, after it has been imported from gnulib */
- q1 = x / y;
- q = (q1 >= 0) ? floor (q1) : ceil (q1);
- r = x - q * y;
+ double q = trunc (x / y);
+ double r = x - q * y;
*qp = scm_from_double (q);
*rp = scm_from_double (r);
}
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
+ s_scm_centered_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
+ s_scm_centered_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_centered_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
+ s_scm_centered_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
+ s_scm_centered_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG1,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG1,
+ s_scm_centered_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
+ s_scm_centered_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
+ s_scm_centered_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_centered_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
+ s_scm_centered_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
+ s_scm_centered_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG1,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG1,
+ s_scm_centered_remainder);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_round_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_round_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_round_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_round_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG1,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG1,
+ s_scm_round_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_round_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_round_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_round_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_round_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG1,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG1,
+ s_scm_round_remainder);
}
#undef FUNC_NAME
SCM
scm_gcd (SCM x, SCM y)
{
- if (SCM_UNBNDP (y))
+ if (SCM_UNLIKELY (SCM_UNBNDP (y)))
return SCM_UNBNDP (x) ? SCM_INUM0 : scm_abs (x);
- if (SCM_I_INUMP (x))
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
{
- if (SCM_I_INUMP (y))
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
{
scm_t_inum xx = SCM_I_INUM (x);
scm_t_inum yy = SCM_I_INUM (y);
scm_t_inum u = xx < 0 ? -xx : xx;
scm_t_inum v = yy < 0 ? -yy : yy;
scm_t_inum result;
- if (xx == 0)
+ if (SCM_UNLIKELY (xx == 0))
result = v;
- else if (yy == 0)
+ else if (SCM_UNLIKELY (yy == 0))
result = u;
else
{
- scm_t_inum k = 1;
- scm_t_inum t;
+ int k = 0;
/* Determine a common factor 2^k */
- while (!(1 & (u | v)))
+ while (((u | v) & 1) == 0)
{
- k <<= 1;
+ k++;
u >>= 1;
v >>= 1;
}
/* Now, any factor 2^n can be eliminated */
- if (u & 1)
- t = -v;
+ if ((u & 1) == 0)
+ while ((u & 1) == 0)
+ u >>= 1;
else
+ while ((v & 1) == 0)
+ v >>= 1;
+ /* Both u and v are now odd. Subtract the smaller one
+ from the larger one to produce an even number, remove
+ more factors of two, and repeat. */
+ while (u != v)
{
- t = u;
- b3:
- t = SCM_SRS (t, 1);
+ if (u > v)
+ {
+ u -= v;
+ while ((u & 1) == 0)
+ u >>= 1;
+ }
+ else
+ {
+ v -= u;
+ while ((v & 1) == 0)
+ v >>= 1;
+ }
}
- if (!(1 & t))
- goto b3;
- if (t > 0)
- u = t;
- else
- v = -t;
- t = u - v;
- if (t != 0)
- goto b3;
- result = u * k;
+ result = u << k;
}
return (SCM_POSFIXABLE (result)
? SCM_I_MAKINUM (result)
goto big_inum;
}
else
- SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
+ return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
}
else if (SCM_BIGP (x))
{
return scm_i_normbig (result);
}
else
- SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
+ return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
}
else
- SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG1, s_gcd);
+ return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG1, s_gcd);
}
SCM_PRIMITIVE_GENERIC (scm_i_lcm, "lcm", 0, 2, 1,
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_I_INUMP (n1) || SCM_BIGP (n1))))
+ return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG1, s_lcm);
+
+ if (SCM_UNLIKELY (!(SCM_I_INUMP (n2) || SCM_BIGP (n2))))
+ return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
if (SCM_I_INUMP (n1))
{
else if SCM_BIGP (n2)
{
intbig:
- if (n1 == 0)
+ if (nn1 == 0)
return SCM_INUM0;
{
SCM result_z = scm_i_mkbig ();
else /* return NaN for (0 ^ k) for negative k per R6RS */
return scm_nan ();
}
+ else if (SCM_FRACTIONP (n))
+ {
+ /* Optimize the fraction case by (a/b)^k ==> (a^k)/(b^k), to avoid
+ needless reduction of intermediate products to lowest terms.
+ If a and b have no common factors, then a^k and b^k have no
+ common factors. Use 'scm_i_make_ratio_already_reduced' to
+ construct the final result, so that no gcd computations are
+ needed to exponentiate a fraction. */
+ if (scm_is_true (scm_positive_p (k)))
+ return scm_i_make_ratio_already_reduced
+ (scm_integer_expt (SCM_FRACTION_NUMERATOR (n), k),
+ scm_integer_expt (SCM_FRACTION_DENOMINATOR (n), k));
+ else
+ {
+ k = scm_difference (k, SCM_UNDEFINED);
+ return scm_i_make_ratio_already_reduced
+ (scm_integer_expt (SCM_FRACTION_DENOMINATOR (n), k),
+ scm_integer_expt (SCM_FRACTION_NUMERATOR (n), k));
+ }
+ }
if (SCM_I_INUMP (k))
i2 = SCM_I_INUM (k);
}
#undef FUNC_NAME
+/* Efficiently compute (N * 2^COUNT),
+ where N is an exact integer, and COUNT > 0. */
+static SCM
+left_shift_exact_integer (SCM n, long count)
+{
+ if (SCM_I_INUMP (n))
+ {
+ scm_t_inum nn = SCM_I_INUM (n);
+
+ /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will 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)". */
+
+ if (nn == 0)
+ return n;
+ else if (count < SCM_I_FIXNUM_BIT-1 &&
+ ((scm_t_bits) (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - count)) + 1)
+ <= 1))
+ return SCM_I_MAKINUM (nn << count);
+ else
+ {
+ SCM result = scm_i_inum2big (nn);
+ mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
+ count);
+ return result;
+ }
+ }
+ else if (SCM_BIGP (n))
+ {
+ SCM result = scm_i_mkbig ();
+ mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), count);
+ scm_remember_upto_here_1 (n);
+ return result;
+ }
+ else
+ scm_syserror ("left_shift_exact_integer");
+}
+
+/* Efficiently compute floor (N / 2^COUNT),
+ where N is an exact integer and COUNT > 0. */
+static SCM
+floor_right_shift_exact_integer (SCM n, long count)
+{
+ if (SCM_I_INUMP (n))
+ {
+ scm_t_inum nn = SCM_I_INUM (n);
+
+ if (count >= SCM_I_FIXNUM_BIT)
+ return (nn >= 0 ? SCM_INUM0 : SCM_I_MAKINUM (-1));
+ else
+ return SCM_I_MAKINUM (SCM_SRS (nn, count));
+ }
+ else if (SCM_BIGP (n))
+ {
+ SCM result = scm_i_mkbig ();
+ mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n),
+ count);
+ scm_remember_upto_here_1 (n);
+ return scm_i_normbig (result);
+ }
+ else
+ scm_syserror ("floor_right_shift_exact_integer");
+}
+
+/* Efficiently compute round (N / 2^COUNT),
+ where N is an exact integer and COUNT > 0. */
+static SCM
+round_right_shift_exact_integer (SCM n, long count)
+{
+ if (SCM_I_INUMP (n))
+ {
+ if (count >= SCM_I_FIXNUM_BIT)
+ return SCM_INUM0;
+ else
+ {
+ scm_t_inum nn = SCM_I_INUM (n);
+ scm_t_inum qq = SCM_SRS (nn, count);
+
+ if (0 == (nn & (1L << (count-1))))
+ return SCM_I_MAKINUM (qq); /* round down */
+ else if (nn & ((1L << (count-1)) - 1))
+ return SCM_I_MAKINUM (qq + 1); /* round up */
+ else
+ return SCM_I_MAKINUM ((~1L) & (qq + 1)); /* round to even */
+ }
+ }
+ else if (SCM_BIGP (n))
+ {
+ SCM q = scm_i_mkbig ();
+
+ mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (n), count);
+ if (mpz_tstbit (SCM_I_BIG_MPZ (n), count-1)
+ && (mpz_odd_p (SCM_I_BIG_MPZ (q))
+ || (mpz_scan1 (SCM_I_BIG_MPZ (n), 0) < count-1)))
+ mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
+ scm_remember_upto_here_1 (n);
+ return scm_i_normbig (q);
+ }
+ else
+ scm_syserror ("round_right_shift_exact_integer");
+}
+
SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
- (SCM n, SCM cnt),
- "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
- "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
- "\n"
- "This is effectively a multiplication by 2^@var{cnt}, and when\n"
- "@var{cnt} is negative it's a division, rounded towards negative\n"
- "infinity. (Note that this is not the same rounding as\n"
- "@code{quotient} does.)\n"
+ (SCM n, SCM count),
+ "Return @math{floor(@var{n} * 2^@var{count})}.\n"
+ "@var{n} and @var{count} must be exact integers.\n"
"\n"
- "With @var{n} viewed as an infinite precision twos complement,\n"
- "@code{ash} means a left shift introducing zero bits, or a right\n"
- "shift dropping bits.\n"
+ "With @var{n} viewed as an infinite-precision twos-complement\n"
+ "integer, @code{ash} means a left shift introducing zero bits\n"
+ "when @var{count} is positive, or a right shift dropping bits\n"
+ "when @var{count} is negative. This is an ``arithmetic'' shift.\n"
"\n"
"@lisp\n"
"(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
"@end lisp")
#define FUNC_NAME s_scm_ash
{
- long bits_to_shift;
- bits_to_shift = scm_to_long (cnt);
-
- if (SCM_I_INUMP (n))
+ if (SCM_I_INUMP (n) || SCM_BIGP (n))
{
- scm_t_inum nn = SCM_I_INUM (n);
+ long bits_to_shift = scm_to_long (count);
if (bits_to_shift > 0)
- {
- /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will 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 -
- bits_to_shift)". */
-
- if (nn == 0)
- return n;
-
- if (bits_to_shift < SCM_I_FIXNUM_BIT-1
- && ((scm_t_bits)
- (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
- <= 1))
- {
- return SCM_I_MAKINUM (nn << bits_to_shift);
- }
- else
- {
- SCM result = scm_i_inum2big (nn);
- mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
- bits_to_shift);
- return result;
- }
- }
+ return left_shift_exact_integer (n, bits_to_shift);
+ else if (SCM_LIKELY (bits_to_shift < 0))
+ return floor_right_shift_exact_integer (n, -bits_to_shift);
else
- {
- bits_to_shift = -bits_to_shift;
- if (bits_to_shift >= SCM_LONG_BIT)
- return (nn >= 0 ? SCM_INUM0 : SCM_I_MAKINUM(-1));
- else
- return SCM_I_MAKINUM (SCM_SRS (nn, bits_to_shift));
- }
-
+ return n;
}
- else if (SCM_BIGP (n))
- {
- SCM result;
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
+}
+#undef FUNC_NAME
- if (bits_to_shift == 0)
- return n;
+SCM_DEFINE (scm_round_ash, "round-ash", 2, 0, 0,
+ (SCM n, SCM count),
+ "Return @math{round(@var{n} * 2^@var{count})}.\n"
+ "@var{n} and @var{count} must be exact integers.\n"
+ "\n"
+ "With @var{n} viewed as an infinite-precision twos-complement\n"
+ "integer, @code{round-ash} means a left shift introducing zero\n"
+ "bits when @var{count} is positive, or a right shift rounding\n"
+ "to the nearest integer (with ties going to the nearest even\n"
+ "integer) when @var{count} is negative. This is a rounded\n"
+ "``arithmetic'' shift.\n"
+ "\n"
+ "@lisp\n"
+ "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n"
+ "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n"
+ "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n"
+ "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n"
+ "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n"
+ "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_round_ash
+{
+ if (SCM_I_INUMP (n) || SCM_BIGP (n))
+ {
+ long bits_to_shift = scm_to_long (count);
- result = scm_i_mkbig ();
- if (bits_to_shift >= 0)
- {
- mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n),
- bits_to_shift);
- return result;
- }
+ if (bits_to_shift > 0)
+ return left_shift_exact_integer (n, bits_to_shift);
+ else if (SCM_LIKELY (bits_to_shift < 0))
+ return round_right_shift_exact_integer (n, -bits_to_shift);
else
- {
- /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
- we have to allocate a bignum even if the result is going to be a
- fixnum. */
- mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n),
- -bits_to_shift);
- return scm_i_normbig (result);
- }
-
+ return n;
}
else
- {
- SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
- }
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
}
#undef FUNC_NAME
#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;
+ int ch = 0;
- if(radix < 2 ||
- radix > SCM_MAX_DBL_RADIX)
- {
- /* revert to existing behavior */
- radix = 10;
- }
+ if (radix < 2 || radix > SCM_MAX_DBL_RADIX)
+ /* revert to existing behavior */
+ radix = 10;
- wp = scm_dblprec[radix-2];
- fx = fx_per_radix[radix-2];
-
- 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 (!double_is_non_negative_zero (dbl))
+ 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;
+
+ /* 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);
+ }
- 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;
- }
- }
+ mpz_clears (f, r, s, mplus, mminus, hi, digit, NULL);
+ }
return ch;
}
else if (SCM_BIGP (n))
{
char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n));
+ size_t len = strlen (str);
+ void (*freefunc) (void *, size_t);
+ SCM ret;
+ mp_get_memory_functions (NULL, NULL, &freefunc);
scm_remember_upto_here_1 (n);
- return scm_take_locale_string (str);
+ ret = scm_from_latin1_stringn (str, len);
+ freefunc (str, len + 1);
+ return ret;
}
else if (SCM_FRACTIONP (n))
{
scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, iflo2str (sexp, num_buf, 10), port);
return !0;
}
scm_i_print_double (double val, SCM port)
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, idbl2str (val, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, idbl2str (val, num_buf, 10), port);
}
int
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, iflo2str (sexp, num_buf, 10), port);
return !0;
}
scm_i_print_complex (double real, double imag, SCM port)
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, icmplx2str (real, imag, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, icmplx2str (real, imag, num_buf, 10), port);
}
int
scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
char *str = mpz_get_str (NULL, 10, SCM_I_BIG_MPZ (exp));
+ size_t len = strlen (str);
+ void (*freefunc) (void *, size_t);
+ mp_get_memory_functions (NULL, NULL, &freefunc);
scm_remember_upto_here_1 (exp);
- scm_lfwrite (str, (size_t) strlen (str), port);
- free (str);
+ scm_lfwrite_unlocked (str, len, port);
+ freefunc (str, len + 1);
return !0;
}
/*** END nums->strs ***/
return d;
}
+/* Parse the substring of MEM starting at *P_IDX for an unsigned integer
+ in base RADIX. Upon success, return the unsigned integer and update
+ *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
static SCM
mem2uinteger (SCM mem, unsigned int *p_idx,
unsigned int radix, enum t_exactness *p_exactness)
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);
if (sign == 1)
result = scm_product (result, e);
else
- result = scm_divide2real (result, e);
+ result = scm_divide (result, e);
/* We've seen an exponent, thus the value is implicitly inexact. */
x = INEXACT;
static SCM
mem2ureal (SCM mem, unsigned int *p_idx,
- unsigned int radix, enum t_exactness forced_x)
+ unsigned int radix, enum t_exactness forced_x,
+ int allow_inf_or_nan)
{
unsigned int idx = *p_idx;
SCM result;
if (idx == len)
return SCM_BOOL_F;
- if (idx+5 <= len && !scm_i_string_strcmp (mem, idx, "inf.0"))
- {
- *p_idx = idx+5;
- return scm_inf ();
- }
-
- if (idx+4 < len && !scm_i_string_strcmp (mem, idx, "nan."))
- {
- /* Cobble up the fractional part. We might want to set the
- NaN's mantissa from it. */
- idx += 4;
- mem2uinteger (mem, &idx, 10, &implicit_x);
- *p_idx = idx;
- return scm_nan ();
- }
+ if (allow_inf_or_nan && forced_x != EXACT && idx+5 <= len)
+ switch (scm_i_string_ref (mem, idx))
+ {
+ case 'i': case 'I':
+ switch (scm_i_string_ref (mem, idx + 1))
+ {
+ case 'n': case 'N':
+ switch (scm_i_string_ref (mem, idx + 2))
+ {
+ case 'f': case 'F':
+ if (scm_i_string_ref (mem, idx + 3) == '.'
+ && scm_i_string_ref (mem, idx + 4) == '0')
+ {
+ *p_idx = idx+5;
+ return scm_inf ();
+ }
+ }
+ }
+ case 'n': case 'N':
+ switch (scm_i_string_ref (mem, idx + 1))
+ {
+ case 'a': case 'A':
+ switch (scm_i_string_ref (mem, idx + 2))
+ {
+ case 'n': case 'N':
+ if (scm_i_string_ref (mem, idx + 3) == '.')
+ {
+ /* Cobble up the fractional part. We might want to
+ set the NaN's mantissa from it. */
+ idx += 4;
+ if (!scm_is_eq (mem2uinteger (mem, &idx, 10, &implicit_x),
+ SCM_INUM0))
+ {
+#if SCM_ENABLE_DEPRECATED == 1
+ scm_c_issue_deprecation_warning
+ ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
+#else
+ return SCM_BOOL_F;
+#endif
+ }
+
+ *p_idx = idx;
+ return scm_nan ();
+ }
+ }
+ }
+ }
if (scm_i_string_ref (mem, idx) == '.')
{
return SCM_BOOL_F;
divisor = mem2uinteger (mem, &idx, radix, &implicit_x);
- if (scm_is_false (divisor))
+ if (scm_is_false (divisor) || scm_is_eq (divisor, SCM_INUM0))
return SCM_BOOL_F;
/* both are int/big here, I assume */
if (idx == len)
return SCM_BOOL_F;
- ureal = mem2ureal (mem, &idx, radix, forced_x);
+ ureal = mem2ureal (mem, &idx, radix, forced_x, sign != 0);
if (scm_is_false (ureal))
{
/* input must be either +i or -i */
sign = -1;
}
else
- sign = 1;
+ sign = 0;
- angle = mem2ureal (mem, &idx, radix, forced_x);
+ angle = mem2ureal (mem, &idx, radix, forced_x, sign != 0);
if (scm_is_false (angle))
return SCM_BOOL_F;
if (idx != len)
else
{
int sign = (c == '+') ? 1 : -1;
- SCM imag = mem2ureal (mem, &idx, radix, forced_x);
+ SCM imag = mem2ureal (mem, &idx, radix, forced_x, sign != 0);
if (scm_is_false (imag))
imag = SCM_I_MAKINUM (sign);
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
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
+ s_scm_i_num_eq_p);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
+ s_scm_i_num_eq_p);
}
else if (SCM_REALP (x))
{
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
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
+ s_scm_i_num_eq_p);
}
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
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
+ s_scm_i_num_eq_p);
}
else if (SCM_FRACTIONP (x))
{
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;
}
else if (SCM_FRACTIONP (y))
return scm_i_fraction_equalp (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
+ s_scm_i_num_eq_p);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARG1, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARG1,
+ s_scm_i_num_eq_p);
}
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" */
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
+ s_scm_i_num_less_p);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
goto int_frac;
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
+ s_scm_i_num_less_p);
}
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;
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
+ s_scm_i_num_less_p);
}
else if (SCM_FRACTIONP (x))
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
+ s_scm_i_num_less_p);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARG1, s_scm_i_num_less_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARG1,
+ s_scm_i_num_less_p);
}
scm_gr_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p, x, y, SCM_ARG1, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_gr_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p, x, y, SCM_ARG2, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_gr_p, x, y, SCM_ARG2, FUNC_NAME);
else
return scm_less_p (y, x);
}
scm_leq_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p, x, y, SCM_ARG1, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_leq_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p, x, y, SCM_ARG2, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_leq_p, x, y, SCM_ARG2, FUNC_NAME);
else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
return SCM_BOOL_F;
else
scm_geq_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p, x, y, SCM_ARG1, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_geq_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p, x, y, SCM_ARG2, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_geq_p, x, y, SCM_ARG2, FUNC_NAME);
else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
return SCM_BOOL_F;
else
else if (SCM_FRACTIONP (z))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_1 (g_scm_zero_p, z, SCM_ARG1, s_scm_zero_p);
+ return scm_wta_dispatch_1 (g_scm_zero_p, z, SCM_ARG1, s_scm_zero_p);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (x))
return scm_positive_p (SCM_FRACTION_NUMERATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_positive_p, x, SCM_ARG1, s_scm_positive_p);
+ return scm_wta_dispatch_1 (g_scm_positive_p, x, SCM_ARG1, s_scm_positive_p);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (x))
return scm_negative_p (SCM_FRACTION_NUMERATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_negative_p, x, SCM_ARG1, s_scm_negative_p);
+ return scm_wta_dispatch_1 (g_scm_negative_p, x, SCM_ARG1, s_scm_negative_p);
}
#undef FUNC_NAME
if (SCM_UNBNDP (y))
{
if (SCM_UNBNDP (x))
- SCM_WTA_DISPATCH_0 (g_max, s_max);
+ return scm_wta_dispatch_0 (g_max, s_max);
else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
return x;
else
- SCM_WTA_DISPATCH_1 (g_max, x, SCM_ARG1, s_max);
+ return scm_wta_dispatch_1 (g_max, x, SCM_ARG1, s_max);
}
if (SCM_I_INUMP (x))
return (scm_is_false (scm_less_p (x, y)) ? x : y);
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else if (SCM_BIGP (x))
{
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else if (SCM_REALP (x))
{
return (xx < yy) ? scm_from_double (yy) : x;
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else if (SCM_FRACTIONP (x))
{
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARG1, s_max);
}
if (SCM_UNBNDP (y))
{
if (SCM_UNBNDP (x))
- SCM_WTA_DISPATCH_0 (g_min, s_min);
+ return scm_wta_dispatch_0 (g_min, s_min);
else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
return x;
else
- SCM_WTA_DISPATCH_1 (g_min, x, SCM_ARG1, s_min);
+ return scm_wta_dispatch_1 (g_min, x, SCM_ARG1, s_min);
}
if (SCM_I_INUMP (x))
return (scm_is_false (scm_less_p (x, y)) ? y : x);
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else if (SCM_BIGP (x))
{
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else if (SCM_REALP (x))
{
return (yy < xx) ? scm_from_double (yy) : x;
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else if (SCM_FRACTIONP (x))
{
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARG1, s_min);
}
{
if (SCM_NUMBERP (x)) return x;
if (SCM_UNBNDP (x)) return SCM_INUM0;
- SCM_WTA_DISPATCH_1 (g_sum, x, SCM_ARG1, s_sum);
+ return scm_wta_dispatch_1 (g_sum, x, SCM_ARG1, s_sum);
}
if (SCM_LIKELY (SCM_I_INUMP (x)))
scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
} else if (SCM_BIGP (x))
{
if (SCM_I_INUMP (y))
scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
else if (SCM_REALP (x))
{
else if (SCM_FRACTIONP (y))
return scm_from_double (SCM_REAL_VALUE (x) + scm_i_fraction2double (y));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
else if (SCM_COMPLEXP (x))
{
return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + scm_i_fraction2double (y),
SCM_COMPLEX_IMAG (x));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
else if (SCM_FRACTIONP (x))
{
scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARG1, s_sum);
}
if (SCM_UNLIKELY (SCM_UNBNDP (y)))
{
if (SCM_UNBNDP (x))
- SCM_WTA_DISPATCH_0 (g_difference, s_difference);
+ return scm_wta_dispatch_0 (g_difference, s_difference);
else
if (SCM_I_INUMP (x))
{
return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x),
-SCM_COMPLEX_IMAG (x));
else if (SCM_FRACTIONP (x))
- return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
- SCM_FRACTION_DENOMINATOR (x));
+ return scm_i_make_ratio_already_reduced
+ (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
+ SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference);
+ return scm_wta_dispatch_1 (g_difference, x, SCM_ARG1, s_difference);
}
if (SCM_LIKELY (SCM_I_INUMP (x)))
SCM_FRACTION_NUMERATOR (y)),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else if (SCM_BIGP (x))
{
return scm_i_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
SCM_FRACTION_NUMERATOR (y)),
SCM_FRACTION_DENOMINATOR (y));
- else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ else
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else if (SCM_REALP (x))
{
else if (SCM_FRACTIONP (y))
return scm_from_double (SCM_REAL_VALUE (x) - scm_i_fraction2double (y));
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else if (SCM_COMPLEXP (x))
{
return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - scm_i_fraction2double (y),
SCM_COMPLEX_IMAG (x));
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else if (SCM_FRACTIONP (x))
{
scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARG1, s_difference);
}
#undef FUNC_NAME
else if (SCM_NUMBERP (x))
return x;
else
- SCM_WTA_DISPATCH_1 (g_product, x, SCM_ARG1, s_product);
+ return scm_wta_dispatch_1 (g_product, x, SCM_ARG1, s_product);
}
if (SCM_LIKELY (SCM_I_INUMP (x)))
else if (SCM_NUMP (y))
return SCM_INUM0;
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
break;
case -1:
/*
if (SCM_LIKELY (SCM_I_INUMP (y)))
{
scm_t_inum yy = SCM_I_INUM (y);
- scm_t_inum kk = xx * yy;
- SCM k = SCM_I_MAKINUM (kk);
- if ((kk == SCM_I_INUM (k)) && (kk / xx == yy))
- return k;
+#if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
+ scm_t_int64 kk = xx * (scm_t_int64) yy;
+ if (SCM_FIXABLE (kk))
+ return SCM_I_MAKINUM (kk);
+#else
+ scm_t_inum axx = (xx > 0) ? xx : -xx;
+ scm_t_inum ayy = (yy > 0) ? yy : -yy;
+ if (SCM_MOST_POSITIVE_FIXNUM / axx >= ayy)
+ return SCM_I_MAKINUM (xx * yy);
+#endif
else
{
SCM result = scm_i_inum2big (xx);
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else if (SCM_BIGP (x))
{
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else if (SCM_REALP (x))
{
else if (SCM_FRACTIONP (y))
return scm_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_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else if (SCM_COMPLEXP (x))
{
yy * SCM_COMPLEX_IMAG (x));
}
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else if (SCM_FRACTIONP (x))
{
scm_product (SCM_FRACTION_DENOMINATOR (x),
SCM_FRACTION_DENOMINATOR (y)));
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARG1, s_product);
}
#if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
#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;
if (SCM_UNLIKELY (SCM_UNBNDP (y)))
{
if (SCM_UNBNDP (x))
- SCM_WTA_DISPATCH_0 (g_divide, s_divide);
+ return scm_wta_dispatch_0 (g_divide, s_divide);
else if (SCM_I_INUMP (x))
{
scm_t_inum xx = SCM_I_INUM (x);
scm_num_overflow (s_divide);
#endif
else
- {
- if (inexact)
- return scm_from_double (1.0 / (double) xx);
- else return scm_i_make_ratio (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 (SCM_INUM1, x);
- }
+ return scm_i_make_ratio_already_reduced (SCM_INUM1, x);
else if (SCM_REALP (x))
{
double xx = SCM_REAL_VALUE (x);
}
}
else if (SCM_FRACTIONP (x))
- return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x),
- SCM_FRACTION_NUMERATOR (x));
+ return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x),
+ SCM_FRACTION_NUMERATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide);
+ return scm_wta_dispatch_1 (g_divide, x, SCM_ARG1, s_divide);
}
if (SCM_LIKELY (SCM_I_INUMP (x)))
#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
+ /* FIXME: Precision may be lost here due to:
+ (1) The cast from 'scm_t_inum' to 'double'
+ (2) Double rounding */
return scm_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_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else if (SCM_BIGP (x))
{
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
+ /* FIXME: Precision may be lost here due to:
+ (1) scm_i_big2dbl (2) Double rounding */
return scm_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);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else if (SCM_REALP (x))
{
scm_num_overflow (s_divide);
else
#endif
+ /* FIXME: Precision may be lost here due to:
+ (1) The cast from 'scm_t_inum' to 'double'
+ (2) Double rounding */
return scm_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);
else if (SCM_FRACTIONP (y))
return scm_from_double (rx / scm_i_fraction2double (y));
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else if (SCM_COMPLEXP (x))
{
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
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else if (SCM_FRACTIONP (x))
{
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
+ /* FIXME: Precision may be lost here due to:
+ (1) The conversion from fraction to double
+ (2) Double rounding */
return scm_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);
+ return 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);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARG1, s_divide);
}
#undef FUNC_NAME
double
scm_c_truncate (double x)
{
-#if HAVE_TRUNC
return trunc (x);
-#else
- if (x < 0.0)
- return ceil (x);
- else
- return floor (x);
-#endif
}
/* scm_c_round is done using floor(x+0.5) to round to nearest and with
if (SCM_I_INUMP (x) || SCM_BIGP (x))
return x;
else if (SCM_REALP (x))
- return scm_from_double (scm_c_truncate (SCM_REAL_VALUE (x)));
+ return scm_from_double (trunc (SCM_REAL_VALUE (x)));
else if (SCM_FRACTIONP (x))
return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_truncate_number, x, SCM_ARG1,
+ return scm_wta_dispatch_1 (g_scm_truncate_number, x, SCM_ARG1,
s_scm_truncate_number);
}
#undef FUNC_NAME
return scm_round_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_round_number, x, SCM_ARG1,
- s_scm_round_number);
+ return scm_wta_dispatch_1 (g_scm_round_number, x, SCM_ARG1,
+ s_scm_round_number);
}
#undef FUNC_NAME
return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_floor, x, 1, s_scm_floor);
+ return scm_wta_dispatch_1 (g_scm_floor, x, 1, s_scm_floor);
}
#undef FUNC_NAME
return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_ceiling, x, 1, s_scm_ceiling);
+ return scm_wta_dispatch_1 (g_scm_ceiling, x, 1, s_scm_ceiling);
}
#undef FUNC_NAME
else if (scm_is_complex (x) && scm_is_complex (y))
return scm_exp (scm_product (scm_log (x), y));
else if (scm_is_complex (x))
- SCM_WTA_DISPATCH_2 (g_scm_expt, x, y, SCM_ARG2, s_scm_expt);
+ return scm_wta_dispatch_2 (g_scm_expt, x, y, SCM_ARG2, s_scm_expt);
else
- SCM_WTA_DISPATCH_2 (g_scm_expt, x, y, SCM_ARG1, s_scm_expt);
+ return scm_wta_dispatch_2 (g_scm_expt, x, y, SCM_ARG1, s_scm_expt);
}
#undef FUNC_NAME
cos (x) * sinh (y));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_sin, z, 1, s_scm_sin);
+ return scm_wta_dispatch_1 (g_scm_sin, z, 1, s_scm_sin);
}
#undef FUNC_NAME
-sin (x) * sinh (y));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_cos, z, 1, s_scm_cos);
+ return scm_wta_dispatch_1 (g_scm_cos, z, 1, s_scm_cos);
}
#undef FUNC_NAME
return scm_c_make_rectangular (sin (x) / w, sinh (y) / w);
}
else
- SCM_WTA_DISPATCH_1 (g_scm_tan, z, 1, s_scm_tan);
+ return scm_wta_dispatch_1 (g_scm_tan, z, 1, s_scm_tan);
}
#undef FUNC_NAME
cosh (x) * sin (y));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_sinh, z, 1, s_scm_sinh);
+ return scm_wta_dispatch_1 (g_scm_sinh, z, 1, s_scm_sinh);
}
#undef FUNC_NAME
sinh (x) * sin (y));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_cosh, z, 1, s_scm_cosh);
+ return scm_wta_dispatch_1 (g_scm_cosh, z, 1, s_scm_cosh);
}
#undef FUNC_NAME
return scm_c_make_rectangular (sinh (x) / w, sin (y) / w);
}
else
- SCM_WTA_DISPATCH_1 (g_scm_tanh, z, 1, s_scm_tanh);
+ return scm_wta_dispatch_1 (g_scm_tanh, z, 1, s_scm_tanh);
}
#undef FUNC_NAME
scm_sys_asinh (scm_c_make_rectangular (-y, x)));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_asin, z, 1, s_scm_asin);
+ return scm_wta_dispatch_1 (g_scm_asin, z, 1, s_scm_asin);
}
#undef FUNC_NAME
scm_sys_asinh (scm_c_make_rectangular (-y, x))));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_acos, z, 1, s_scm_acos);
+ return scm_wta_dispatch_1 (g_scm_acos, z, 1, s_scm_acos);
}
#undef FUNC_NAME
scm_c_make_rectangular (0, 2));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_atan, z, SCM_ARG1, s_scm_atan);
+ return scm_wta_dispatch_1 (g_scm_atan, z, SCM_ARG1, s_scm_atan);
}
else if (scm_is_real (z))
{
if (scm_is_real (y))
return scm_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);
+ return scm_wta_dispatch_2 (g_scm_atan, z, y, SCM_ARG2, s_scm_atan);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_atan, z, y, SCM_ARG1, s_scm_atan);
+ return scm_wta_dispatch_2 (g_scm_atan, z, y, SCM_ARG1, s_scm_atan);
}
#undef FUNC_NAME
scm_sqrt (scm_sum (scm_product (z, z),
SCM_INUM1))));
else
- SCM_WTA_DISPATCH_1 (g_scm_sys_asinh, z, 1, s_scm_sys_asinh);
+ return scm_wta_dispatch_1 (g_scm_sys_asinh, z, 1, s_scm_sys_asinh);
}
#undef FUNC_NAME
scm_sqrt (scm_difference (scm_product (z, z),
SCM_INUM1))));
else
- SCM_WTA_DISPATCH_1 (g_scm_sys_acosh, z, 1, s_scm_sys_acosh);
+ return scm_wta_dispatch_1 (g_scm_sys_acosh, z, 1, s_scm_sys_acosh);
}
#undef FUNC_NAME
scm_difference (SCM_INUM1, z))),
SCM_I_MAKINUM (2));
else
- SCM_WTA_DISPATCH_1 (g_scm_sys_atanh, z, 1, s_scm_sys_atanh);
+ return scm_wta_dispatch_1 (g_scm_sys_atanh, z, 1, s_scm_sys_atanh);
}
#undef FUNC_NAME
{
SCM z;
- z = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex),
+ z = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_complex),
"complex"));
SCM_SET_CELL_TYPE (z, scm_tc16_complex);
SCM_COMPLEX_REAL (z) = re;
SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0,
(SCM real_part, SCM imaginary_part),
- "Return a complex number constructed of the given @var{real-part} "
- "and @var{imaginary-part} parts.")
+ "Return a complex number constructed of the given @var{real_part} "
+ "and @var{imaginary_part} parts.")
#define FUNC_NAME s_scm_make_rectangular
{
SCM_ASSERT_TYPE (scm_is_real (real_part), real_part,
else if (SCM_I_INUMP (z) || SCM_BIGP (z) || SCM_REALP (z) || SCM_FRACTIONP (z))
return z;
else
- SCM_WTA_DISPATCH_1 (g_scm_real_part, z, SCM_ARG1, s_scm_real_part);
+ return scm_wta_dispatch_1 (g_scm_real_part, z, SCM_ARG1, s_scm_real_part);
}
#undef FUNC_NAME
else if (SCM_I_INUMP (z) || SCM_REALP (z) || SCM_BIGP (z) || SCM_FRACTIONP (z))
return SCM_INUM0;
else
- SCM_WTA_DISPATCH_1 (g_scm_imag_part, z, SCM_ARG1, s_scm_imag_part);
+ return scm_wta_dispatch_1 (g_scm_imag_part, z, SCM_ARG1, s_scm_imag_part);
}
#undef FUNC_NAME
else if (SCM_REALP (z))
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);
+ return scm_wta_dispatch_1 (g_scm_numerator, z, SCM_ARG1, s_scm_numerator);
}
#undef FUNC_NAME
else if (SCM_REALP (z))
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 scm_wta_dispatch_1 (g_scm_denominator, z, SCM_ARG1,
+ s_scm_denominator);
}
#undef FUNC_NAME
{
if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
return z;
- return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z), SCM_UNDEFINED),
- SCM_FRACTION_DENOMINATOR (z));
+ return scm_i_make_ratio_already_reduced
+ (scm_difference (SCM_FRACTION_NUMERATOR (z), SCM_UNDEFINED),
+ SCM_FRACTION_DENOMINATOR (z));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_magnitude, z, SCM_ARG1, s_scm_magnitude);
+ return scm_wta_dispatch_1 (g_scm_magnitude, z, SCM_ARG1,
+ s_scm_magnitude);
}
#undef FUNC_NAME
}
else if (SCM_REALP (z))
{
- if (SCM_REAL_VALUE (z) >= 0)
+ double x = SCM_REAL_VALUE (z);
+ if (x > 0.0 || double_is_non_negative_zero (x))
return flo0;
else
return scm_from_double (atan2 (0.0, -1.0));
else return scm_from_double (atan2 (0.0, -1.0));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_angle, z, SCM_ARG1, s_scm_angle);
+ return scm_wta_dispatch_1 (g_scm_angle, z, SCM_ARG1, s_scm_angle);
}
#undef FUNC_NAME
else if (SCM_INEXACTP (z))
return z;
else
- SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact, z, 1, s_scm_exact_to_inexact);
+ return scm_wta_dispatch_1 (g_scm_exact_to_inexact, z, 1,
+ s_scm_exact_to_inexact);
}
#undef FUNC_NAME
else if (SCM_COMPLEXP (z) && SCM_COMPLEX_IMAG (z) == 0.0)
val = SCM_COMPLEX_REAL (z);
else
- SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact, z, 1, s_scm_inexact_to_exact);
+ return scm_wta_dispatch_1 (g_scm_inexact_to_exact, z, 1,
+ s_scm_inexact_to_exact);
if (!SCM_LIKELY (DOUBLE_IS_FINITE (val)))
SCM_OUT_OF_RANGE (1, z);
+ else if (val == 0.0)
+ return SCM_INUM0;
else
{
- mpq_t frac;
- SCM q;
-
- mpq_init (frac);
- mpq_set_d (frac, val);
- q = scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac)),
- scm_i_mpz2num (mpq_denref (frac)));
+ int expon;
+ SCM numerator;
- /* When scm_i_make_ratio throws, we leak the memory allocated
- for frac...
- */
- mpq_clear (frac);
- return q;
+ numerator = scm_i_dbl2big (ldexp (frexp (val, &expon),
+ DBL_MANT_DIG));
+ expon -= DBL_MANT_DIG;
+ if (expon < 0)
+ {
+ int shift = mpz_scan1 (SCM_I_BIG_MPZ (numerator), 0);
+
+ if (shift > -expon)
+ shift = -expon;
+ mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator),
+ SCM_I_BIG_MPZ (numerator),
+ shift);
+ expon += shift;
+ }
+ numerator = scm_i_normbig (numerator);
+ if (expon < 0)
+ return scm_i_make_ratio_already_reduced
+ (numerator, left_shift_exact_integer (SCM_INUM1, -expon));
+ else if (expon > 0)
+ return left_shift_exact_integer (numerator, expon);
+ else
+ return numerator;
}
}
}
{
SCM z;
- z = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double), "real"));
+ z = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double), "real"));
SCM_SET_CELL_TYPE (z, scm_tc16_real);
SCM_REAL_VALUE (z) = val;
return z;
}
-#if SCM_ENABLE_DEPRECATED == 1
-
-float
-scm_num2float (SCM num, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2float' is deprecated. Use scm_to_double instead.");
-
- if (SCM_BIGP (num))
- {
- float res = mpz_get_d (SCM_I_BIG_MPZ (num));
- if (!isinf (res))
- return res;
- else
- scm_out_of_range (NULL, num);
- }
- else
- return scm_to_double (num);
-}
-
-double
-scm_num2double (SCM num, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2double' is deprecated. Use scm_to_double instead.");
-
- if (SCM_BIGP (num))
- {
- double res = mpz_get_d (SCM_I_BIG_MPZ (num));
- if (!isinf (res))
- return res;
- else
- scm_out_of_range (NULL, num);
- }
- else
- return scm_to_double (num);
-}
-
-#endif
-
int
scm_is_complex (SCM val)
{
}
+/* Returns log(x * 2^shift) */
+static SCM
+log_of_shifted_double (double x, long shift)
+{
+ double ans = log (fabs (x)) + shift * M_LN2;
+
+ if (x > 0.0 || double_is_non_negative_zero (x))
+ return scm_from_double (ans);
+ else
+ return scm_c_make_rectangular (ans, M_PI);
+}
+
+/* Returns log(n), for exact integer n */
+static SCM
+log_of_exact_integer (SCM n)
+{
+ if (SCM_I_INUMP (n))
+ return log_of_shifted_double (SCM_I_INUM (n), 0);
+ else if (SCM_BIGP (n))
+ {
+ long expon;
+ double signif = scm_i_big2dbl_2exp (n, &expon);
+ return log_of_shifted_double (signif, expon);
+ }
+ else
+ scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1, n);
+}
+
+/* Returns log(n/d), for exact non-zero integers n and d */
+static SCM
+log_of_fraction (SCM n, SCM d)
+{
+ long n_size = scm_to_long (scm_integer_length (n));
+ long d_size = scm_to_long (scm_integer_length (d));
+
+ if (abs (n_size - d_size) > 1)
+ 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_i_divide2double (scm_difference (n, d), d)));
+ else
+ return scm_c_make_rectangular
+ (log1p (scm_i_divide2double (scm_difference (scm_abs (n), d),
+ d)),
+ M_PI);
+}
+
+
/* In the following functions we dispatch to the real-arg funcs like log()
when we know the arg is real, instead of just handing everything to
clog() for instance. This is in case clog() doesn't optimize for a
{
if (SCM_COMPLEXP (z))
{
-#if HAVE_COMPLEX_DOUBLE && HAVE_CLOG && defined (SCM_COMPLEX_VALUE)
+#if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
+ && defined (SCM_COMPLEX_VALUE)
return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z)));
#else
double re = SCM_COMPLEX_REAL (z);
atan2 (im, re));
#endif
}
- else if (SCM_NUMBERP (z))
+ else if (SCM_REALP (z))
+ return log_of_shifted_double (SCM_REAL_VALUE (z), 0);
+ else if (SCM_I_INUMP (z))
{
- /* ENHANCE-ME: When z is a bignum the logarithm will fit a double
- although the value itself overflows. */
- double re = scm_to_double (z);
- double l = log (fabs (re));
- if (re >= 0.0)
- return scm_from_double (l);
- else
- return scm_c_make_rectangular (l, M_PI);
+#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
+ if (scm_is_eq (z, SCM_INUM0))
+ scm_num_overflow (s_scm_log);
+#endif
+ return log_of_shifted_double (SCM_I_INUM (z), 0);
}
+ else if (SCM_BIGP (z))
+ return log_of_exact_integer (z);
+ else if (SCM_FRACTIONP (z))
+ return log_of_fraction (SCM_FRACTION_NUMERATOR (z),
+ SCM_FRACTION_DENOMINATOR (z));
else
- SCM_WTA_DISPATCH_1 (g_scm_log, z, 1, s_scm_log);
+ return scm_wta_dispatch_1 (g_scm_log, z, 1, s_scm_log);
}
#undef FUNC_NAME
M_LOG10E * atan2 (im, re));
#endif
}
- else if (SCM_NUMBERP (z))
+ else if (SCM_REALP (z) || SCM_I_INUMP (z))
{
- /* ENHANCE-ME: When z is a bignum the logarithm will fit a double
- although the value itself overflows. */
- double re = scm_to_double (z);
- double l = log10 (fabs (re));
- if (re >= 0.0)
- return scm_from_double (l);
- else
- return scm_c_make_rectangular (l, M_LOG10E * M_PI);
+#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
+ if (scm_is_eq (z, SCM_INUM0))
+ scm_num_overflow (s_scm_log10);
+#endif
+ {
+ 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);
+ else
+ return scm_c_make_rectangular (l, M_LOG10E * M_PI);
+ }
}
+ else if (SCM_BIGP (z))
+ return scm_product (flo_log10e, log_of_exact_integer (z));
+ else if (SCM_FRACTIONP (z))
+ return scm_product (flo_log10e,
+ log_of_fraction (SCM_FRACTION_NUMERATOR (z),
+ SCM_FRACTION_DENOMINATOR (z)));
else
- SCM_WTA_DISPATCH_1 (g_scm_log10, z, 1, s_scm_log10);
+ return scm_wta_dispatch_1 (g_scm_log10, z, 1, s_scm_log10);
}
#undef FUNC_NAME
{
if (SCM_COMPLEXP (z))
{
-#if HAVE_COMPLEX_DOUBLE && HAVE_CEXP && defined (SCM_COMPLEX_VALUE)
+#if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
+ && defined (SCM_COMPLEX_VALUE)
return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z)));
#else
return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z)),
return scm_from_double (exp (scm_to_double (z)));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_exp, z, 1, s_scm_exp);
+ return scm_wta_dispatch_1 (g_scm_exp, z, 1, s_scm_exp);
}
#undef FUNC_NAME
+SCM_DEFINE (scm_i_exact_integer_sqrt, "exact-integer-sqrt", 1, 0, 0,
+ (SCM k),
+ "Return two exact non-negative integers @var{s} and @var{r}\n"
+ "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
+ "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
+ "An error is raised if @var{k} is not an exact non-negative integer.\n"
+ "\n"
+ "@lisp\n"
+ "(exact-integer-sqrt 10) @result{} 3 and 1\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_i_exact_integer_sqrt
+{
+ SCM s, r;
+
+ scm_exact_integer_sqrt (k, &s, &r);
+ return scm_values (scm_list_2 (s, r));
+}
+#undef FUNC_NAME
+
+void
+scm_exact_integer_sqrt (SCM k, SCM *sp, SCM *rp)
+{
+ if (SCM_LIKELY (SCM_I_INUMP (k)))
+ {
+ mpz_t kk, ss, rr;
+
+ 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)))
+ {
+ SCM s, r;
+
+ if (mpz_sgn (SCM_I_BIG_MPZ (k)) < 0)
+ scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k,
+ "exact non-negative integer");
+ s = scm_i_mkbig ();
+ r = scm_i_mkbig ();
+ mpz_sqrtrem (SCM_I_BIG_MPZ (s), SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (k));
+ scm_remember_upto_here_1 (k);
+ *sp = scm_i_normbig (s);
+ *rp = scm_i_normbig (r);
+ }
+ else
+ scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, 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),
"Return the square root of @var{z}. Of the two possible roots\n"
}
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_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_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_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_from_double (sqrt (xx));
+ }
}
else
- SCM_WTA_DISPATCH_1 (g_scm_sqrt, z, 1, s_scm_sqrt);
+ return scm_wta_dispatch_1 (g_scm_sqrt, z, 1, s_scm_sqrt);
}
#undef FUNC_NAME
void
scm_init_numbers ()
{
- int i;
+ if (scm_install_gmp_memory_functions)
+ mp_set_memory_functions (custom_gmp_malloc,
+ custom_gmp_realloc,
+ custom_gmp_free);
mpz_init_set_si (z_negative_one, -1);
scm_add_feature ("complex");
scm_add_feature ("inexact");
flo0 = scm_from_double (0.0);
-
- /* 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
+ flo_log10e = scm_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"
}