-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
* and Bellcore. See scm_divide.
#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/strings.h"
+#include "libguile/bdw-gc.h"
#include "libguile/validate.h"
#include "libguile/numbers.h"
#define M_PI 3.14159265358979323846
#endif
+typedef scm_t_signed_bits scm_t_inum;
+#define scm_from_inum(x) (scm_from_signed_integer (x))
+
\f
/*
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)
+{
+ SCM bignum;
+
+ bignum = PTR2SCM (ptr);
+ mpz_clear (SCM_I_BIG_MPZ (bignum));
+}
+
/* 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);
+
return SCM_PACK (p);
}
+
SCM
scm_i_mkbig ()
{
return z;
}
+static SCM
+scm_i_inum2big (scm_t_inum x)
+{
+ /* Return a newly created bignum initialized to X. */
+ SCM z = make_bignum ();
+#if SIZEOF_VOID_P == SIZEOF_LONG
+ mpz_init_set_si (SCM_I_BIG_MPZ (z), x);
+#else
+ /* Note that in this case, you'll also have to check all mpz_*_ui and
+ mpz_*_si invocations in Guile. */
+#error creation of mpz not implemented for this inum size
+#endif
+ return z;
+}
+
SCM
scm_i_long2big (long x)
{
if (u < (double) (SCM_MOST_POSITIVE_FIXNUM+1)
&& u >= (double) SCM_MOST_NEGATIVE_FIXNUM)
- return SCM_I_MAKINUM ((long) u);
+ return SCM_I_MAKINUM ((scm_t_inum) u);
else
return scm_i_dbl2big (u);
}
/* presume b is a bignum */
if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b)))
{
- long val = mpz_get_si (SCM_I_BIG_MPZ (b));
+ scm_t_inum val = mpz_get_si (SCM_I_BIG_MPZ (b));
if (SCM_FIXABLE (val))
b = SCM_I_MAKINUM (val);
}
/* convert a mpz number to a SCM number. */
if (mpz_fits_slong_p (b))
{
- long val = mpz_get_si (b);
+ scm_t_inum val = mpz_get_si (b);
if (SCM_FIXABLE (val))
return SCM_I_MAKINUM (val);
}
*/
if (SCM_I_INUMP (numerator))
{
- long x = SCM_I_INUM (numerator);
+ scm_t_inum x = SCM_I_INUM (numerator);
if (scm_is_eq (numerator, SCM_INUM0))
return SCM_INUM0;
if (SCM_I_INUMP (denominator))
{
- long y;
+ scm_t_inum y;
y = SCM_I_INUM (denominator);
if (x == y)
return SCM_I_MAKINUM(1);
{
if (SCM_I_INUMP (denominator))
{
- long yy = SCM_I_INUM (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);
}
{
if (SCM_I_INUMP (n))
{
- long val = SCM_I_INUM (n);
+ scm_t_inum val = SCM_I_INUM (n);
return scm_from_bool ((val & 1L) != 0);
}
else if (SCM_BIGP (n))
return scm_from_bool (odd_p);
}
else if (scm_is_true (scm_inf_p (n)))
- return SCM_BOOL_T;
+ SCM_WRONG_TYPE_ARG (1, n);
else if (SCM_REALP (n))
{
double rem = fabs (fmod (SCM_REAL_VALUE(n), 2.0));
{
if (SCM_I_INUMP (n))
{
- long val = SCM_I_INUM (n);
+ scm_t_inum val = SCM_I_INUM (n);
return scm_from_bool ((val & 1L) == 0);
}
else if (SCM_BIGP (n))
return scm_from_bool (even_p);
}
else if (scm_is_true (scm_inf_p (n)))
- return SCM_BOOL_T;
+ SCM_WRONG_TYPE_ARG (1, n);
else if (SCM_REALP (n))
{
double rem = fabs (fmod (SCM_REAL_VALUE(n), 2.0));
{
if (SCM_I_INUMP (x))
{
- long int xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
if (xx >= 0)
return x;
else if (SCM_POSFIXABLE (-xx))
return SCM_I_MAKINUM (-xx);
else
- return scm_i_long2big (-xx);
+ return scm_i_inum2big (-xx);
}
else if (SCM_BIGP (x))
{
{
if (SCM_I_INUMP (x))
{
- long xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
if (yy == 0)
scm_num_overflow (s_quotient);
else
{
- long z = xx / yy;
+ scm_t_inum z = xx / yy;
if (SCM_FIXABLE (z))
return SCM_I_MAKINUM (z);
else
- return scm_i_long2big (z);
+ return scm_i_inum2big (z);
}
}
else if (SCM_BIGP (y))
{
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
if (yy == 0)
scm_num_overflow (s_quotient);
else if (yy == 1)
{
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
if (yy == 0)
scm_num_overflow (s_remainder);
else
{
- long z = SCM_I_INUM (x) % yy;
+ scm_t_inum z = SCM_I_INUM (x) % yy;
return SCM_I_MAKINUM (z);
}
}
{
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
if (yy == 0)
scm_num_overflow (s_remainder);
else
{
if (SCM_I_INUMP (x))
{
- long xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
if (yy == 0)
scm_num_overflow (s_modulo);
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. */
- long z = xx % yy;
- long result;
+ scm_t_inum z = xx % yy;
+ scm_t_inum result;
if (yy < 0)
{
{
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
if (yy == 0)
scm_num_overflow (s_modulo);
else
{
if (SCM_I_INUMP (y))
{
- long xx = SCM_I_INUM (x);
- long yy = SCM_I_INUM (y);
- long u = xx < 0 ? -xx : xx;
- long v = yy < 0 ? -yy : yy;
- long result;
+ 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)
result = v;
else if (yy == 0)
result = u;
else
{
- long k = 1;
- long t;
+ scm_t_inum k = 1;
+ scm_t_inum t;
/* Determine a common factor 2^k */
while (!(1 & (u | v)))
{
}
return (SCM_POSFIXABLE (result)
? SCM_I_MAKINUM (result)
- : scm_i_long2big (result));
+ : scm_i_inum2big (result));
}
else if (SCM_BIGP (y))
{
{
if (SCM_I_INUMP (y))
{
- unsigned long result;
- long yy;
+ scm_t_bits result;
+ scm_t_inum yy;
big_inum:
yy = SCM_I_INUM (y);
if (yy == 0)
scm_remember_upto_here_1 (x);
return (SCM_POSFIXABLE (result)
? SCM_I_MAKINUM (result)
- : scm_from_ulong (result));
+ : scm_from_unsigned_integer (result));
}
else if (SCM_BIGP (y))
{
inumbig:
{
SCM result = scm_i_mkbig ();
- long nn1 = SCM_I_INUM (n1);
+ scm_t_inum nn1 = SCM_I_INUM (n1);
if (nn1 == 0) return SCM_INUM0;
if (nn1 < 0) nn1 = - nn1;
mpz_lcm_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n2), nn1);
SCM scm_logand (SCM n1, SCM n2)
#define FUNC_NAME s_scm_logand
{
- long int nn1;
+ scm_t_inum nn1;
if (SCM_UNBNDP (n2))
{
nn1 = SCM_I_INUM (n1);
if (SCM_I_INUMP (n2))
{
- long nn2 = SCM_I_INUM (n2);
+ scm_t_inum nn2 = SCM_I_INUM (n2);
return SCM_I_MAKINUM (nn1 & nn2);
}
else if SCM_BIGP (n2)
SCM scm_logior (SCM n1, SCM n2)
#define FUNC_NAME s_scm_logior
{
- long int nn1;
+ scm_t_inum nn1;
if (SCM_UNBNDP (n2))
{
SCM scm_logxor (SCM n1, SCM n2)
#define FUNC_NAME s_scm_logxor
{
- long int nn1;
+ scm_t_inum nn1;
if (SCM_UNBNDP (n2))
{
nn1 = SCM_I_INUM (n1);
if (SCM_I_INUMP (n2))
{
- long nn2 = SCM_I_INUM (n2);
+ scm_t_inum nn2 = SCM_I_INUM (n2);
return SCM_I_MAKINUM (nn1 ^ nn2);
}
else if (SCM_BIGP (n2))
"@end lisp")
#define FUNC_NAME s_scm_logtest
{
- long int nj;
+ scm_t_inum nj;
if (SCM_I_INUMP (j))
{
nj = SCM_I_INUM (j);
if (SCM_I_INUMP (k))
{
- long nk = SCM_I_INUM (k);
+ scm_t_inum nk = SCM_I_INUM (k);
return scm_from_bool (nj & nk);
}
else if (SCM_BIGP (k))
"@end lisp")
#define FUNC_NAME s_scm_integer_expt
{
- long i2 = 0;
+ scm_t_inum i2 = 0;
SCM z_i2 = SCM_BOOL_F;
int i2_is_big = 0;
SCM acc = SCM_I_MAKINUM (1L);
SCM_VALIDATE_NUMBER (SCM_ARG1, n);
+ if (!SCM_I_INUMP (k) && !SCM_BIGP (k))
+ SCM_WRONG_TYPE_ARG (2, k);
- /* 0^0 == 1 according to R5RS */
- if (scm_is_eq (n, SCM_INUM0) || scm_is_eq (n, acc))
- return scm_is_false (scm_zero_p(k)) ? n : acc;
+ if (scm_is_true (scm_zero_p (n)))
+ {
+ if (scm_is_true (scm_zero_p (k))) /* 0^0 == 1 per R5RS */
+ return acc; /* return exact 1, regardless of n */
+ else if (scm_is_true (scm_positive_p (k)))
+ return n;
+ else /* return NaN for (0 ^ k) for negative k per R6RS */
+ return scm_nan ();
+ }
+ else if (scm_is_eq (n, acc))
+ return acc;
else if (scm_is_eq (n, SCM_I_MAKINUM (-1L)))
return scm_is_false (scm_even_p (k)) ? n : acc;
if (SCM_I_INUMP (n))
{
- long nn = SCM_I_INUM (n);
+ scm_t_inum nn = SCM_I_INUM (n);
if (bits_to_shift > 0)
{
return n;
if (bits_to_shift < SCM_I_FIXNUM_BIT-1
- && ((unsigned long)
+ && ((scm_t_bits)
(SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
<= 1))
{
}
else
{
- SCM result = scm_i_long2big (nn);
+ SCM result = scm_i_inum2big (nn);
mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
bits_to_shift);
return result;
if (SCM_I_INUMP (n))
{
- long int in = SCM_I_INUM (n);
+ scm_t_inum in = SCM_I_INUM (n);
/* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
* special case requires us to produce a result that has
* more bits than can be stored in a fixnum.
*/
- SCM result = scm_i_long2big (in);
+ SCM result = scm_i_inum2big (in);
mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
bits);
return result;
{
if (SCM_I_INUMP (n))
{
- unsigned long int c = 0;
- long int nn = SCM_I_INUM (n);
+ unsigned long c = 0;
+ scm_t_inum nn = SCM_I_INUM (n);
if (nn < 0)
nn = -1 - nn;
while (nn)
{
if (SCM_I_INUMP (n))
{
- unsigned long int c = 0;
+ unsigned long c = 0;
unsigned int l = 4;
- long int nn = SCM_I_INUM (n);
+ scm_t_inum nn = SCM_I_INUM (n);
if (nn < 0)
nn = -1 - nn;
while (nn)
}
/* use this array as a way to generate a single digit */
-static const char*number_chars="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
+static const char number_chars[] = "0123456789abcdefghijklmnopqrstuvwxyz";
static size_t
idbl2str (double f, char *a, int radix)
size_t i;
scm_t_uintmax n = num;
+ if (rad < 2 || rad > 36)
+ scm_out_of_range ("scm_iuint2str", scm_from_int (rad));
+
for (n /= rad; n > 0; n /= rad)
j++;
int d = n % rad;
n /= rad;
- p[i] = d + ((d < 10) ? '0' : 'a' - 10);
+ p[i] = number_chars[d];
}
return j;
}
/* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
-/* In non ASCII-style encodings the following macro might not work. */
-#define XDIGIT2UINT(d) \
- (uc_is_property_decimal_digit ((int) (unsigned char) d) \
- ? (d) - '0' \
- : uc_tolower ((int) (unsigned char) d) - 'a' + 10)
+/* Caller is responsible for checking that the return value is in range
+ for the given radix, which should be <= 36. */
+static unsigned int
+char_decimal_value (scm_t_uint32 c)
+{
+ /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
+ that's certainly above any valid decimal, so we take advantage of
+ that to elide some tests. */
+ unsigned int d = (unsigned int) uc_decimal_value (c);
+
+ /* If that failed, try extended hexadecimals, then. Only accept ascii
+ hexadecimals. */
+ if (d >= 10U)
+ {
+ c = uc_tolower (c);
+ if (c >= (scm_t_uint32) 'a')
+ d = c - (scm_t_uint32)'a' + 10U;
+ }
+ return d;
+}
static SCM
mem2uinteger (SCM mem, unsigned int *p_idx,
return SCM_BOOL_F;
c = scm_i_string_ref (mem, idx);
- if (!uc_is_property_ascii_hex_digit ((scm_t_uint32) c))
- return SCM_BOOL_F;
- digit_value = XDIGIT2UINT (c);
+ digit_value = char_decimal_value (c);
if (digit_value >= radix)
return SCM_BOOL_F;
while (idx != len)
{
scm_t_wchar c = scm_i_string_ref (mem, idx);
- if (uc_is_property_ascii_hex_digit ((scm_t_uint32) c))
- {
- if (hash_seen)
- break;
- digit_value = XDIGIT2UINT (c);
- if (digit_value >= radix)
- break;
- }
- else if (c == '#')
+ if (c == '#')
{
hash_seen = 1;
digit_value = 0;
}
+ else if (hash_seen)
+ break;
else
- break;
+ {
+ digit_value = char_decimal_value (c);
+ /* This check catches non-decimals in addition to out-of-range
+ decimals. */
+ if (digit_value >= radix)
+ break;
+ }
idx++;
if (SCM_MOST_POSITIVE_FIXNUM / radix < shift)
if (SCM_COMPLEXP (x))
return SCM_BOOL_F;
r = SCM_REAL_VALUE (x);
- /* +/-inf passes r==floor(r), making those #t */
+ if (isinf (r))
+ return SCM_BOOL_F;
if (r == floor (r))
return SCM_BOOL_T;
return SCM_BOOL_F;
again:
if (SCM_I_INUMP (x))
{
- long xx = SCM_I_INUM (x);
+ scm_t_signed_bits xx = SCM_I_INUM (x);
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_signed_bits yy = SCM_I_INUM (y);
return scm_from_bool (xx == yy);
}
else if (SCM_BIGP (y))
An alternative (for any size system actually) would be to check
yy is an integer (with floor) and is in range of an inum
(compare against appropriate powers of 2) then test
- xx==(long)yy. It's just a matter of which casts/comparisons
- might be fastest or easiest for the cpu. */
+ xx==(scm_t_signed_bits)yy. It's just a matter of which
+ casts/comparisons might be fastest or easiest for the cpu. */
double yy = SCM_REAL_VALUE (y);
return scm_from_bool ((double) xx == yy
&& (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1
- || xx == (long) yy));
+ || xx == (scm_t_signed_bits) yy));
}
else if (SCM_COMPLEXP (y))
return scm_from_bool (((double) xx == SCM_COMPLEX_REAL (y))
if (SCM_I_INUMP (y))
{
/* see comments with inum/real above */
- long yy = SCM_I_INUM (y);
+ scm_t_signed_bits yy = SCM_I_INUM (y);
return scm_from_bool (xx == (double) yy
&& (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1
- || (long) xx == yy));
+ || (scm_t_signed_bits) xx == yy));
}
else if (SCM_BIGP (y))
{
again:
if (SCM_I_INUMP (x))
{
- long xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
return scm_from_bool (xx < yy);
}
else if (SCM_BIGP (y))
if (SCM_I_INUMP (x))
{
- long xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
return (xx < yy) ? y : x;
}
else if (SCM_BIGP (y))
if (SCM_I_INUMP (x))
{
- long xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
return (xx < yy) ? x : y;
}
else if (SCM_BIGP (y))
{
if (SCM_LIKELY (SCM_I_INUMP (y)))
{
- long xx = SCM_I_INUM (x);
- long yy = SCM_I_INUM (y);
- long int z = xx + yy;
- return SCM_FIXABLE (z) ? SCM_I_MAKINUM (z) : scm_i_long2big (z);
+ scm_t_inum xx = SCM_I_INUM (x);
+ scm_t_inum yy = SCM_I_INUM (y);
+ scm_t_inum z = xx + yy;
+ return SCM_FIXABLE (z) ? SCM_I_MAKINUM (z) : scm_i_inum2big (z);
}
else if (SCM_BIGP (y))
{
}
else if (SCM_REALP (y))
{
- long int xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
return scm_from_double (xx + SCM_REAL_VALUE (y));
}
else if (SCM_COMPLEXP (y))
{
- long int xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
return scm_c_make_rectangular (xx + SCM_COMPLEX_REAL (y),
SCM_COMPLEX_IMAG (y));
}
{
if (SCM_I_INUMP (y))
{
- long int inum;
+ scm_t_inum inum;
int bigsgn;
add_big_inum:
inum = SCM_I_INUM (y);
else
if (SCM_I_INUMP (x))
{
- long xx = -SCM_I_INUM (x);
+ scm_t_inum xx = -SCM_I_INUM (x);
if (SCM_FIXABLE (xx))
return SCM_I_MAKINUM (xx);
else
- return scm_i_long2big (xx);
+ return scm_i_inum2big (xx);
}
else if (SCM_BIGP (x))
/* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
{
if (SCM_LIKELY (SCM_I_INUMP (y)))
{
- long int xx = SCM_I_INUM (x);
- long int yy = SCM_I_INUM (y);
- long int z = xx - yy;
+ scm_t_inum xx = SCM_I_INUM (x);
+ scm_t_inum yy = SCM_I_INUM (y);
+ scm_t_inum z = xx - yy;
if (SCM_FIXABLE (z))
return SCM_I_MAKINUM (z);
else
- return scm_i_long2big (z);
+ return scm_i_inum2big (z);
}
else if (SCM_BIGP (y))
{
/* inum-x - big-y */
- long xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
if (xx == 0)
return scm_i_clonebig (y, 0);
}
else if (SCM_REALP (y))
{
- long int xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
return scm_from_double (xx - SCM_REAL_VALUE (y));
}
else if (SCM_COMPLEXP (y))
{
- long int xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
return scm_c_make_rectangular (xx - SCM_COMPLEX_REAL (y),
- SCM_COMPLEX_IMAG (y));
}
if (SCM_I_INUMP (y))
{
/* big-x - inum-y */
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
scm_remember_upto_here_1 (x);
if (sgn_x == 0)
return (SCM_FIXABLE (-yy) ?
- SCM_I_MAKINUM (-yy) : scm_from_long (-yy));
+ SCM_I_MAKINUM (-yy) : scm_from_inum (-yy));
else
{
SCM result = scm_i_mkbig ();
if (SCM_LIKELY (SCM_I_INUMP (x)))
{
- long xx;
+ scm_t_inum xx;
intbig:
xx = SCM_I_INUM (x);
if (SCM_LIKELY (SCM_I_INUMP (y)))
{
- long yy = SCM_I_INUM (y);
- long kk = xx * yy;
+ 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;
else
{
- SCM result = scm_i_long2big (xx);
+ SCM result = scm_i_inum2big (xx);
mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), yy);
return scm_i_normbig (result);
}
SCM_WTA_DISPATCH_0 (g_divide, s_divide);
else if (SCM_I_INUMP (x))
{
- long xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
if (xx == 1 || xx == -1)
return x;
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
if (SCM_LIKELY (SCM_I_INUMP (x)))
{
- long xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
if (SCM_LIKELY (SCM_I_INUMP (y)))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
if (yy == 0)
{
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
}
else
{
- long z = xx / yy;
+ scm_t_inum z = xx / yy;
if (SCM_FIXABLE (z))
return SCM_I_MAKINUM (z);
else
- return scm_i_long2big (z);
+ return scm_i_inum2big (z);
}
}
else if (SCM_BIGP (y))
{
if (SCM_I_INUMP (y))
{
- long int yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
if (yy == 0)
{
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
middle ground: test, then if divisible, use the faster div
func. */
- long abs_yy = yy < 0 ? -yy : yy;
+ scm_t_inum abs_yy = yy < 0 ? -yy : yy;
int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (x), abs_yy);
if (divisible_p)
double rx = SCM_REAL_VALUE (x);
if (SCM_I_INUMP (y))
{
- long int yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
if (yy == 0)
scm_num_overflow (s_divide);
double ix = SCM_COMPLEX_IMAG (x);
if (SCM_I_INUMP (y))
{
- long int yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
if (yy == 0)
scm_num_overflow (s_divide);
{
if (SCM_I_INUMP (y))
{
- long int yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
if (yy == 0)
scm_num_overflow (s_divide);
"Return @var{x} raised to the power of @var{y}.")
#define FUNC_NAME s_scm_expt
{
- if (scm_is_true (scm_exact_p (x)) && scm_is_integer (y))
- return scm_integer_expt (x, y);
+ if (scm_is_integer (y))
+ {
+ if (scm_is_true (scm_exact_p (y)))
+ return scm_integer_expt (x, y);
+ else
+ {
+ /* Here we handle the case where the exponent is an inexact
+ integer. We make the exponent exact in order to use
+ scm_integer_expt, and thus avoid the spurious imaginary
+ parts that may result from round-off errors in the general
+ e^(y log x) method below (for example when squaring a large
+ negative number). In this case, we must return an inexact
+ result for correctness. We also make the base inexact so
+ that scm_integer_expt will use fast inexact arithmetic
+ internally. Note that making the base inexact is not
+ sufficient to guarantee an inexact result, because
+ scm_integer_expt will return an exact 1 when the exponent
+ is 0, even if the base is inexact. */
+ return scm_exact_to_inexact
+ (scm_integer_expt (scm_exact_to_inexact (x),
+ scm_inexact_to_exact (y)));
+ }
+ }
else if (scm_is_real (x) && scm_is_real (y) && scm_to_double (x) >= 0.0)
{
return scm_from_double (pow (scm_to_double (x), scm_to_double (y)));
else
{
SCM z;
- SCM_NEWSMOB (z, scm_tc16_complex,
- scm_gc_malloc_pointerless (sizeof (scm_t_complex),
+
+ z = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex),
"complex"));
+ SCM_SET_CELL_TYPE (z, scm_tc16_complex);
SCM_COMPLEX_REAL (z) = re;
SCM_COMPLEX_IMAG (z) = im;
return z;
{
if (SCM_I_INUMP (z))
{
- long int zz = SCM_I_INUM (z);
+ scm_t_inum zz = SCM_I_INUM (z);
if (zz >= 0)
return z;
else if (SCM_POSFIXABLE (-zz))
return SCM_I_MAKINUM (-zz);
else
- return scm_i_long2big (-zz);
+ return scm_i_inum2big (-zz);
}
else if (SCM_BIGP (z))
{
SCM
scm_from_double (double val)
{
- SCM z = scm_double_cell (scm_tc16_real, 0, 0, 0);
+ SCM z;
+
+ z = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double), "real"));
+
+ SCM_SET_CELL_TYPE (z, scm_tc16_real);
SCM_REAL_VALUE (z) = val;
+
return z;
}
#if SCM_ENABLE_DEPRECATED == 1
float
-scm_num2float (SCM num, unsigned long int pos, const char *s_caller)
+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.");
}
double
-scm_num2double (SCM num, unsigned long int pos, const char *s_caller)
+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.");
HCoop / bpt / guile.git / blobdiff