X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/e06beeaddab802e600390bfcf4ca58f2166681cd..bc721aa21d970eb1532dd19fc4778c8969bd4016:/libguile/numbers.c diff --git a/libguile/numbers.c b/libguile/numbers.c index 48abc2d46..52d6fe60a 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005 Free Software Foundation, Inc. * * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories * and Bellcore. See scm_divide. @@ -16,7 +16,7 @@ * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */ @@ -25,6 +25,7 @@ * All objects satisfying SCM_BIGP() are too large to fit in a fixnum. * If an object satisfies integer?, it's either an inum, a bignum, or a real. * If floor (r) == r, r is an int, and mpz_set_d will DTRT. + * All objects satisfying SCM_FRACTIONP are never an integer. */ /* TODO: @@ -39,6 +40,9 @@ */ +/* tell glibc (2.3) to give prototype for C99 trunc() */ +#define _GNU_SOURCE + #if HAVE_CONFIG_H # include #endif @@ -46,7 +50,7 @@ #include #include #include -#include + #include "libguile/_scm.h" #include "libguile/feature.h" #include "libguile/ports.h" @@ -58,6 +62,10 @@ #include "libguile/numbers.h" #include "libguile/deprecation.h" +#include "libguile/eq.h" + +#include "libguile/discouraged.h" + /* @@ -71,11 +79,12 @@ #define SCM_I_NUMTAG_REAL scm_tc16_real #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex #define SCM_I_NUMTAG(x) \ - (SCM_INUMP(x) ? SCM_I_NUMTAG_INUM \ + (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \ : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \ - : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_smob) ? SCM_TYP16(x) \ + : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \ : SCM_I_NUMTAG_NOTNUM))) */ +/* the macro above will not work as is with fractions */ #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0) @@ -83,7 +92,7 @@ /* FLOBUFLEN is the maximum number of characters neccessary for the * printed or scm_string representation of an inexact number. */ -#define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10) +#define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10) #if defined (SCO) #if ! defined (HAVE_ISNAN) @@ -106,26 +115,48 @@ isinf (double x) #endif -/* mpz_cmp_d only recognises infinities in gmp 4.2 and up. - For prior versions use an explicit check here. */ -#if __GNU_MP_VERSION < 4 \ - || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR < 2) +/* 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. */ +#if 1 #define xmpz_cmp_d(z, d) \ (xisinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d)) #else #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d) #endif +/* For reference, sparc solaris 7 has infinities (IEEE) but doesn't have + isinf. It does have finite and isnan though, hence the use of those. + fpclass would be a possibility on that system too. */ +static int +xisinf (double x) +{ +#if defined (HAVE_ISINF) + return isinf (x); +#elif defined (HAVE_FINITE) && defined (HAVE_ISNAN) + return (! (finite (x) || isnan (x))); +#else + return 0; +#endif +} + +static int +xisnan (double x) +{ +#if defined (HAVE_ISNAN) + return isnan (x); +#else + return 0; +#endif +} + -static SCM abs_most_negative_fixnum; static mpz_t z_negative_one; -static const char s_bignum[] = "bignum"; - -SCM_C_INLINE SCM +SCM_C_INLINE_KEYWORD SCM scm_i_mkbig () { /* Return a newly created bignum. */ @@ -134,17 +165,36 @@ scm_i_mkbig () return z; } -SCM_C_INLINE static SCM +SCM_C_INLINE_KEYWORD SCM +scm_i_long2big (long x) +{ + /* Return a newly created bignum initialized to X. */ + SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + mpz_init_set_si (SCM_I_BIG_MPZ (z), x); + return z; +} + +SCM_C_INLINE_KEYWORD SCM +scm_i_ulong2big (unsigned long x) +{ + /* Return a newly created bignum initialized to X. */ + SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + mpz_init_set_ui (SCM_I_BIG_MPZ (z), x); + return z; +} + +SCM_C_INLINE_KEYWORD SCM scm_i_clonebig (SCM src_big, int same_sign_p) { /* Copy src_big's value, negate it if same_sign_p is false, and return. */ SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); mpz_init_set (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (src_big)); - if (!same_sign_p) mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z)); + if (!same_sign_p) + mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z)); return z; } -SCM_C_INLINE int +SCM_C_INLINE_KEYWORD int scm_i_bigcmp (SCM x, SCM y) { /* Return neg if x < y, pos if x > y, and 0 if x == y */ @@ -154,7 +204,7 @@ scm_i_bigcmp (SCM x, SCM y) return result; } -SCM_C_INLINE SCM +SCM_C_INLINE_KEYWORD SCM scm_i_dbl2big (double d) { /* results are only defined if d is an integer */ @@ -163,15 +213,106 @@ scm_i_dbl2big (double d) return z; } -SCM_C_INLINE double +/* Convert a integer in double representation to a SCM number. */ + +SCM_C_INLINE_KEYWORD SCM +scm_i_dbl2num (double u) +{ + /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both + powers of 2, so there's no rounding when making "double" values + from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could + get rounded on a 64-bit machine, hence the "+1". + + The use of floor() to force to an integer value ensures we get a + "numerically closest" value without depending on how a + double->long cast or how mpz_set_d will round. For reference, + double->long probably follows the hardware rounding mode, + mpz_set_d truncates towards zero. */ + + /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not + representable as a double? */ + + if (u < (double) (SCM_MOST_POSITIVE_FIXNUM+1) + && u >= (double) SCM_MOST_NEGATIVE_FIXNUM) + return SCM_I_MAKINUM ((long) u); + else + 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. + + 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. + + 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) { - double result = mpz_get_d (SCM_I_BIG_MPZ (b)); + 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 + + 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))) + { + result += ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b)), pos + 1); + } + } + scm_remember_upto_here_1 (b); return result; } -SCM_C_INLINE SCM +SCM_C_INLINE_KEYWORD SCM scm_i_normbig (SCM b) { /* convert a big back to a fixnum if it'll fit */ @@ -180,20 +321,154 @@ scm_i_normbig (SCM b) { long val = mpz_get_si (SCM_I_BIG_MPZ (b)); if (SCM_FIXABLE (val)) - b = SCM_MAKINUM (val); + b = SCM_I_MAKINUM (val); } return b; } +static SCM_C_INLINE_KEYWORD SCM +scm_i_mpz2num (mpz_t b) +{ + /* convert a mpz number to a SCM number. */ + if (mpz_fits_slong_p (b)) + { + long val = mpz_get_si (b); + if (SCM_FIXABLE (val)) + return SCM_I_MAKINUM (val); + } + + { + SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + mpz_init_set (SCM_I_BIG_MPZ (z), b); + return z; + } +} + +/* 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); + +static SCM +scm_i_make_ratio (SCM numerator, SCM denominator) +#define FUNC_NAME "make-ratio" +{ + /* First make sure the arguments are proper. + */ + if (SCM_I_INUMP (denominator)) + { + if (scm_is_eq (denominator, SCM_INUM0)) + scm_num_overflow ("make-ratio"); + if (scm_is_eq (denominator, SCM_I_MAKINUM(1))) + return numerator; + } + else + { + if (!(SCM_BIGP(denominator))) + SCM_WRONG_TYPE_ARG (2, denominator); + } + 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); + } + + /* Now consider for each of the four fixnum/bignum combinations + whether the rational number is really an integer. + */ + if (SCM_I_INUMP (numerator)) + { + long x = SCM_I_INUM (numerator); + if (scm_is_eq (numerator, SCM_INUM0)) + return SCM_INUM0; + if (SCM_I_INUMP (denominator)) + { + long y; + y = SCM_I_INUM (denominator); + if (x == y) + return SCM_I_MAKINUM(1); + if ((x % y) == 0) + return SCM_I_MAKINUM (x / y); + } + 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); + } + } + else if (SCM_BIGP (numerator)) + { + if (SCM_I_INUMP (denominator)) + { + long 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_I_MAKINUM(1); + if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator), + SCM_I_BIG_MPZ (denominator))) + return scm_divide(numerator, denominator); + } + } + + /* No, it's a proper fraction. + */ + return scm_double_cell (scm_tc16_fraction, + SCM_UNPACK (numerator), + SCM_UNPACK (denominator), 0); +} +#undef FUNC_NAME + +static void scm_i_fraction_reduce (SCM z) +{ + if (!(SCM_FRACTION_REDUCED (z))) + { + SCM divisor; + divisor = scm_gcd (SCM_FRACTION_NUMERATOR (z), SCM_FRACTION_DENOMINATOR (z)); + if (!(scm_is_eq (divisor, SCM_I_MAKINUM(1)))) + { + /* is this safe? */ + SCM_FRACTION_SET_NUMERATOR (z, scm_divide (SCM_FRACTION_NUMERATOR (z), divisor)); + SCM_FRACTION_SET_DENOMINATOR (z, scm_divide (SCM_FRACTION_DENOMINATOR (z), divisor)); + } + SCM_FRACTION_REDUCED_SET (z); + } +} + +double +scm_i_fraction2double (SCM z) +{ + return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z), + SCM_FRACTION_DENOMINATOR (z))); +} + SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0, (SCM x), "Return @code{#t} if @var{x} is an exact number, @code{#f}\n" "otherwise.") #define FUNC_NAME s_scm_exact_p { - if (SCM_INUMP (x)) return SCM_BOOL_T; - if (SCM_BIGP (x)) return SCM_BOOL_T; - return SCM_BOOL_F; + if (SCM_I_INUMP (x)) + return SCM_BOOL_T; + if (SCM_BIGP (x)) + return SCM_BOOL_T; + if (SCM_FRACTIONP (x)) + return SCM_BOOL_T; + if (SCM_NUMBERP (x)) + return SCM_BOOL_F; + SCM_WRONG_TYPE_ARG (1, x); } #undef FUNC_NAME @@ -204,18 +479,31 @@ SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0, "otherwise.") #define FUNC_NAME s_scm_odd_p { - if (SCM_INUMP (n)) { - long val = SCM_INUM (n); - return SCM_BOOL ((val & 1L) != 0); - } else if (SCM_BIGP (n)) { - int odd_p = mpz_odd_p (SCM_I_BIG_MPZ (n)); - scm_remember_upto_here_1 (n); - return SCM_BOOL (odd_p); - } else if (scm_inf_p (n)) { + if (SCM_I_INUMP (n)) + { + long val = SCM_I_INUM (n); + return scm_from_bool ((val & 1L) != 0); + } + else if (SCM_BIGP (n)) + { + int odd_p = mpz_odd_p (SCM_I_BIG_MPZ (n)); + scm_remember_upto_here_1 (n); + return scm_from_bool (odd_p); + } + else if (scm_is_true (scm_inf_p (n))) return SCM_BOOL_T; - } else { + else if (SCM_REALP (n)) + { + double rem = fabs (fmod (SCM_REAL_VALUE(n), 2.0)); + if (rem == 1.0) + return SCM_BOOL_T; + else if (rem == 0.0) + return SCM_BOOL_F; + else + SCM_WRONG_TYPE_ARG (1, n); + } + else SCM_WRONG_TYPE_ARG (1, n); - } } #undef FUNC_NAME @@ -226,59 +514,47 @@ SCM_DEFINE (scm_even_p, "even?", 1, 0, 0, "otherwise.") #define FUNC_NAME s_scm_even_p { - if (SCM_INUMP (n)) { - long val = SCM_INUM (n); - return SCM_BOOL ((val & 1L) == 0); - } else if (SCM_BIGP (n)) { - int even_p = mpz_even_p (SCM_I_BIG_MPZ (n)); - scm_remember_upto_here_1 (n); - return SCM_BOOL (even_p); - } else if (scm_inf_p (n)) { + if (SCM_I_INUMP (n)) + { + long val = SCM_I_INUM (n); + return scm_from_bool ((val & 1L) == 0); + } + else if (SCM_BIGP (n)) + { + int even_p = mpz_even_p (SCM_I_BIG_MPZ (n)); + scm_remember_upto_here_1 (n); + return scm_from_bool (even_p); + } + else if (scm_is_true (scm_inf_p (n))) return SCM_BOOL_T; - } else { + else if (SCM_REALP (n)) + { + double rem = fabs (fmod (SCM_REAL_VALUE(n), 2.0)); + if (rem == 1.0) + return SCM_BOOL_F; + else if (rem == 0.0) + return SCM_BOOL_T; + else + SCM_WRONG_TYPE_ARG (1, n); + } + else SCM_WRONG_TYPE_ARG (1, n); - } } #undef FUNC_NAME -static int -xisinf (double x) -{ -#if defined (HAVE_ISINF) - return isinf (x); -#elif defined (HAVE_FINITE) && defined (HAVE_ISNAN) - return (! (finite (x) || isnan (x))); -#else - return 0; -#endif -} - -static int -xisnan (double x) -{ -#if defined (HAVE_ISNAN) - return isnan (x); -#else - return 0; -#endif -} - -#define isfinite(x) (! xisinf (x)) - SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0, - (SCM n), - "Return @code{#t} if @var{n} is infinite, @code{#f}\n" - "otherwise.") + (SCM x), + "Return @code{#t} if @var{x} is either @samp{+inf.0}\n" + "or @samp{-inf.0}, @code{#f} otherwise.") #define FUNC_NAME s_scm_inf_p { - if (SCM_REALP (n)) { - return SCM_BOOL (xisinf (SCM_REAL_VALUE (n))); - } else if (SCM_COMPLEXP (n)) { - return SCM_BOOL (xisinf (SCM_COMPLEX_REAL (n)) - || xisinf (SCM_COMPLEX_IMAG (n))); - } else { + if (SCM_REALP (x)) + return scm_from_bool (xisinf (SCM_REAL_VALUE (x))); + else if (SCM_COMPLEXP (x)) + return scm_from_bool (xisinf (SCM_COMPLEX_REAL (x)) + || xisinf (SCM_COMPLEX_IMAG (x))); + else return SCM_BOOL_F; - } } #undef FUNC_NAME @@ -288,14 +564,13 @@ SCM_DEFINE (scm_nan_p, "nan?", 1, 0, 0, "otherwise.") #define FUNC_NAME s_scm_nan_p { - if (SCM_REALP (n)) { - return SCM_BOOL (xisnan (SCM_REAL_VALUE (n))); - } else if (SCM_COMPLEXP (n)) { - return SCM_BOOL (xisnan (SCM_COMPLEX_REAL (n)) + if (SCM_REALP (n)) + return scm_from_bool (xisnan (SCM_REAL_VALUE (n))); + else if (SCM_COMPLEXP (n)) + return scm_from_bool (xisnan (SCM_COMPLEX_REAL (n)) || xisnan (SCM_COMPLEX_IMAG (n))); - } else { + else return SCM_BOOL_F; - } } #undef FUNC_NAME @@ -313,10 +588,15 @@ guile_ieee_init (void) /* Some version of gcc on some old version of Linux used to crash when trying to make Inf and NaN. */ -#if defined (SCO) - double tmp = 1.0; - guile_Inf = 1.0 / (tmp - tmp); -#elif defined (__alpha__) && ! defined (linux) +#ifdef INFINITY + /* C99 INFINITY, when available. + FIXME: The standard allows for INFINITY to be something that overflows + at compile time. We ought to have a configure test to check for that + before trying to use it. (But in practice we believe this is not a + problem on any system guile is likely to target.) */ + guile_Inf = INFINITY; +#elif HAVE_DINFINITY + /* OSF */ extern unsigned int DINFINITY[2]; guile_Inf = (*(X_CAST(double *, DINFINITY))); #else @@ -335,7 +615,11 @@ guile_ieee_init (void) #if defined (HAVE_ISNAN) -#if defined (__alpha__) && ! defined (linux) +#ifdef NAN + /* C99 NAN, when available */ + guile_NaN = NAN; +#elif HAVE_DQNAN + /* OSF */ extern unsigned int DQNAN[2]; guile_NaN = (*(X_CAST(double *, DQNAN))); #else @@ -356,7 +640,7 @@ SCM_DEFINE (scm_inf, "inf", 0, 0, 0, guile_ieee_init (); initialized = 1; } - return scm_make_real (guile_Inf); + return scm_from_double (guile_Inf); } #undef FUNC_NAME @@ -366,12 +650,12 @@ SCM_DEFINE (scm_nan, "nan", 0, 0, 0, #define FUNC_NAME s_scm_nan { static int initialized = 0; - if (! initialized) + if (!initialized) { guile_ieee_init (); initialized = 1; } - return scm_make_real (guile_NaN); + return scm_from_double (guile_NaN); } #undef FUNC_NAME @@ -381,27 +665,42 @@ SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0, "Return the absolute value of @var{x}.") #define FUNC_NAME { - if (SCM_INUMP (x)) { - long int xx = SCM_INUM (x); - if (xx >= 0) { - return x; - } else if (SCM_POSFIXABLE (-xx)) { - return SCM_MAKINUM (-xx); - } else { - return scm_i_long2big (-xx); - } - } else if (SCM_BIGP (x)) { - const int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); - if (sgn < 0) { - return scm_i_clonebig (x, 0); - } else { - return x; - } - } else if (SCM_REALP (x)) { - return scm_make_real (fabs (SCM_REAL_VALUE (x))); - } else { + if (SCM_I_INUMP (x)) + { + long int 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); + } + else if (SCM_BIGP (x)) + { + const int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); + if (sgn < 0) + return scm_i_clonebig (x, 0); + else + return x; + } + else if (SCM_REALP (x)) + { + /* note that if x is a NaN then xx<0 is false so we return x unchanged */ + double xx = SCM_REAL_VALUE (x); + if (xx < 0.0) + return scm_from_double (-xx); + else + return x; + } + else if (SCM_FRACTIONP (x)) + { + 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)); + } + else SCM_WTA_DISPATCH_1 (g_scm_abs, x, 1, s_scm_abs); - } } #undef FUNC_NAME @@ -412,63 +711,78 @@ SCM_GPROC (s_quotient, "quotient", 2, 0, 0, scm_quotient, g_quotient); SCM scm_quotient (SCM x, SCM y) { - if (SCM_INUMP (x)) { - long xx = SCM_INUM (x); - if (SCM_INUMP (y)) { - long yy = SCM_INUM (y); - if (yy == 0) { - scm_num_overflow (s_quotient); - } else { - long z = xx / yy; - if (SCM_FIXABLE (z)) { - return SCM_MAKINUM (z); - } else { - return scm_i_long2big (z); + if (SCM_I_INUMP (x)) + { + long xx = SCM_I_INUM (x); + if (SCM_I_INUMP (y)) + { + long yy = SCM_I_INUM (y); + if (yy == 0) + scm_num_overflow (s_quotient); + else + { + long z = xx / yy; + if (SCM_FIXABLE (z)) + return SCM_I_MAKINUM (z); + else + return scm_i_long2big (z); + } } - } - } else if (SCM_BIGP (y)) { - if ((SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM) - && (scm_i_bigcmp (abs_most_negative_fixnum, y) == 0)) + else if (SCM_BIGP (y)) { - /* Special case: x == fixnum-min && y == abs (fixnum-min) */ - return SCM_MAKINUM (-1); + 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_I_MAKINUM (0); } else - return SCM_MAKINUM (0); - } else { - SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient); - } - } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) { - long yy = SCM_INUM (y); - if (yy == 0) { - scm_num_overflow (s_quotient); - } else if (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); - } else { - SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient); + SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient); } - } else { + else if (SCM_BIGP (x)) + { + if (SCM_I_INUMP (y)) + { + long yy = SCM_I_INUM (y); + if (yy == 0) + scm_num_overflow (s_quotient); + else if (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); + } + else + SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient); + } + else SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG1, s_quotient); - } } SCM_GPROC (s_remainder, "remainder", 2, 0, 0, scm_remainder, g_remainder); @@ -481,55 +795,69 @@ SCM_GPROC (s_remainder, "remainder", 2, 0, 0, scm_remainder, g_remainder); SCM scm_remainder (SCM x, SCM y) { - if (SCM_INUMP (x)) { - if (SCM_INUMP (y)) { - long yy = SCM_INUM (y); - if (yy == 0) { - scm_num_overflow (s_remainder); - } else { - long z = SCM_INUM (x) % yy; - return SCM_MAKINUM (z); - } - } else if (SCM_BIGP (y)) { - if ((SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM) - && (scm_i_bigcmp (abs_most_negative_fixnum, y) == 0)) + if (SCM_I_INUMP (x)) + { + if (SCM_I_INUMP (y)) + { + long yy = SCM_I_INUM (y); + if (yy == 0) + scm_num_overflow (s_remainder); + else + { + long z = SCM_I_INUM (x) % yy; + return SCM_I_MAKINUM (z); + } + } + else if (SCM_BIGP (y)) { - /* Special case: x == fixnum-min && y == abs (fixnum-min) */ - return SCM_MAKINUM (0); + 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 (0); + } + else + return x; } else - return x; - } else { - SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder); - } - } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) { - long yy = SCM_INUM (y); - if (yy == 0) { - scm_num_overflow (s_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); - } else { - SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder); + SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder); } - } else { - SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG1, s_remainder); - } -} - - + else if (SCM_BIGP (x)) + { + if (SCM_I_INUMP (y)) + { + long yy = SCM_I_INUM (y); + if (yy == 0) + scm_num_overflow (s_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); + } + else + SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder); + } + else + SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG1, s_remainder); +} + + SCM_GPROC (s_modulo, "modulo", 2, 0, 0, scm_modulo, g_modulo); /* "Return the modulo of the numbers @var{x} and @var{y}.\n" * "@lisp\n" @@ -540,109 +868,126 @@ SCM_GPROC (s_modulo, "modulo", 2, 0, 0, scm_modulo, g_modulo); SCM scm_modulo (SCM x, SCM y) { - if (SCM_INUMP (x)) { - long xx = SCM_INUM (x); - if (SCM_INUMP (y)) { - long yy = SCM_INUM (y); - if (yy == 0) { - scm_num_overflow (s_modulo); - } else { - /* FIXME: I think this may be a bug on some arches -- results - of % with negative second arg are undefined... */ - long z = xx % yy; - long result; - - if (yy < 0) { - if (z > 0) result = z + yy; - else result = z; - } else { - if (z < 0) result = z + yy; - else result = z; - } - return SCM_MAKINUM (result); - } - } else if (SCM_BIGP (y)) { - int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); - - if (sgn_y == 0) { - scm_num_overflow (s_modulo); - } else { - 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 (SCM_I_INUMP (x)) + { + long xx = SCM_I_INUM (x); + if (SCM_I_INUMP (y)) + { + long 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; + + if (yy < 0) + { + if (z > 0) + result = z + yy; + else + result = z; + } + else + { + if (z < 0) + result = z + yy; + else + result = z; + } + return SCM_I_MAKINUM (result); + } + } + else if (SCM_BIGP (y)) + { + 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); - } - } else { - SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo); - } - } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) { - long yy = SCM_INUM (y); - if (yy == 0) { - scm_num_overflow (s_modulo); - } 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); - } - } else if (SCM_BIGP (y)) { - int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); - if (sgn_y == 0) { - scm_num_overflow (s_modulo); - } else { - 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)); + 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); + } + } + else + SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo); + } + else if (SCM_BIGP (x)) + { + if (SCM_I_INUMP (y)) + { + long yy = SCM_I_INUM (y); + if (yy == 0) + scm_num_overflow (s_modulo); + 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); + } + } + else if (SCM_BIGP (y)) + { + { + 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); - } - } else { - SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo); + 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); + } + } + else + SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo); } - } else { + else SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG1, s_modulo); - } } SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd); @@ -653,88 +998,89 @@ SCM scm_gcd (SCM x, SCM y) { if (SCM_UNBNDP (y)) - return (SCM_UNBNDP (x)) ? SCM_INUM0 : x; + return SCM_UNBNDP (x) ? SCM_INUM0 : x; - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { - long xx = SCM_INUM (x); - long yy = SCM_INUM (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; - if (xx == 0) { - result = v; - } else if (yy == 0) { - result = u; - } else { - long k = 1; - long t; - /* Determine a common factor 2^k */ - while (!(1 & (u | v))) - { - k <<= 1; - u >>= 1; - v >>= 1; - } - /* Now, any factor 2^n can be eliminated */ - if (u & 1) - t = -v; - else - { - t = u; - b3: - t = SCM_SRS (t, 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; - } - return SCM_POSFIXABLE (result) \ - ? SCM_MAKINUM (result) : scm_i_long2big (result); + if (xx == 0) + result = v; + else if (yy == 0) + result = u; + else + { + long k = 1; + long t; + /* Determine a common factor 2^k */ + while (!(1 & (u | v))) + { + k <<= 1; + u >>= 1; + v >>= 1; + } + /* Now, any factor 2^n can be eliminated */ + if (u & 1) + t = -v; + else + { + t = u; + b3: + t = SCM_SRS (t, 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; + } + return (SCM_POSFIXABLE (result) + ? SCM_I_MAKINUM (result) + : scm_i_long2big (result)); } else if (SCM_BIGP (y)) { - SCM result = scm_i_mkbig (); - SCM mx = scm_i_mkbig (); - mpz_set_si(SCM_I_BIG_MPZ (mx), SCM_INUM (x)); - scm_remember_upto_here_1 (x); - mpz_gcd(SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (mx), SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_2(mx, y); - return scm_i_normbig (result); + SCM_SWAP (x, y); + goto big_inum; } else SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd); } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) + if (SCM_I_INUMP (y)) { unsigned long result; - long yy = SCM_INUM (y); + long yy; + big_inum: + yy = SCM_I_INUM (y); if (yy == 0) return scm_abs (x); - if (yy < 0) yy = -yy; + if (yy < 0) + yy = -yy; result = mpz_gcd_ui (NULL, SCM_I_BIG_MPZ (x), yy); scm_remember_upto_here_1 (x); - return SCM_POSFIXABLE (result) \ - ? SCM_MAKINUM (result) : scm_ulong2num (result); + return (SCM_POSFIXABLE (result) + ? SCM_I_MAKINUM (result) + : scm_from_ulong (result)); } else if (SCM_BIGP (y)) { SCM result = scm_i_mkbig (); - mpz_gcd(SCM_I_BIG_MPZ (result), - SCM_I_BIG_MPZ (x), - SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_2(x, y); + mpz_gcd (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 @@ -754,21 +1100,21 @@ scm_lcm (SCM n1, SCM n2) if (SCM_UNBNDP (n2)) { if (SCM_UNBNDP (n1)) - return SCM_MAKINUM (1L); - n2 = SCM_MAKINUM (1L); + return SCM_I_MAKINUM (1L); + n2 = SCM_I_MAKINUM (1L); } - SCM_GASSERT2 (SCM_INUMP (n1) || SCM_BIGP (n1), + SCM_GASSERT2 (SCM_I_INUMP (n1) || SCM_BIGP (n1), g_lcm, n1, n2, SCM_ARG1, s_lcm); - SCM_GASSERT2 (SCM_INUMP (n2) || SCM_BIGP (n2), + SCM_GASSERT2 (SCM_I_INUMP (n2) || SCM_BIGP (n2), g_lcm, n1, n2, SCM_ARGn, s_lcm); - if (SCM_INUMP (n1)) + if (SCM_I_INUMP (n1)) { - if (SCM_INUMP (n2)) + if (SCM_I_INUMP (n2)) { SCM d = scm_gcd (n1, n2); - if (SCM_EQ_P (d, SCM_INUM0)) + if (scm_is_eq (d, SCM_INUM0)) return d; else return scm_abs (scm_product (n1, scm_quotient (n2, d))); @@ -779,7 +1125,7 @@ scm_lcm (SCM n1, SCM n2) inumbig: { SCM result = scm_i_mkbig (); - long nn1 = SCM_INUM (n1); + long 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); @@ -791,7 +1137,7 @@ scm_lcm (SCM n1, SCM n2) else { /* big n1 */ - if (SCM_INUMP (n2)) + if (SCM_I_INUMP (n2)) { SCM_SWAP (n1, n2); goto inumbig; @@ -809,12 +1155,6 @@ scm_lcm (SCM n1, SCM n2) } } -#ifndef scm_long2num -#define SCM_LOGOP_RETURN(x) scm_ulong2num(x) -#else -#define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x) -#endif - /* Emulating 2's complement bignums with sign magnitude arithmetic: Logand: @@ -857,62 +1197,72 @@ SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr, "@lisp\n" "(logand) @result{} -1\n" "(logand 7) @result{} 7\n" - "(logand #b111 #b011 #\b001) @result{} 1\n" + "(logand #b111 #b011 #b001) @result{} 1\n" "@end lisp") #define FUNC_NAME s_scm_logand { long int nn1; - if (SCM_UNBNDP (n2)) { - if (SCM_UNBNDP (n1)) { - return SCM_MAKINUM (-1); - } else if (!SCM_NUMBERP (n1)) { - SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); - } else if (SCM_NUMBERP (n1)) { - return n1; - } else { - SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); + if (SCM_UNBNDP (n2)) + { + if (SCM_UNBNDP (n1)) + return SCM_I_MAKINUM (-1); + else if (!SCM_NUMBERP (n1)) + SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); + else if (SCM_NUMBERP (n1)) + return n1; + else + SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); } - } - if (SCM_INUMP (n1)) { - nn1 = SCM_INUM (n1); - if (SCM_INUMP (n2)) { - long nn2 = SCM_INUM (n2); - return SCM_MAKINUM (nn1 & nn2); - } else if SCM_BIGP (n2) { - intbig: - if (n1 == 0) return SCM_INUM0; - { - SCM result_z = scm_i_mkbig (); - mpz_t nn1_z; - mpz_init_set_si (nn1_z, nn1); - mpz_and (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2)); - scm_remember_upto_here_1 (n2); - mpz_clear (nn1_z); - return scm_i_normbig (result_z); - } - } else { - SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); - } - } else if (SCM_BIGP (n1)) { - if (SCM_INUMP (n2)) { - SCM_SWAP (n1, n2); - nn1 = SCM_INUM (n1); - goto intbig; - } else if (SCM_BIGP (n2)) { - SCM result_z = scm_i_mkbig (); - mpz_and (SCM_I_BIG_MPZ (result_z), - SCM_I_BIG_MPZ (n1), - SCM_I_BIG_MPZ (n2)); - scm_remember_upto_here_2 (n1, n2); - return scm_i_normbig (result_z); - } else { - SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); + if (SCM_I_INUMP (n1)) + { + nn1 = SCM_I_INUM (n1); + if (SCM_I_INUMP (n2)) + { + long nn2 = SCM_I_INUM (n2); + return SCM_I_MAKINUM (nn1 & nn2); + } + else if SCM_BIGP (n2) + { + intbig: + if (n1 == 0) + return SCM_INUM0; + { + SCM result_z = scm_i_mkbig (); + mpz_t nn1_z; + mpz_init_set_si (nn1_z, nn1); + mpz_and (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2)); + scm_remember_upto_here_1 (n2); + mpz_clear (nn1_z); + return scm_i_normbig (result_z); + } + } + else + SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); } - } else { + else if (SCM_BIGP (n1)) + { + if (SCM_I_INUMP (n2)) + { + SCM_SWAP (n1, n2); + nn1 = SCM_I_INUM (n1); + goto intbig; + } + else if (SCM_BIGP (n2)) + { + SCM result_z = scm_i_mkbig (); + mpz_and (SCM_I_BIG_MPZ (result_z), + SCM_I_BIG_MPZ (n1), + SCM_I_BIG_MPZ (n2)); + scm_remember_upto_here_2 (n1, n2); + return scm_i_normbig (result_z); + } + else + SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); + } + else SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); - } } #undef FUNC_NAME @@ -929,54 +1279,64 @@ SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr, { long int nn1; - if (SCM_UNBNDP (n2)) { - if (SCM_UNBNDP (n1)) { - return SCM_INUM0; - } else if (SCM_NUMBERP (n1)) { - return n1; - } else { - SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); + if (SCM_UNBNDP (n2)) + { + if (SCM_UNBNDP (n1)) + return SCM_INUM0; + else if (SCM_NUMBERP (n1)) + return n1; + else + SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); } - } - if (SCM_INUMP (n1)) { - nn1 = SCM_INUM (n1); - if (SCM_INUMP (n2)) { - long nn2 = SCM_INUM (n2); - return SCM_MAKINUM (nn1 | nn2); - } else if (SCM_BIGP (n2)) { - intbig: - if (nn1 == 0) return n2; - { - SCM result_z = scm_i_mkbig (); - mpz_t nn1_z; - mpz_init_set_si (nn1_z, nn1); - mpz_ior (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2)); - scm_remember_upto_here_1 (n2); - mpz_clear (nn1_z); - return result_z; - } - } else { - SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); - } - } else if (SCM_BIGP (n1)) { - if (SCM_INUMP (n2)) { - SCM_SWAP (n1, n2); - nn1 = SCM_INUM (n1); - goto intbig; - } else if (SCM_BIGP (n2)) { - SCM result_z = scm_i_mkbig (); - mpz_ior (SCM_I_BIG_MPZ (result_z), - SCM_I_BIG_MPZ (n1), - SCM_I_BIG_MPZ (n2)); - scm_remember_upto_here_2 (n1, n2); - return result_z; - } else { - SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); + if (SCM_I_INUMP (n1)) + { + nn1 = SCM_I_INUM (n1); + if (SCM_I_INUMP (n2)) + { + long nn2 = SCM_I_INUM (n2); + return SCM_I_MAKINUM (nn1 | nn2); + } + else if (SCM_BIGP (n2)) + { + intbig: + if (nn1 == 0) + return n2; + { + SCM result_z = scm_i_mkbig (); + mpz_t nn1_z; + mpz_init_set_si (nn1_z, nn1); + mpz_ior (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2)); + scm_remember_upto_here_1 (n2); + mpz_clear (nn1_z); + return scm_i_normbig (result_z); + } + } + else + SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); } - } else { + else if (SCM_BIGP (n1)) + { + if (SCM_I_INUMP (n2)) + { + SCM_SWAP (n1, n2); + nn1 = SCM_I_INUM (n1); + goto intbig; + } + else if (SCM_BIGP (n2)) + { + SCM result_z = scm_i_mkbig (); + mpz_ior (SCM_I_BIG_MPZ (result_z), + SCM_I_BIG_MPZ (n1), + SCM_I_BIG_MPZ (n2)); + scm_remember_upto_here_2 (n1, n2); + return scm_i_normbig (result_z); + } + else + SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); + } + else SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); - } } #undef FUNC_NAME @@ -995,61 +1355,74 @@ SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr, { long int nn1; - if (SCM_UNBNDP (n2)) { - if (SCM_UNBNDP (n1)) { - return SCM_INUM0; - } else if (SCM_NUMBERP (n1)) { - return n1; - } else { - SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); + if (SCM_UNBNDP (n2)) + { + if (SCM_UNBNDP (n1)) + return SCM_INUM0; + else if (SCM_NUMBERP (n1)) + return n1; + else + SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); } - } - if (SCM_INUMP (n1)) { - nn1 = SCM_INUM (n1); - if (SCM_INUMP (n2)) { - long nn2 = SCM_INUM (n2); - return SCM_MAKINUM (nn1 ^ nn2); - } else if (SCM_BIGP (n2)) { - intbig: - { - SCM result_z = scm_i_mkbig (); - mpz_t nn1_z; - mpz_init_set_si (nn1_z, nn1); - mpz_xor (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2)); - scm_remember_upto_here_1 (n2); - mpz_clear (nn1_z); - return scm_i_normbig (result_z); - } - } else { - SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); - } - } else if (SCM_BIGP (n1)) { - if (SCM_INUMP (n2)) { - SCM_SWAP (n1, n2); - nn1 = SCM_INUM (n1); - goto intbig; - } else if (SCM_BIGP (n2)) { - SCM result_z = scm_i_mkbig (); - mpz_xor (SCM_I_BIG_MPZ (result_z), - SCM_I_BIG_MPZ (n1), - SCM_I_BIG_MPZ (n2)); - scm_remember_upto_here_2 (n1, n2); - return scm_i_normbig (result_z); - } else { - SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); + if (SCM_I_INUMP (n1)) + { + nn1 = SCM_I_INUM (n1); + if (SCM_I_INUMP (n2)) + { + long nn2 = SCM_I_INUM (n2); + return SCM_I_MAKINUM (nn1 ^ nn2); + } + else if (SCM_BIGP (n2)) + { + intbig: + { + SCM result_z = scm_i_mkbig (); + mpz_t nn1_z; + mpz_init_set_si (nn1_z, nn1); + mpz_xor (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2)); + scm_remember_upto_here_1 (n2); + mpz_clear (nn1_z); + return scm_i_normbig (result_z); + } + } + else + SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); } - } else { + else if (SCM_BIGP (n1)) + { + if (SCM_I_INUMP (n2)) + { + SCM_SWAP (n1, n2); + nn1 = SCM_I_INUM (n1); + goto intbig; + } + else if (SCM_BIGP (n2)) + { + SCM result_z = scm_i_mkbig (); + mpz_xor (SCM_I_BIG_MPZ (result_z), + SCM_I_BIG_MPZ (n1), + SCM_I_BIG_MPZ (n2)); + scm_remember_upto_here_2 (n1, n2); + return scm_i_normbig (result_z); + } + else + SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); + } + else SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); - } } #undef FUNC_NAME SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0, (SCM j, SCM k), + "Test whether @var{j} and @var{k} have any 1 bits in common.\n" + "This is equivalent to @code{(not (zero? (logand j k)))}, but\n" + "without actually calculating the @code{logand}, just testing\n" + "for non-zero.\n" + "\n" "@lisp\n" - "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n" "(logtest #b0100 #b1011) @result{} #f\n" "(logtest #b0100 #b0111) @result{} #t\n" "@end lisp") @@ -1057,57 +1430,69 @@ SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0, { long int nj; - if (SCM_INUMP (j)) { - nj = SCM_INUM (j); - if (SCM_INUMP (k)) { - long nk = SCM_INUM (k); - return SCM_BOOL (nj & nk); - } else if (SCM_BIGP (k)) { - intbig: - if (nj == 0) return SCM_BOOL_F; - { - SCM result; - mpz_t nj_z; - mpz_init_set_si (nj_z, nj); - mpz_and (nj_z, nj_z, SCM_I_BIG_MPZ (k)); - scm_remember_upto_here_1 (k); - result = SCM_BOOL (mpz_sgn (nj_z) != 0); - mpz_clear (nj_z); - return result; - } - } else { - SCM_WRONG_TYPE_ARG (SCM_ARG2, k); - } - } else if (SCM_BIGP (j)) { - if (SCM_INUMP (k)) { - SCM_SWAP (j, k); - nj = SCM_INUM (j); - goto intbig; - } else if (SCM_BIGP (k)) { - SCM result; - mpz_t result_z; - mpz_init (result_z); - mpz_and (result_z, - SCM_I_BIG_MPZ (j), - SCM_I_BIG_MPZ (k)); - scm_remember_upto_here_2 (j, k); - result = SCM_BOOL (mpz_sgn (result_z) != 0); - mpz_clear (result_z); - return result; - } else { - SCM_WRONG_TYPE_ARG (SCM_ARG2, k); + if (SCM_I_INUMP (j)) + { + nj = SCM_I_INUM (j); + if (SCM_I_INUMP (k)) + { + long nk = SCM_I_INUM (k); + return scm_from_bool (nj & nk); + } + else if (SCM_BIGP (k)) + { + intbig: + if (nj == 0) + return SCM_BOOL_F; + { + SCM result; + mpz_t nj_z; + mpz_init_set_si (nj_z, nj); + mpz_and (nj_z, nj_z, SCM_I_BIG_MPZ (k)); + scm_remember_upto_here_1 (k); + result = scm_from_bool (mpz_sgn (nj_z) != 0); + mpz_clear (nj_z); + return result; + } + } + else + SCM_WRONG_TYPE_ARG (SCM_ARG2, k); } - } else { + else if (SCM_BIGP (j)) + { + if (SCM_I_INUMP (k)) + { + SCM_SWAP (j, k); + nj = SCM_I_INUM (j); + goto intbig; + } + else if (SCM_BIGP (k)) + { + SCM result; + mpz_t result_z; + mpz_init (result_z); + mpz_and (result_z, + SCM_I_BIG_MPZ (j), + SCM_I_BIG_MPZ (k)); + scm_remember_upto_here_2 (j, k); + result = scm_from_bool (mpz_sgn (result_z) != 0); + mpz_clear (result_z); + return result; + } + else + SCM_WRONG_TYPE_ARG (SCM_ARG2, k); + } + else SCM_WRONG_TYPE_ARG (SCM_ARG1, j); - } } #undef FUNC_NAME SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0, (SCM index, SCM j), + "Test whether bit number @var{index} in @var{j} is set.\n" + "@var{index} starts from 0 for the least significant bit.\n" + "\n" "@lisp\n" - "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n" "(logbit? 0 #b1101) @result{} #t\n" "(logbit? 1 #b1101) @result{} #f\n" "(logbit? 2 #b1101) @result{} #t\n" @@ -1117,26 +1502,29 @@ SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0, #define FUNC_NAME s_scm_logbit_p { unsigned long int iindex; + iindex = scm_to_ulong (index); - SCM_VALIDATE_INUM_MIN (SCM_ARG1, index, 0); - iindex = (unsigned long int) SCM_INUM (index); - - if (SCM_INUMP (j)) { - return SCM_BOOL ((1L << iindex) & SCM_INUM (j)); - } else if (SCM_BIGP (j)) { - int val = mpz_tstbit (SCM_I_BIG_MPZ (j), iindex); - scm_remember_upto_here_1 (j); - return SCM_BOOL (val); - } else { + if (SCM_I_INUMP (j)) + { + /* bits above what's in an inum follow the sign bit */ + iindex = min (iindex, SCM_LONG_BIT - 1); + return scm_from_bool ((1L << iindex) & SCM_I_INUM (j)); + } + else if (SCM_BIGP (j)) + { + int val = mpz_tstbit (SCM_I_BIG_MPZ (j), iindex); + scm_remember_upto_here_1 (j); + return scm_from_bool (val); + } + else SCM_WRONG_TYPE_ARG (SCM_ARG2, j); - } } #undef FUNC_NAME SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0, (SCM n), - "Return the integer which is the 2s-complement of the integer\n" + "Return the integer which is the ones-complement of the integer\n" "argument.\n" "\n" "@lisp\n" @@ -1147,59 +1535,179 @@ SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0, "@end lisp") #define FUNC_NAME s_scm_lognot { - return scm_difference (SCM_MAKINUM (-1L), n); + if (SCM_I_INUMP (n)) { + /* No overflow here, just need to toggle all the bits making up the inum. + Enhancement: No need to strip the tag and add it back, could just xor + a block of 1 bits, if that worked with the various debug versions of + the SCM typedef. */ + return SCM_I_MAKINUM (~ SCM_I_INUM (n)); + + } else if (SCM_BIGP (n)) { + SCM result = scm_i_mkbig (); + mpz_com (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n)); + scm_remember_upto_here_1 (n); + return result; + + } else { + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); + } +} +#undef FUNC_NAME + +/* returns 0 if IN is not an integer. OUT must already be + initialized. */ +static int +coerce_to_big (SCM in, mpz_t out) +{ + if (SCM_BIGP (in)) + mpz_set (out, SCM_I_BIG_MPZ (in)); + else if (SCM_I_INUMP (in)) + mpz_set_si (out, SCM_I_INUM (in)); + else + return 0; + + return 1; +} + +SCM_DEFINE (scm_modulo_expt, "modulo-expt", 3, 0, 0, + (SCM n, SCM k, SCM m), + "Return @var{n} raised to the integer exponent\n" + "@var{k}, modulo @var{m}.\n" + "\n" + "@lisp\n" + "(modulo-expt 2 3 5)\n" + " @result{} 3\n" + "@end lisp") +#define FUNC_NAME s_scm_modulo_expt +{ + mpz_t n_tmp; + mpz_t k_tmp; + mpz_t m_tmp; + + /* There are two classes of error we might encounter -- + 1) Math errors, which we'll report by calling scm_num_overflow, + and + 2) wrong-type errors, which of course we'll report by calling + SCM_WRONG_TYPE_ARG. + We don't report those errors immediately, however; instead we do + some cleanup first. These variables tell us which error (if + any) we should report after cleaning up. + */ + int report_overflow = 0; + + int position_of_wrong_type = 0; + SCM value_of_wrong_type = SCM_INUM0; + + SCM result = SCM_UNDEFINED; + + mpz_init (n_tmp); + mpz_init (k_tmp); + mpz_init (m_tmp); + + if (scm_is_eq (m, SCM_INUM0)) + { + report_overflow = 1; + goto cleanup; + } + + if (!coerce_to_big (n, n_tmp)) + { + value_of_wrong_type = n; + position_of_wrong_type = 1; + goto cleanup; + } + + if (!coerce_to_big (k, k_tmp)) + { + value_of_wrong_type = k; + position_of_wrong_type = 2; + goto cleanup; + } + + if (!coerce_to_big (m, m_tmp)) + { + value_of_wrong_type = m; + position_of_wrong_type = 3; + goto cleanup; + } + + /* if the exponent K is negative, and we simply call mpz_powm, we + will get a divide-by-zero exception when an inverse 1/n mod m + doesn't exist (or is not unique). Since exceptions are hard to + handle, we'll attempt the inversion "by hand" -- that way, we get + a simple failure code, which is easy to handle. */ + + if (-1 == mpz_sgn (k_tmp)) + { + if (!mpz_invert (n_tmp, n_tmp, m_tmp)) + { + report_overflow = 1; + goto cleanup; + } + mpz_neg (k_tmp, k_tmp); + } + + result = scm_i_mkbig (); + mpz_powm (SCM_I_BIG_MPZ (result), + n_tmp, + k_tmp, + m_tmp); + + if (mpz_sgn (m_tmp) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result)) != 0) + mpz_add (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), m_tmp); + + cleanup: + mpz_clear (m_tmp); + mpz_clear (k_tmp); + mpz_clear (n_tmp); + + if (report_overflow) + scm_num_overflow (FUNC_NAME); + + if (position_of_wrong_type) + SCM_WRONG_TYPE_ARG (position_of_wrong_type, + value_of_wrong_type); + + return scm_i_normbig (result); } #undef FUNC_NAME SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, (SCM n, SCM k), - "Return @var{n} raised to the non-negative integer exponent\n" - "@var{k}.\n" + "Return @var{n} raised to the power @var{k}. @var{k} must be an\n" + "exact integer, @var{n} can be any number.\n" + "\n" + "Negative @var{k} is supported, and results in @math{1/n^abs(k)}\n" + "in the usual way. @math{@var{n}^0} is 1, as usual, and that\n" + "includes @math{0^0} is 1.\n" "\n" "@lisp\n" - "(integer-expt 2 5)\n" - " @result{} 32\n" - "(integer-expt -3 3)\n" - " @result{} -27\n" + "(integer-expt 2 5) @result{} 32\n" + "(integer-expt -3 3) @result{} -27\n" + "(integer-expt 5 -3) @result{} 1/125\n" + "(integer-expt 0 0) @result{} 1\n" "@end lisp") #define FUNC_NAME s_scm_integer_expt { long i2 = 0; SCM z_i2 = SCM_BOOL_F; int i2_is_big = 0; - SCM acc = SCM_MAKINUM (1L); + SCM acc = SCM_I_MAKINUM (1L); /* 0^0 == 1 according to R5RS */ - if (SCM_EQ_P (n, SCM_INUM0) || SCM_EQ_P (n, acc)) - return SCM_FALSEP (scm_zero_p(k)) ? n : acc; - else if (SCM_EQ_P (n, SCM_MAKINUM (-1L))) - return SCM_FALSEP (scm_even_p (k)) ? n : acc; + if (scm_is_eq (n, SCM_INUM0) || scm_is_eq (n, acc)) + return scm_is_false (scm_zero_p(k)) ? n : acc; + else if (scm_is_eq (n, SCM_I_MAKINUM (-1L))) + return scm_is_false (scm_even_p (k)) ? n : acc; - if (SCM_INUMP (k)) - i2 = SCM_INUM (k); + if (SCM_I_INUMP (k)) + i2 = SCM_I_INUM (k); else if (SCM_BIGP (k)) { z_i2 = scm_i_clonebig (k, 1); - mpz_init_set (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (k)); scm_remember_upto_here_1 (k); i2_is_big = 1; } - else if (SCM_REALP (k)) - { - double r = SCM_REAL_VALUE (k); - if (floor (r) != r) - SCM_WRONG_TYPE_ARG (2, k); - if ((r > SCM_MOST_POSITIVE_FIXNUM) || (r < SCM_MOST_NEGATIVE_FIXNUM)) - { - z_i2 = scm_i_mkbig (); - mpz_init_set_d (SCM_I_BIG_MPZ (z_i2), r); - i2_is_big = 1; - } - else - { - i2 = r; - } - } else SCM_WRONG_TYPE_ARG (2, k); @@ -1214,12 +1722,10 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, { if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == 0) { - mpz_clear (SCM_I_BIG_MPZ (z_i2)); return acc; } if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2), 1) == 0) { - mpz_clear (SCM_I_BIG_MPZ (z_i2)); return scm_product (acc, n); } if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2), 0)) @@ -1252,46 +1758,100 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, SCM_DEFINE (scm_ash, "ash", 2, 0, 0, (SCM n, SCM cnt), - "The function ash performs an arithmetic shift left by @var{cnt}\n" - "bits (or shift right, if @var{cnt} is negative). 'Arithmetic'\n" - "means, that the function does not guarantee to keep the bit\n" - "structure of @var{n}, but rather guarantees that the result\n" - "will always be rounded towards minus infinity. Therefore, the\n" - "results of ash and a corresponding bitwise shift will differ if\n" - "@var{n} is negative.\n" + "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" - "Formally, the function returns an integer equivalent to\n" - "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\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" + "\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" "\n" "@lisp\n" "(number->string (ash #b1 3) 2) @result{} \"1000\"\n" "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n" + "\n" + ";; -23 is bits ...11101001, -6 is bits ...111010\n" + "(ash -23 -2) @result{} -6\n" "@end lisp") #define FUNC_NAME s_scm_ash { long bits_to_shift; + bits_to_shift = scm_to_long (cnt); - SCM_VALIDATE_INUM (2, cnt); - - bits_to_shift = SCM_INUM (cnt); - - if (bits_to_shift < 0) + if (SCM_I_INUMP (n)) { - /* Shift right by abs(cnt) bits. This is realized as a division - by div:=2^abs(cnt). However, to guarantee the floor - rounding, negative values require some special treatment. - */ - SCM div = scm_integer_expt (SCM_MAKINUM (2), - SCM_MAKINUM (-bits_to_shift)); - if (SCM_FALSEP (scm_negative_p (n))) - return scm_quotient (n, div); - else - return scm_sum (SCM_MAKINUM (-1L), - scm_quotient (scm_sum (SCM_MAKINUM (1L), n), div)); + long nn = SCM_I_INUM (n); + + 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 + && ((unsigned long) + (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_long2big (nn); + mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), + bits_to_shift); + return result; + } + } + else + { + bits_to_shift = -bits_to_shift; + if (bits_to_shift >= SCM_LONG_BIT) + return (nn >= 0 ? SCM_I_MAKINUM (0) : SCM_I_MAKINUM(-1)); + else + return SCM_I_MAKINUM (SCM_SRS (nn, bits_to_shift)); + } + + } + else if (SCM_BIGP (n)) + { + SCM result; + + if (bits_to_shift == 0) + return n; + + 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; + } + 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); + } + } else - /* Shift left is done by multiplication with 2^CNT */ - return scm_product (n, scm_integer_expt (SCM_MAKINUM (2), cnt)); + { + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); + } } #undef FUNC_NAME @@ -1310,56 +1870,64 @@ SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0, "@end lisp") #define FUNC_NAME s_scm_bit_extract { - unsigned long int istart, iend; - SCM_VALIDATE_INUM_MIN_COPY (2, start,0, istart); - SCM_VALIDATE_INUM_MIN_COPY (3, end, 0, iend); + unsigned long int istart, iend, bits; + istart = scm_to_ulong (start); + iend = scm_to_ulong (end); SCM_ASSERT_RANGE (3, end, (iend >= istart)); - if (SCM_INUMP (n)) { - long int in = SCM_INUM (n); - unsigned long int bits = iend - istart; + /* how many bits to keep */ + bits = iend - istart; - if (in < 0 && bits >= SCM_I_FIXNUM_BIT) - { - /* Since we emulate two's complement encoded numbers, this special - * case requires us to produce a result that has more bits than can be - * stored in a fixnum. Thus, we fall back to the more general - * algorithm that is used for bignums. - */ - goto generalcase; - } + if (SCM_I_INUMP (n)) + { + long int in = SCM_I_INUM (n); - if (istart < SCM_I_FIXNUM_BIT) - { - in = in >> istart; - if (bits < SCM_I_FIXNUM_BIT) - return SCM_MAKINUM (in & ((1L << bits) - 1)); - else /* we know: in >= 0 */ - return SCM_MAKINUM (in); - } - else if (in < 0) - { - return SCM_MAKINUM (-1L & ((1L << bits) - 1)); - } - else - { - return SCM_MAKINUM (0); - } - } else if (SCM_BIGP (n)) { - generalcase: + /* 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". */ + in = SCM_SRS (in, min (istart, SCM_I_FIXNUM_BIT-1)); + + if (in < 0 && bits >= SCM_I_FIXNUM_BIT) + { + /* Since we emulate two's complement encoded numbers, this + * 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); + mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), + bits); + return result; + } + + /* mask down to requisite bits */ + bits = min (bits, SCM_I_FIXNUM_BIT); + return SCM_I_MAKINUM (in & ((1L << bits) - 1)); + } + else if (SCM_BIGP (n)) { - SCM num1 = SCM_MAKINUM (1L); - SCM num2 = SCM_MAKINUM (2L); - SCM bits = SCM_MAKINUM (iend - istart); - SCM mask = scm_difference (scm_integer_expt (num2, bits), num1); - return scm_logand (mask, scm_ash (n, SCM_MAKINUM (-istart))); + SCM result; + if (bits == 1) + { + result = SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n), istart)); + } + else + { + /* ENHANCE-ME: It'd be nice not to allocate a new bignum when + bits>= 4; } - return SCM_MAKINUM (c); + return SCM_I_MAKINUM (c); } else if (SCM_BIGP (n)) { @@ -1402,7 +1970,7 @@ SCM_DEFINE (scm_logcount, "logcount", 1, 0, 0, else count = mpz_hamdist (SCM_I_BIG_MPZ (n), z_negative_one); scm_remember_upto_here_1 (n); - return SCM_MAKINUM (count); + return SCM_I_MAKINUM (count); } else SCM_WRONG_TYPE_ARG (SCM_ARG1, n); @@ -1429,50 +1997,105 @@ SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0, "@end lisp") #define FUNC_NAME s_scm_integer_length { - if (SCM_INUMP (n)) { - unsigned long int c = 0; - unsigned int l = 4; - long int nn = SCM_INUM (n); - if (nn < 0) { - nn = -1 - nn; - }; - while (nn) { - c += 4; - l = scm_ilentab [15 & nn]; - nn >>= 4; - }; - return SCM_MAKINUM (c - 4 + l); - } else if (SCM_BIGP (n)) { - /* mpz_sizeinbase looks at the absolute value of negatives, whereas we - want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is - 1 too big, so check for that and adjust. */ - size_t size = mpz_sizeinbase (SCM_I_BIG_MPZ (n), 2); - if (mpz_sgn (SCM_I_BIG_MPZ (n)) < 0 - && mpz_scan0 (SCM_I_BIG_MPZ (n), /* no 0 bits above the lowest 1 */ - mpz_scan1 (SCM_I_BIG_MPZ (n), 0)) == ULONG_MAX) - size--; - scm_remember_upto_here_1 (n); - return SCM_MAKINUM (size); - } else { + if (SCM_I_INUMP (n)) + { + unsigned long int c = 0; + unsigned int l = 4; + long int nn = SCM_I_INUM (n); + if (nn < 0) + nn = -1 - nn; + while (nn) + { + c += 4; + l = scm_ilentab [15 & nn]; + nn >>= 4; + } + return SCM_I_MAKINUM (c - 4 + l); + } + else if (SCM_BIGP (n)) + { + /* mpz_sizeinbase looks at the absolute value of negatives, whereas we + want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is + 1 too big, so check for that and adjust. */ + size_t size = mpz_sizeinbase (SCM_I_BIG_MPZ (n), 2); + if (mpz_sgn (SCM_I_BIG_MPZ (n)) < 0 + && mpz_scan0 (SCM_I_BIG_MPZ (n), /* no 0 bits above the lowest 1 */ + mpz_scan1 (SCM_I_BIG_MPZ (n), 0)) == ULONG_MAX) + size--; + scm_remember_upto_here_1 (n); + return SCM_I_MAKINUM (size); + } + else SCM_WRONG_TYPE_ARG (SCM_ARG1, n); - } } #undef FUNC_NAME /*** NUMBERS -> STRINGS ***/ -int scm_dblprec; -static const double fx[] = -{ 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5, - 5e-6, 5e-7, 5e-8, 5e-9, 5e-10, - 5e-11, 5e-12, 5e-13, 5e-14, 5e-15, - 5e-16, 5e-17, 5e-18, 5e-19, 5e-20}; +#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 size_t -idbl2str (double f, char *a) +idbl2str (double f, char *a, int radix) { - int efmt, dpt, d, i, wp = scm_dblprec; - size_t ch = 0; - int exp = 0; + int efmt, dpt, d, i, wp; + double *fx; +#ifdef DBL_MIN_10_EXP + double f_cpy; + int exp_cpy; +#endif /* DBL_MIN_10_EXP */ + size_t ch = 0; + int exp = 0; + + if(radix < 2 || + radix > SCM_MAX_DBL_RADIX) + { + /* revert to existing behavior */ + radix = 10; + } + + wp = scm_dblprec[radix-2]; + fx = fx_per_radix[radix-2]; if (f == 0.0) { @@ -1482,7 +2105,6 @@ idbl2str (double f, char *a) if (sgn < 0.0) a[ch++] = '-'; #endif - goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */ } @@ -1508,10 +2130,15 @@ idbl2str (double f, char *a) #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from make-uniform-vector, from causing infinite loops. */ - while (f < 1.0) + /* just do the checking...if it passes, we do the conversion for our + radix again below */ + f_cpy = f; + exp_cpy = exp; + + while (f_cpy < 1.0) { - f *= 10.0; - if (exp-- < DBL_MIN_10_EXP) + f_cpy *= 10.0; + if (exp_cpy-- < DBL_MIN_10_EXP) { a[ch++] = '#'; a[ch++] = '.'; @@ -1519,10 +2146,10 @@ idbl2str (double f, char *a) return ch; } } - while (f > 10.0) + while (f_cpy > 10.0) { - f *= 0.10; - if (exp++ > DBL_MAX_10_EXP) + f_cpy *= 0.10; + if (exp_cpy++ > DBL_MAX_10_EXP) { a[ch++] = '#'; a[ch++] = '.'; @@ -1530,25 +2157,27 @@ idbl2str (double f, char *a) return ch; } } -#else +#endif + while (f < 1.0) { - f *= 10.0; + f *= radix; exp--; } - while (f > 10.0) + while (f > radix) { - f /= 10.0; + f /= radix; exp++; } -#endif - if (f + fx[wp] >= 10.0) + + if (f + fx[wp] >= radix) { f = 1.0; exp++; } zero: -#ifdef ENGNOT +#ifdef ENGNOT + /* adding 9999 makes this equivalent to abs(x) % 3 */ dpt = (exp + 9999) % 3; exp -= dpt++; efmt = 1; @@ -1575,15 +2204,15 @@ idbl2str (double f, char *a) { d = f; f -= d; - a[ch++] = d + '0'; + a[ch++] = number_chars[d]; if (f < fx[wp]) break; if (f + fx[wp] >= 1.0) { - a[ch - 1]++; + a[ch - 1] = number_chars[d+1]; break; } - f *= 10.0; + f *= radix; if (!(--dpt)) a[ch++] = '.'; } @@ -1618,10 +2247,10 @@ idbl2str (double f, char *a) exp = -exp; a[ch++] = '-'; } - for (i = 10; i <= exp; i *= 10); - for (i /= 10; i; i /= 10) + for (i = radix; i <= exp; i *= radix); + for (i /= radix; i; i /= radix) { - a[ch++] = exp / i + '0'; + a[ch++] = number_chars[exp / i]; exp %= i; } } @@ -1630,51 +2259,67 @@ idbl2str (double f, char *a) static size_t -iflo2str (SCM flt, char *str) +icmplx2str (double real, double imag, char *str, int radix) +{ + size_t i; + + i = idbl2str (real, str, radix); + if (imag != 0.0) + { + /* Don't output a '+' for negative numbers or for Inf and + NaN. They will provide their own sign. */ + if (0 <= imag && !xisinf (imag) && !xisnan (imag)) + str[i++] = '+'; + i += idbl2str (imag, &str[i], radix); + str[i++] = 'i'; + } + return i; +} + +static size_t +iflo2str (SCM flt, char *str, int radix) { size_t i; if (SCM_REALP (flt)) - i = idbl2str (SCM_REAL_VALUE (flt), str); + i = idbl2str (SCM_REAL_VALUE (flt), str, radix); else + i = icmplx2str (SCM_COMPLEX_REAL (flt), SCM_COMPLEX_IMAG (flt), + str, radix); + return i; +} + +/* convert a scm_t_intmax to a string (unterminated). returns the number of + characters in the result. + rad is output base + p is destination: worst case (base 2) is SCM_INTBUFLEN */ +size_t +scm_iint2str (scm_t_intmax num, int rad, char *p) +{ + if (num < 0) { - i = idbl2str (SCM_COMPLEX_REAL (flt), str); - if (SCM_COMPLEX_IMAG (flt) != 0.0) - { - double imag = SCM_COMPLEX_IMAG (flt); - /* Don't output a '+' for negative numbers or for Inf and - NaN. They will provide their own sign. */ - if (0 <= imag && !xisinf (imag) && !xisnan (imag)) - str[i++] = '+'; - i += idbl2str (imag, &str[i]); - str[i++] = 'i'; - } + *p++ = '-'; + return scm_iuint2str (-num, rad, p) + 1; } - return i; + else + return scm_iuint2str (num, rad, p); } -/* convert a long to a string (unterminated). returns the number of +/* convert a scm_t_intmax to a string (unterminated). returns the number of characters in the result. rad is output base p is destination: worst case (base 2) is SCM_INTBUFLEN */ size_t -scm_iint2str (long num, int rad, char *p) +scm_iuint2str (scm_t_uintmax num, int rad, char *p) { size_t j = 1; size_t i; - unsigned long n = (num < 0) ? -num : num; + scm_t_uintmax n = num; for (n /= rad; n > 0; n /= rad) j++; i = j; - if (num < 0) - { - *p++ = '-'; - j++; - n = -num; - } - else - n = num; + n = num; while (i--) { int d = n % rad; @@ -1685,7 +2330,6 @@ scm_iint2str (long num, int rad, char *p) return j; } - SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, (SCM n, SCM radix), "Return a string holding the external representation of the\n" @@ -1695,29 +2339,37 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, { int base; - if (SCM_UNBNDP (radix)) { + if (SCM_UNBNDP (radix)) base = 10; - } else { - SCM_VALIDATE_INUM (2, radix); - base = SCM_INUM (radix); - /* FIXME: ask if range limit was OK, and if so, document */ - SCM_ASSERT_RANGE (2, radix, (base >= 2) && (base <= 36)); - } + else + base = scm_to_signed_integer (radix, 2, 36); - if (SCM_INUMP (n)) { - char num_buf [SCM_INTBUFLEN]; - size_t length = scm_iint2str (SCM_INUM (n), base, num_buf); - return scm_mem2string (num_buf, length); - } else if (SCM_BIGP (n)) { - char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n)); - scm_remember_upto_here_1 (n); - return scm_take0str (str); - } else if (SCM_INEXACTP (n)) { - char num_buf [FLOBUFLEN]; - return scm_mem2string (num_buf, iflo2str (n, num_buf)); - } else { + if (SCM_I_INUMP (n)) + { + char num_buf [SCM_INTBUFLEN]; + size_t length = scm_iint2str (SCM_I_INUM (n), base, num_buf); + return scm_from_locale_stringn (num_buf, length); + } + else if (SCM_BIGP (n)) + { + char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n)); + scm_remember_upto_here_1 (n); + return scm_take_locale_string (str); + } + else if (SCM_FRACTIONP (n)) + { + scm_i_fraction_reduce (n); + return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n), radix), + scm_from_locale_string ("/"), + scm_number_to_string (SCM_FRACTION_DENOMINATOR (n), radix))); + } + else if (SCM_INEXACTP (n)) + { + char num_buf [FLOBUFLEN]; + return scm_from_locale_stringn (num_buf, iflo2str (n, num_buf, base)); + } + else SCM_WRONG_TYPE_ARG (1, n); - } } #undef FUNC_NAME @@ -1729,15 +2381,41 @@ int 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), port); + scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port); return !0; } +void +scm_i_print_double (double val, SCM port) +{ + char num_buf[FLOBUFLEN]; + scm_lfwrite (num_buf, idbl2str (val, num_buf, 10), port); +} + int scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) + +{ + char num_buf[FLOBUFLEN]; + scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port); + return !0; +} + +void +scm_i_print_complex (double real, double imag, SCM port) { char num_buf[FLOBUFLEN]; - scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port); + scm_lfwrite (num_buf, icmplx2str (real, imag, num_buf, 10), port); +} + +int +scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) +{ + SCM str; + scm_i_fraction_reduce (sexp); + str = scm_number_to_string (sexp, SCM_UNDEFINED); + scm_lfwrite (scm_i_string_chars (str), scm_i_string_length (str), port); + scm_remember_upto_here_1 (str); return !0; } @@ -1783,7 +2461,10 @@ enum t_exactness {NO_EXACTNESS, INEXACT, EXACT}; /* R5RS, section 7.1.1, lexical structure of numbers: . */ /* In non ASCII-style encodings the following macro might not work. */ -#define XDIGIT2UINT(d) (isdigit (d) ? (d) - '0' : tolower (d) - 'a' + 10) +#define XDIGIT2UINT(d) \ + (isdigit ((int) (unsigned char) d) \ + ? (d) - '0' \ + : tolower ((int) (unsigned char) d) - 'a' + 10) static SCM mem2uinteger (const char* mem, size_t len, unsigned int *p_idx, @@ -1801,18 +2482,18 @@ mem2uinteger (const char* mem, size_t len, unsigned int *p_idx, return SCM_BOOL_F; c = mem[idx]; - if (!isxdigit (c)) + if (!isxdigit ((int) (unsigned char) c)) return SCM_BOOL_F; digit_value = XDIGIT2UINT (c); if (digit_value >= radix) return SCM_BOOL_F; idx++; - result = SCM_MAKINUM (digit_value); + result = SCM_I_MAKINUM (digit_value); while (idx != len) { char c = mem[idx]; - if (isxdigit (c)) + if (isxdigit ((int) (unsigned char) c)) { if (hash_seen) break; @@ -1831,9 +2512,9 @@ mem2uinteger (const char* mem, size_t len, unsigned int *p_idx, idx++; if (SCM_MOST_POSITIVE_FIXNUM / radix < shift) { - result = scm_product (result, SCM_MAKINUM (shift)); + result = scm_product (result, SCM_I_MAKINUM (shift)); if (add > 0) - result = scm_sum (result, SCM_MAKINUM (add)); + result = scm_sum (result, SCM_I_MAKINUM (add)); shift = radix; add = digit_value; @@ -1846,9 +2527,9 @@ mem2uinteger (const char* mem, size_t len, unsigned int *p_idx, }; if (shift > 1) - result = scm_product (result, SCM_MAKINUM (shift)); + result = scm_product (result, SCM_I_MAKINUM (shift)); if (add > 0) - result = scm_sum (result, SCM_MAKINUM (add)); + result = scm_sum (result, SCM_I_MAKINUM (add)); *p_idx = idx; if (hash_seen) @@ -1883,13 +2564,13 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, scm_t_bits shift = 1; scm_t_bits add = 0; unsigned int digit_value; - SCM big_shift = SCM_MAKINUM (1); + SCM big_shift = SCM_I_MAKINUM (1); idx++; while (idx != len) { char c = mem[idx]; - if (isdigit (c)) + if (isdigit ((int) (unsigned char) c)) { if (x == INEXACT) return SCM_BOOL_F; @@ -1907,10 +2588,10 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, idx++; if (SCM_MOST_POSITIVE_FIXNUM / 10 < shift) { - big_shift = scm_product (big_shift, SCM_MAKINUM (shift)); - result = scm_product (result, SCM_MAKINUM (shift)); + big_shift = scm_product (big_shift, SCM_I_MAKINUM (shift)); + result = scm_product (result, SCM_I_MAKINUM (shift)); if (add > 0) - result = scm_sum (result, SCM_MAKINUM (add)); + result = scm_sum (result, SCM_I_MAKINUM (add)); shift = 10; add = digit_value; @@ -1924,9 +2605,9 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, if (add > 0) { - big_shift = scm_product (big_shift, SCM_MAKINUM (shift)); - result = scm_product (result, SCM_MAKINUM (shift)); - result = scm_sum (result, SCM_MAKINUM (add)); + big_shift = scm_product (big_shift, SCM_I_MAKINUM (shift)); + result = scm_product (result, SCM_I_MAKINUM (shift)); + result = scm_sum (result, SCM_I_MAKINUM (add)); } result = scm_divide (result, big_shift); @@ -1970,7 +2651,7 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, else sign = 1; - if (!isdigit (c)) + if (!isdigit ((int) (unsigned char) c)) return SCM_BOOL_F; idx++; @@ -1978,7 +2659,7 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, while (idx != len) { char c = mem[idx]; - if (isdigit (c)) + if (isdigit ((int) (unsigned char) c)) { idx++; if (exponent <= SCM_MAXEXP) @@ -1991,16 +2672,16 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, if (exponent > SCM_MAXEXP) { size_t exp_len = idx - start; - SCM exp_string = scm_mem2string (&mem[start], exp_len); + SCM exp_string = scm_from_locale_stringn (&mem[start], exp_len); SCM exp_num = scm_string_to_number (exp_string, SCM_UNDEFINED); scm_out_of_range ("string->number", exp_num); } - e = scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent)); + e = scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent)); if (sign == 1) result = scm_product (result, e); else - result = scm_divide (result, e); + result = scm_divide2real (result, e); /* We've seen an exponent, thus the value is implicitly inexact. */ x = INEXACT; @@ -2042,8 +2723,8 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, { enum t_exactness x = EXACT; - /* Cobble up the fraction. We might want to set the NaN's - mantissa from it. */ + /* Cobble up the fractional part. We might want to set the + NaN's mantissa from it. */ idx += 4; mem2uinteger (mem, len, &idx, 10, &x); *p_idx = idx; @@ -2056,10 +2737,10 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, return SCM_BOOL_F; else if (idx + 1 == len) return SCM_BOOL_F; - else if (!isdigit (mem[idx + 1])) + else if (!isdigit ((int) (unsigned char) mem[idx + 1])) return SCM_BOOL_F; else - result = mem2decimal_from_point (SCM_MAKINUM (0), mem, len, + result = mem2decimal_from_point (SCM_I_MAKINUM (0), mem, len, p_idx, p_exactness); } else @@ -2068,7 +2749,7 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, SCM uinteger; uinteger = mem2uinteger (mem, len, &idx, radix, &x); - if (SCM_FALSEP (uinteger)) + if (scm_is_false (uinteger)) return SCM_BOOL_F; if (idx == len) @@ -2080,15 +2761,16 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, idx++; divisor = mem2uinteger (mem, len, &idx, radix, &x); - if (SCM_FALSEP (divisor)) + if (scm_is_false (divisor)) return SCM_BOOL_F; - result = scm_divide (uinteger, divisor); + /* both are int/big here, I assume */ + result = scm_i_make_ratio (uinteger, divisor); } else if (radix == 10) { result = mem2decimal_from_point (uinteger, mem, len, &idx, &x); - if (SCM_FALSEP (result)) + if (scm_is_false (result)) return SCM_BOOL_F; } else @@ -2102,8 +2784,8 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, /* When returning an inexact zero, make sure it is represented as a floating point value so that we can change its sign. */ - if (SCM_EQ_P (result, SCM_MAKINUM(0)) && *p_exactness == INEXACT) - result = scm_make_real (0.0); + if (scm_is_eq (result, SCM_I_MAKINUM(0)) && *p_exactness == INEXACT) + result = scm_from_double (0.0); return result; } @@ -2138,7 +2820,7 @@ mem2complex (const char* mem, size_t len, unsigned int idx, return SCM_BOOL_F; ureal = mem2ureal (mem, len, &idx, radix, p_exactness); - if (SCM_FALSEP (ureal)) + if (scm_is_false (ureal)) { /* input must be either +i or -i */ @@ -2151,14 +2833,14 @@ mem2complex (const char* mem, size_t len, unsigned int idx, if (idx != len) return SCM_BOOL_F; - return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign)); + return scm_make_rectangular (SCM_I_MAKINUM (0), SCM_I_MAKINUM (sign)); } else return SCM_BOOL_F; } else { - if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal))) + if (sign == -1 && scm_is_false (scm_nan_p (ureal))) ureal = scm_difference (ureal, SCM_UNDEFINED); if (idx == len) @@ -2175,7 +2857,7 @@ mem2complex (const char* mem, size_t len, unsigned int idx, return SCM_BOOL_F; if (idx != len) return SCM_BOOL_F; - return scm_make_rectangular (SCM_MAKINUM (0), ureal); + return scm_make_rectangular (SCM_I_MAKINUM (0), ureal); case '@': /* polar input: @. */ @@ -2204,12 +2886,12 @@ mem2complex (const char* mem, size_t len, unsigned int idx, sign = 1; angle = mem2ureal (mem, len, &idx, radix, p_exactness); - if (SCM_FALSEP (angle)) + if (scm_is_false (angle)) return SCM_BOOL_F; if (idx != len) return SCM_BOOL_F; - if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal))) + if (sign == -1 && scm_is_false (scm_nan_p (ureal))) angle = scm_difference (angle, SCM_UNDEFINED); result = scm_make_polar (ureal, angle); @@ -2227,9 +2909,9 @@ mem2complex (const char* mem, size_t len, unsigned int idx, int sign = (c == '+') ? 1 : -1; SCM imag = mem2ureal (mem, len, &idx, radix, p_exactness); - if (SCM_FALSEP (imag)) - imag = SCM_MAKINUM (sign); - else if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal))) + if (scm_is_false (imag)) + imag = SCM_I_MAKINUM (sign); + else if (sign == -1 && scm_is_false (scm_nan_p (ureal))) imag = scm_difference (imag, SCM_UNDEFINED); if (idx == len) @@ -2310,14 +2992,13 @@ scm_i_mem2number (const char* mem, size_t len, unsigned int default_radix) else result = mem2complex (mem, len, idx, (unsigned int) radix, &implicit_x); - if (SCM_FALSEP (result)) + if (scm_is_false (result)) return SCM_BOOL_F; switch (forced_x) { case EXACT: if (SCM_INEXACTP (result)) - /* FIXME: This may change the value. */ return scm_inexact_to_exact (result); else return result; @@ -2354,120 +3035,124 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, #define FUNC_NAME s_scm_string_to_number { SCM answer; - int base; + unsigned int base; SCM_VALIDATE_STRING (1, string); - SCM_VALIDATE_INUM_MIN_DEF_COPY (2, radix,2,10, base); - answer = scm_i_mem2number (SCM_STRING_CHARS (string), - SCM_STRING_LENGTH (string), - base); - return scm_return_first (answer, string); -} -#undef FUNC_NAME + if (SCM_UNBNDP (radix)) + base = 10; + else + base = scm_to_unsigned_integer (radix, 2, INT_MAX); -/*** END strs->nums ***/ - - -SCM -scm_make_real (double x) -{ - SCM z = scm_double_cell (scm_tc16_real, 0, 0, 0); - - SCM_REAL_VALUE (z) = x; - return z; + answer = scm_i_mem2number (scm_i_string_chars (string), + scm_i_string_length (string), + base); + scm_remember_upto_here_1 (string); + return answer; } +#undef FUNC_NAME -SCM -scm_make_complex (double x, double y) -{ - if (y == 0.0) { - return scm_make_real (x); - } else { - SCM z; - SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (2*sizeof (double), - "complex")); - SCM_COMPLEX_REAL (z) = x; - SCM_COMPLEX_IMAG (z) = y; - return z; - } -} +/*** END strs->nums ***/ SCM scm_bigequal (SCM x, SCM y) { - int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (x)); + int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); scm_remember_upto_here_2 (x, y); - return SCM_BOOL (0 == result); + return scm_from_bool (0 == result); } SCM scm_real_equalp (SCM x, SCM y) { - return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y)); + return scm_from_bool (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y)); } SCM scm_complex_equalp (SCM x, SCM y) { - return SCM_BOOL (SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y) + return scm_from_bool (SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y) && SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y)); } +SCM +scm_i_fraction_equalp (SCM x, SCM y) +{ + scm_i_fraction_reduce (x); + scm_i_fraction_reduce (y); + if (scm_is_false (scm_equal_p (SCM_FRACTION_NUMERATOR (x), + SCM_FRACTION_NUMERATOR (y))) + || scm_is_false (scm_equal_p (SCM_FRACTION_DENOMINATOR (x), + SCM_FRACTION_DENOMINATOR (y)))) + return SCM_BOOL_F; + else + return SCM_BOOL_T; +} -SCM_REGISTER_PROC (s_number_p, "number?", 1, 0, 0, scm_number_p); -/* "Return @code{#t} if @var{x} is a number, @code{#f}\n" - * "else. Note that the sets of complex, real, rational and\n" - * "integer values form subsets of the set of numbers, i. e. the\n" - * "predicate will be fulfilled for any number." - */ -SCM_DEFINE (scm_number_p, "complex?", 1, 0, 0, +SCM_DEFINE (scm_number_p, "number?", 1, 0, 0, + (SCM x), + "Return @code{#t} if @var{x} is a number, @code{#f}\n" + "otherwise.") +#define FUNC_NAME s_scm_number_p +{ + return scm_from_bool (SCM_NUMBERP (x)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_complex_p, "complex?", 1, 0, 0, (SCM x), "Return @code{#t} if @var{x} is a complex number, @code{#f}\n" "otherwise. Note that the sets of real, rational and integer\n" "values form subsets of the set of complex numbers, i. e. the\n" "predicate will also be fulfilled if @var{x} is a real,\n" "rational or integer number.") -#define FUNC_NAME s_scm_number_p +#define FUNC_NAME s_scm_complex_p { - return SCM_BOOL (SCM_NUMBERP (x)); + /* all numbers are complex. */ + return scm_number_p (x); } #undef FUNC_NAME +SCM_DEFINE (scm_real_p, "real?", 1, 0, 0, + (SCM x), + "Return @code{#t} if @var{x} is a real number, @code{#f}\n" + "otherwise. Note that the set of integer values forms a subset of\n" + "the set of real numbers, i. e. the predicate will also be\n" + "fulfilled if @var{x} is an integer number.") +#define FUNC_NAME s_scm_real_p +{ + /* we can't represent irrational numbers. */ + return scm_rational_p (x); +} +#undef FUNC_NAME -SCM_REGISTER_PROC (s_real_p, "real?", 1, 0, 0, scm_real_p); -/* "Return @code{#t} if @var{x} is a real number, @code{#f} else.\n" - * "Note that the sets of integer and rational values form a subset\n" - * "of the set of real numbers, i. e. the predicate will also\n" - * "be fulfilled if @var{x} is an integer or a rational number." - */ -SCM_DEFINE (scm_real_p, "rational?", 1, 0, 0, +SCM_DEFINE (scm_rational_p, "rational?", 1, 0, 0, (SCM x), "Return @code{#t} if @var{x} is a rational number, @code{#f}\n" "otherwise. Note that the set of integer values forms a subset of\n" "the set of rational numbers, i. e. the predicate will also be\n" - "fulfilled if @var{x} is an integer number. Real numbers\n" - "will also satisfy this predicate, because of their limited\n" - "precision.") -#define FUNC_NAME s_scm_real_p + "fulfilled if @var{x} is an integer number.") +#define FUNC_NAME s_scm_rational_p { - if (SCM_INUMP (x)) { + if (SCM_I_INUMP (x)) return SCM_BOOL_T; - } else if (SCM_IMP (x)) { + else if (SCM_IMP (x)) return SCM_BOOL_F; - } else if (SCM_REALP (x)) { + else if (SCM_BIGP (x)) return SCM_BOOL_T; - } else if (SCM_BIGP (x)) { + else if (SCM_FRACTIONP (x)) return SCM_BOOL_T; - } else { + else if (SCM_REALP (x)) + /* due to their limited precision, all floating point numbers are + rational as well. */ + return SCM_BOOL_T; + else return SCM_BOOL_F; - } } #undef FUNC_NAME - SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0, (SCM x), "Return @code{#t} if @var{x} is an integer number, @code{#f}\n" @@ -2475,7 +3160,7 @@ SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0, #define FUNC_NAME s_scm_integer_p { double r; - if (SCM_INUMP (x)) + if (SCM_I_INUMP (x)) return SCM_BOOL_T; if (SCM_IMP (x)) return SCM_BOOL_F; @@ -2486,6 +3171,7 @@ SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0, if (SCM_COMPLEXP (x)) return SCM_BOOL_F; r = SCM_REAL_VALUE (x); + /* +/-inf passes r==floor(r), making those #t */ if (r == floor (r)) return SCM_BOOL_T; return SCM_BOOL_F; @@ -2499,7 +3185,11 @@ SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0, "else.") #define FUNC_NAME s_scm_inexact_p { - return SCM_BOOL (SCM_INEXACTP (x)); + if (SCM_INEXACTP (x)) + return SCM_BOOL_T; + if (SCM_NUMBERP (x)) + return SCM_BOOL_F; + SCM_WRONG_TYPE_ARG (1, x); } #undef FUNC_NAME @@ -2509,143 +3199,329 @@ SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p, g_eq_p); SCM scm_num_eq_p (SCM x, SCM y) { - if (SCM_INUMP (x)) { - long xx = SCM_INUM (x); - if (SCM_INUMP (y)) { - long yy = SCM_INUM (y); - return SCM_BOOL (xx == yy); - } else if (SCM_BIGP (y)) { - return SCM_BOOL_F; - } else if (SCM_REALP (y)) { - return SCM_BOOL ((double) xx == SCM_REAL_VALUE (y)); - } else if (SCM_COMPLEXP (y)) { - return SCM_BOOL (((double) xx == SCM_COMPLEX_REAL (y)) - && (0.0 == SCM_COMPLEX_IMAG (y))); - } else { - SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); - } - } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) { - return SCM_BOOL_F; - } else if (SCM_BIGP (y)) { - int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_2 (x, y); - return SCM_BOOL (0 == cmp); - } else if (SCM_REALP (y)) { - int cmp; - if (xisnan (SCM_REAL_VALUE (y))) return SCM_BOOL_F; - cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y)); - scm_remember_upto_here_1 (x); - return SCM_BOOL (0 == cmp); - } else if (SCM_COMPLEXP (y)) { - int cmp; - if (0.0 != SCM_COMPLEX_IMAG (y)) return SCM_BOOL_F; - if (xisnan (SCM_COMPLEX_REAL (y))) return SCM_BOOL_F; - cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_COMPLEX_REAL (y)); - scm_remember_upto_here_1 (x); - return SCM_BOOL (0 == cmp); - } else { - SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); - } - } else if (SCM_REALP (x)) { - if (SCM_INUMP (y)) { - return SCM_BOOL (SCM_REAL_VALUE (x) == (double) SCM_INUM (y)); - } else if (SCM_BIGP (y)) { - int cmp; - if (xisnan (SCM_REAL_VALUE (x))) return SCM_BOOL_F; - cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x)); - scm_remember_upto_here_1 (y); - return SCM_BOOL (0 == cmp); - } else if (SCM_REALP (y)) { - return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y)); - } else if (SCM_COMPLEXP (y)) { - return SCM_BOOL ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y)) - && (0.0 == SCM_COMPLEX_IMAG (y))); - } else { - SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); - } - } else if (SCM_COMPLEXP (x)) { - if (SCM_INUMP (y)) { - return SCM_BOOL ((SCM_COMPLEX_REAL (x) == (double) SCM_INUM (y)) - && (SCM_COMPLEX_IMAG (x) == 0.0)); - } else if (SCM_BIGP (y)) { - int cmp; - if (0.0 != SCM_COMPLEX_IMAG (x)) return SCM_BOOL_F; - if (xisnan (SCM_COMPLEX_REAL (x))) return SCM_BOOL_F; - cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_COMPLEX_REAL (x)); - scm_remember_upto_here_1 (y); - return SCM_BOOL (0 == cmp); - } else if (SCM_REALP (y)) { - return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y)) - && (SCM_COMPLEX_IMAG (x) == 0.0)); - } else if (SCM_COMPLEXP (y)) { - return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y)) - && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y))); - } else { - SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); + again: + if (SCM_I_INUMP (x)) + { + long xx = SCM_I_INUM (x); + if (SCM_I_INUMP (y)) + { + long yy = SCM_I_INUM (y); + return scm_from_bool (xx == yy); + } + else if (SCM_BIGP (y)) + return SCM_BOOL_F; + else if (SCM_REALP (y)) + { + /* On a 32-bit system an inum fits a double, we can cast the inum + 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 + compare with plain xx. + + 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. */ + + double yy = SCM_REAL_VALUE (y); + return SCM_BOOL ((double) xx == yy + && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1 + || xx == (long) yy)); + } + else if (SCM_COMPLEXP (y)) + return scm_from_bool (((double) xx == SCM_COMPLEX_REAL (y)) + && (0.0 == SCM_COMPLEX_IMAG (y))); + else if (SCM_FRACTIONP (y)) + return SCM_BOOL_F; + else + SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); } - } else { - SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p); - } -} - - -SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p); -/* "Return @code{#t} if the list of parameters is monotonically\n" - * "increasing." - */ -SCM -scm_less_p (SCM x, SCM y) -{ - if (SCM_INUMP (x)) { - long xx = SCM_INUM (x); - if (SCM_INUMP (y)) { - long yy = SCM_INUM (y); - return SCM_BOOL (xx < yy); - } else if (SCM_BIGP (y)) { - int sgn = mpz_sgn (SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_1 (y); - return SCM_BOOL (sgn > 0); - } else if (SCM_REALP (y)) { - return SCM_BOOL ((double) xx < SCM_REAL_VALUE (y)); - } else { - SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); - } - } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) { - int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); - scm_remember_upto_here_1 (x); - return SCM_BOOL (sgn < 0); - } else if (SCM_BIGP (y)) { - int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_2 (x, y); - return SCM_BOOL (cmp < 0); - } else if (SCM_REALP (y)) { - int cmp; - if (xisnan (SCM_REAL_VALUE (y))) return SCM_BOOL_F; - cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y)); - scm_remember_upto_here_1 (x); - return SCM_BOOL (cmp < 0); - } else { - SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); - } - } else if (SCM_REALP (x)) { - if (SCM_INUMP (y)) { - return SCM_BOOL (SCM_REAL_VALUE (x) < (double) SCM_INUM (y)); - } else if (SCM_BIGP (y)) { - int cmp; - if (xisnan (SCM_REAL_VALUE (x))) return SCM_BOOL_F; - cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x)); - scm_remember_upto_here_1 (y); - return SCM_BOOL (cmp > 0); - } else if (SCM_REALP (y)) { - return SCM_BOOL (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y)); - } else { - SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); + else if (SCM_BIGP (x)) + { + if (SCM_I_INUMP (y)) + return SCM_BOOL_F; + else if (SCM_BIGP (y)) + { + int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + return scm_from_bool (0 == cmp); + } + else if (SCM_REALP (y)) + { + int cmp; + if (xisnan (SCM_REAL_VALUE (y))) + return SCM_BOOL_F; + cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y)); + scm_remember_upto_here_1 (x); + return scm_from_bool (0 == cmp); + } + else if (SCM_COMPLEXP (y)) + { + int cmp; + if (0.0 != SCM_COMPLEX_IMAG (y)) + return SCM_BOOL_F; + if (xisnan (SCM_COMPLEX_REAL (y))) + return SCM_BOOL_F; + cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_COMPLEX_REAL (y)); + scm_remember_upto_here_1 (x); + return scm_from_bool (0 == cmp); + } + else if (SCM_FRACTIONP (y)) + return SCM_BOOL_F; + else + SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); } - } else { + else if (SCM_REALP (x)) + { + double xx = SCM_REAL_VALUE (x); + if (SCM_I_INUMP (y)) + { + /* see comments with inum/real above */ + long yy = SCM_I_INUM (y); + return SCM_BOOL (xx == (double) yy + && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1 + || (long) xx == yy)); + } + else if (SCM_BIGP (y)) + { + int cmp; + if (xisnan (SCM_REAL_VALUE (x))) + return SCM_BOOL_F; + cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x)); + 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)); + else if (SCM_COMPLEXP (y)) + return scm_from_bool ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y)) + && (0.0 == SCM_COMPLEX_IMAG (y))); + else if (SCM_FRACTIONP (y)) + { + double xx = SCM_REAL_VALUE (x); + if (xisnan (xx)) + return SCM_BOOL_F; + if (xisinf (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_eq_p, x, y, SCM_ARGn, s_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)); + else if (SCM_BIGP (y)) + { + int cmp; + if (0.0 != SCM_COMPLEX_IMAG (x)) + return SCM_BOOL_F; + if (xisnan (SCM_COMPLEX_REAL (x))) + return SCM_BOOL_F; + cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_COMPLEX_REAL (x)); + scm_remember_upto_here_1 (y); + return scm_from_bool (0 == cmp); + } + else if (SCM_REALP (y)) + return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y)) + && (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))); + else if (SCM_FRACTIONP (y)) + { + double xx; + if (SCM_COMPLEX_IMAG (x) != 0.0) + return SCM_BOOL_F; + xx = SCM_COMPLEX_REAL (x); + if (xisnan (xx)) + return SCM_BOOL_F; + if (xisinf (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_eq_p, x, y, SCM_ARGn, s_eq_p); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_I_INUMP (y)) + return SCM_BOOL_F; + else if (SCM_BIGP (y)) + return SCM_BOOL_F; + else if (SCM_REALP (y)) + { + double yy = SCM_REAL_VALUE (y); + if (xisnan (yy)) + return SCM_BOOL_F; + if (xisinf (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_COMPLEXP (y)) + { + double yy; + if (SCM_COMPLEX_IMAG (y) != 0.0) + return SCM_BOOL_F; + yy = SCM_COMPLEX_REAL (y); + if (xisnan (yy)) + return SCM_BOOL_F; + if (xisinf (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_eq_p, x, y, SCM_ARGn, s_eq_p); + } + else + SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p); +} + + +/* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications + done are good for inums, but for bignums an answer can almost always be + had by just examining a few high bits of the operands, as done by GMP in + mpq_cmp. flonum/frac compares likewise, but with the slight complication + of the float exponent to take into account. */ + +SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p); +/* "Return @code{#t} if the list of parameters is monotonically\n" + * "increasing." + */ +SCM +scm_less_p (SCM x, SCM y) +{ + again: + if (SCM_I_INUMP (x)) + { + long xx = SCM_I_INUM (x); + if (SCM_I_INUMP (y)) + { + long yy = SCM_I_INUM (y); + return scm_from_bool (xx < yy); + } + else if (SCM_BIGP (y)) + { + int sgn = mpz_sgn (SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_1 (y); + return scm_from_bool (sgn > 0); + } + else if (SCM_REALP (y)) + return scm_from_bool ((double) xx < SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + { + /* "x < a/b" becomes "x*b < a" */ + int_frac: + x = scm_product (x, SCM_FRACTION_DENOMINATOR (y)); + y = SCM_FRACTION_NUMERATOR (y); + goto again; + } + else + SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); + } + else if (SCM_BIGP (x)) + { + if (SCM_I_INUMP (y)) + { + int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); + scm_remember_upto_here_1 (x); + return scm_from_bool (sgn < 0); + } + else if (SCM_BIGP (y)) + { + int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + return scm_from_bool (cmp < 0); + } + else if (SCM_REALP (y)) + { + int cmp; + if (xisnan (SCM_REAL_VALUE (y))) + return SCM_BOOL_F; + cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y)); + scm_remember_upto_here_1 (x); + return scm_from_bool (cmp < 0); + } + else if (SCM_FRACTIONP (y)) + goto int_frac; + else + SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_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)); + else if (SCM_BIGP (y)) + { + int cmp; + if (xisnan (SCM_REAL_VALUE (x))) + return SCM_BOOL_F; + cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x)); + scm_remember_upto_here_1 (y); + return scm_from_bool (cmp > 0); + } + else if (SCM_REALP (y)) + return scm_from_bool (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + { + double xx = SCM_REAL_VALUE (x); + if (xisnan (xx)) + return SCM_BOOL_F; + if (xisinf (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_less_p, x, y, SCM_ARGn, s_less_p); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_I_INUMP (y) || SCM_BIGP (y)) + { + /* "a/b < y" becomes "a < y*b" */ + y = scm_product (y, SCM_FRACTION_DENOMINATOR (x)); + x = SCM_FRACTION_NUMERATOR (x); + goto again; + } + else if (SCM_REALP (y)) + { + double yy = SCM_REAL_VALUE (y); + if (xisnan (yy)) + return SCM_BOOL_F; + if (xisinf (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)) + { + /* "a/b < c/d" becomes "a*d < c*b" */ + SCM new_x = scm_product (SCM_FRACTION_NUMERATOR (x), + SCM_FRACTION_DENOMINATOR (y)); + SCM new_y = scm_product (SCM_FRACTION_NUMERATOR (y), + SCM_FRACTION_DENOMINATOR (x)); + x = new_x; + y = new_y; + goto again; + } + else + SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); + } + else SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p); - } } @@ -2679,10 +3555,10 @@ scm_leq_p (SCM x, SCM y) SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG1, FUNC_NAME); else if (!SCM_NUMBERP (y)) SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG2, FUNC_NAME); - else if (SCM_NFALSEP (scm_nan_p (x)) || SCM_NFALSEP (scm_nan_p (y))) + else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y))) return SCM_BOOL_F; else - return SCM_BOOL_NOT (scm_less_p (y, x)); + return scm_not (scm_less_p (y, x)); } #undef FUNC_NAME @@ -2699,10 +3575,10 @@ scm_geq_p (SCM x, SCM y) SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG1, FUNC_NAME); else if (!SCM_NUMBERP (y)) SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG2, FUNC_NAME); - else if (SCM_NFALSEP (scm_nan_p (x)) || SCM_NFALSEP (scm_nan_p (y))) + else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y))) return SCM_BOOL_F; else - return SCM_BOOL_NOT (scm_less_p (x, y)); + return scm_not (scm_less_p (x, y)); } #undef FUNC_NAME @@ -2714,18 +3590,19 @@ SCM_GPROC (s_zero_p, "zero?", 1, 0, 0, scm_zero_p, g_zero_p); SCM scm_zero_p (SCM z) { - if (SCM_INUMP (z)) { - return SCM_BOOL (SCM_EQ_P (z, SCM_INUM0)); - } else if (SCM_BIGP (z)) { + if (SCM_I_INUMP (z)) + return scm_from_bool (scm_is_eq (z, SCM_INUM0)); + else if (SCM_BIGP (z)) return SCM_BOOL_F; - } else if (SCM_REALP (z)) { - return SCM_BOOL (SCM_REAL_VALUE (z) == 0.0); - } else if (SCM_COMPLEXP (z)) { - return SCM_BOOL (SCM_COMPLEX_REAL (z) == 0.0 + else if (SCM_REALP (z)) + return scm_from_bool (SCM_REAL_VALUE (z) == 0.0); + else if (SCM_COMPLEXP (z)) + return scm_from_bool (SCM_COMPLEX_REAL (z) == 0.0 && SCM_COMPLEX_IMAG (z) == 0.0); - } else { + else if (SCM_FRACTIONP (z)) + return SCM_BOOL_F; + else SCM_WTA_DISPATCH_1 (g_zero_p, z, SCM_ARG1, s_zero_p); - } } @@ -2736,17 +3613,20 @@ SCM_GPROC (s_positive_p, "positive?", 1, 0, 0, scm_positive_p, g_positive_p); SCM scm_positive_p (SCM x) { - if (SCM_INUMP (x)) { - return SCM_BOOL (SCM_INUM (x) > 0); - } else if (SCM_BIGP (x)) { - int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); - scm_remember_upto_here_1 (x); - return SCM_BOOL (sgn > 0); - } else if (SCM_REALP (x)) { - return SCM_BOOL(SCM_REAL_VALUE (x) > 0.0); - } else { + if (SCM_I_INUMP (x)) + return scm_from_bool (SCM_I_INUM (x) > 0); + else if (SCM_BIGP (x)) + { + int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); + scm_remember_upto_here_1 (x); + return scm_from_bool (sgn > 0); + } + else if (SCM_REALP (x)) + return scm_from_bool(SCM_REAL_VALUE (x) > 0.0); + else if (SCM_FRACTIONP (x)) + return scm_positive_p (SCM_FRACTION_NUMERATOR (x)); + else SCM_WTA_DISPATCH_1 (g_positive_p, x, SCM_ARG1, s_positive_p); - } } @@ -2757,98 +3637,158 @@ SCM_GPROC (s_negative_p, "negative?", 1, 0, 0, scm_negative_p, g_negative_p); SCM scm_negative_p (SCM x) { - if (SCM_INUMP (x)) { - return SCM_BOOL (SCM_INUM (x) < 0); - } else if (SCM_BIGP (x)) { - int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); - scm_remember_upto_here_1 (x); - return SCM_BOOL (sgn < 0); - } else if (SCM_REALP (x)) { - return SCM_BOOL(SCM_REAL_VALUE (x) < 0.0); - } else { + if (SCM_I_INUMP (x)) + return scm_from_bool (SCM_I_INUM (x) < 0); + else if (SCM_BIGP (x)) + { + int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); + scm_remember_upto_here_1 (x); + return scm_from_bool (sgn < 0); + } + else if (SCM_REALP (x)) + return scm_from_bool(SCM_REAL_VALUE (x) < 0.0); + else if (SCM_FRACTIONP (x)) + return scm_negative_p (SCM_FRACTION_NUMERATOR (x)); + else SCM_WTA_DISPATCH_1 (g_negative_p, x, SCM_ARG1, s_negative_p); - } } +/* scm_min and scm_max return an inexact when either argument is inexact, as + required by r5rs. On that basis, for exact/inexact combinations the + exact is converted to inexact to compare and possibly return. This is + unlike scm_less_p above which takes some trouble to preserve all bits in + its test, such trouble is not required for min and max. */ + SCM_GPROC1 (s_max, "max", scm_tc7_asubr, scm_max, g_max); /* "Return the maximum of all parameter values." */ SCM scm_max (SCM x, SCM y) { - if (SCM_UNBNDP (y)) { - if (SCM_UNBNDP (x)) { - SCM_WTA_DISPATCH_0 (g_max, s_max); - } else if (SCM_NUMBERP (x)) { - return x; - } else { - SCM_WTA_DISPATCH_1 (g_max, x, SCM_ARG1, s_max); + if (SCM_UNBNDP (y)) + { + if (SCM_UNBNDP (x)) + 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); } - } - if (SCM_INUMP (x)) { - long xx = SCM_INUM (x); - if (SCM_INUMP (y)) { - long yy = SCM_INUM (y); - return (xx < yy) ? y : x; - } else if (SCM_BIGP (y)) { - int sgn = mpz_sgn (SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_1 (y); - return (sgn < 0) ? x : y; - } else if (SCM_REALP (y)) { - double z = xx; - /* if y==NaN then ">" is false and we return NaN */ - return (z > SCM_REAL_VALUE (y)) ? scm_make_real (z) : y; - } else { - SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); - } - } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) { - int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); - scm_remember_upto_here_1 (x); - return (sgn < 0) ? y : x; - } else if (SCM_BIGP (y)) { - int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_2 (x, y); - return (cmp > 0) ? x : y; - } else if (SCM_REALP (y)) { - double yy = SCM_REAL_VALUE (y); - int cmp; - if (xisnan (yy)) - return y; - cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy); - scm_remember_upto_here_1 (x); - return (cmp > 0) ? x : y; - } else { - SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); - } - } else if (SCM_REALP (x)) { - if (SCM_INUMP (y)) { - double z = SCM_INUM (y); - /* if x==NaN then "<" is false and we return NaN */ - return (SCM_REAL_VALUE (x) < z) ? scm_make_real (z) : x; - } else if (SCM_BIGP (y)) { - double xx = SCM_REAL_VALUE (x); - int cmp; - if (xisnan (xx)) - return x; - cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx); - scm_remember_upto_here_1 (y); - return (cmp < 0) ? x : y; - } else if (SCM_REALP (y)) { - /* if x==NaN then our explicit check means we return NaN - if y==NaN then ">" is false and we return NaN - calling isnan is unavoidable, since it's the only way to know - which of x or y causes any compares to be false */ - double xx = SCM_REAL_VALUE (x); - return (xisnan (xx) || xx > SCM_REAL_VALUE (y)) ? x : y; - } else { - SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); + if (SCM_I_INUMP (x)) + { + long xx = SCM_I_INUM (x); + if (SCM_I_INUMP (y)) + { + long yy = SCM_I_INUM (y); + return (xx < yy) ? y : x; + } + else if (SCM_BIGP (y)) + { + int sgn = mpz_sgn (SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_1 (y); + return (sgn < 0) ? x : y; + } + else if (SCM_REALP (y)) + { + double z = xx; + /* if y==NaN then ">" is false and we return NaN */ + return (z > SCM_REAL_VALUE (y)) ? scm_from_double (z) : y; + } + else if (SCM_FRACTIONP (y)) + { + use_less: + return (scm_is_false (scm_less_p (x, y)) ? x : y); + } + else + SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); } - } else { + else if (SCM_BIGP (x)) + { + if (SCM_I_INUMP (y)) + { + int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); + scm_remember_upto_here_1 (x); + return (sgn < 0) ? y : x; + } + else if (SCM_BIGP (y)) + { + int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + return (cmp > 0) ? x : y; + } + else if (SCM_REALP (y)) + { + /* if y==NaN then xx>yy is false, so we return the NaN y */ + double xx, yy; + big_real: + xx = scm_i_big2dbl (x); + yy = SCM_REAL_VALUE (y); + return (xx > yy ? scm_from_double (xx) : y); + } + else if (SCM_FRACTIONP (y)) + { + goto use_less; + } + else + SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); + } + else if (SCM_REALP (x)) + { + if (SCM_I_INUMP (y)) + { + double z = SCM_I_INUM (y); + /* if x==NaN then "<" is false and we return NaN */ + return (SCM_REAL_VALUE (x) < z) ? scm_from_double (z) : x; + } + else if (SCM_BIGP (y)) + { + SCM_SWAP (x, y); + goto big_real; + } + else if (SCM_REALP (y)) + { + /* if x==NaN then our explicit check means we return NaN + if y==NaN then ">" is false and we return NaN + calling isnan is unavoidable, since it's the only way to know + which of x or y causes any compares to be false */ + double xx = SCM_REAL_VALUE (x); + return (xisnan (xx) || xx > SCM_REAL_VALUE (y)) ? x : y; + } + else if (SCM_FRACTIONP (y)) + { + double yy = scm_i_fraction2double (y); + double xx = SCM_REAL_VALUE (x); + return (xx < yy) ? scm_from_double (yy) : x; + } + else + SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_I_INUMP (y)) + { + goto use_less; + } + else if (SCM_BIGP (y)) + { + goto use_less; + } + else if (SCM_REALP (y)) + { + double xx = scm_i_fraction2double (x); + return (xx < SCM_REAL_VALUE (y)) ? y : scm_from_double (xx); + } + else if (SCM_FRACTIONP (y)) + { + goto use_less; + } + else + 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); - } } @@ -2858,206 +3798,325 @@ SCM_GPROC1 (s_min, "min", scm_tc7_asubr, scm_min, g_min); SCM scm_min (SCM x, SCM y) { - if (SCM_UNBNDP (y)) { - if (SCM_UNBNDP (x)) { - SCM_WTA_DISPATCH_0 (g_min, s_min); - } else if (SCM_NUMBERP (x)) { - return x; - } else { - SCM_WTA_DISPATCH_1 (g_min, x, SCM_ARG1, s_min); + if (SCM_UNBNDP (y)) + { + if (SCM_UNBNDP (x)) + 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); } - } - if (SCM_INUMP (x)) { - long xx = SCM_INUM (x); - if (SCM_INUMP (y)) { - long yy = SCM_INUM (y); - return (xx < yy) ? x : y; - } else if (SCM_BIGP (y)) { - int sgn = mpz_sgn (SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_1 (y); - return (sgn < 0) ? y : x; - } else if (SCM_REALP (y)) { - double z = xx; - /* if y==NaN then "<" is false and we return NaN */ - return (z < SCM_REAL_VALUE (y)) ? scm_make_real (z) : y; - } else { - SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min); - } - } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) { - int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); - scm_remember_upto_here_1 (x); - return (sgn < 0) ? x : y; - } else if (SCM_BIGP (y)) { - int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_2 (x, y); - return (cmp > 0) ? y : x; - } else if (SCM_REALP (y)) { - double yy = SCM_REAL_VALUE (y); - int cmp; - if (xisnan (yy)) - return y; - cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy); - scm_remember_upto_here_1 (x); - return (cmp > 0) ? y : x; - } else { - SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min); - } - } else if (SCM_REALP (x)) { - if (SCM_INUMP (y)) { - double z = SCM_INUM (y); - /* if x==NaN then "<" is false and we return NaN */ - return (z < SCM_REAL_VALUE (x)) ? scm_make_real (z) : x; - } else if (SCM_BIGP (y)) { - double xx = SCM_REAL_VALUE (x); - int cmp; - if (xisnan (xx)) - return x; - cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx); - scm_remember_upto_here_1 (y); - return (cmp < 0) ? y : x; - } else if (SCM_REALP (y)) { - /* if x==NaN then our explicit check means we return NaN - if y==NaN then "<" is false and we return NaN - calling isnan is unavoidable, since it's the only way to know - which of x or y causes any compares to be false */ - double xx = SCM_REAL_VALUE (x); - return (xisnan (xx) || xx < SCM_REAL_VALUE (y)) ? x : y; - } else { - 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); - } -} - - -SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum); -/* "Return the sum of all parameter values. Return 0 if called without\n" - * "any parameters." - */ -SCM -scm_sum (SCM x, SCM y) -{ - if (SCM_UNBNDP (y)) + if (SCM_I_INUMP (x)) { - if (SCM_NUMBERP (x)) return x; - if (SCM_UNBNDP (x)) return SCM_INUM0; - SCM_WTA_DISPATCH_1 (g_sum, x, SCM_ARG1, s_sum); + long xx = SCM_I_INUM (x); + if (SCM_I_INUMP (y)) + { + long yy = SCM_I_INUM (y); + return (xx < yy) ? x : y; + } + else if (SCM_BIGP (y)) + { + int sgn = mpz_sgn (SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_1 (y); + return (sgn < 0) ? y : x; + } + else if (SCM_REALP (y)) + { + double z = xx; + /* if y==NaN then "<" is false and we return NaN */ + return (z < SCM_REAL_VALUE (y)) ? scm_from_double (z) : y; + } + else if (SCM_FRACTIONP (y)) + { + use_less: + return (scm_is_false (scm_less_p (x, y)) ? y : x); + } + else + SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min); } - - if (SCM_INUMP (x)) + else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) - { - long xx = SCM_INUM (x); - long yy = SCM_INUM (y); - long int z = xx + yy; - return SCM_FIXABLE (z) ? SCM_MAKINUM (z) : scm_i_long2big (z); - } + if (SCM_I_INUMP (y)) + { + int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); + scm_remember_upto_here_1 (x); + return (sgn < 0) ? x : y; + } else if (SCM_BIGP (y)) - { - SCM_SWAP (x, y); - goto add_big_inum; - } + { + int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + return (cmp > 0) ? y : x; + } else if (SCM_REALP (y)) - { - long int xx = SCM_INUM (x); - return scm_make_real (xx + SCM_REAL_VALUE (y)); - } - else if (SCM_COMPLEXP (y)) - { - long int xx = SCM_INUM (x); - return scm_make_complex (xx + SCM_COMPLEX_REAL (y), - SCM_COMPLEX_IMAG (y)); - } + { + /* if y==NaN then xx= 0) - mpz_ui_sub (SCM_I_BIG_MPZ (result), xx, SCM_I_BIG_MPZ (y)); - else - { - /* x - y == -(y + -x) */ - mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), -xx); - mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result)); - } - scm_remember_upto_here_1 (y); + if (xx == 0) + return scm_i_clonebig (y, 0); + else + { + int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); + SCM result = scm_i_mkbig (); - if ((xx < 0 && (sgn_y > 0)) || ((xx > 0) && sgn_y < 0)) - /* we know the result will have to be a bignum */ - return result; - else - return scm_i_normbig (result); - } - } else if (SCM_REALP (y)) { - long int xx = SCM_INUM (x); - return scm_make_real (xx - SCM_REAL_VALUE (y)); - } else if (SCM_COMPLEXP (y)) { - long int xx = SCM_INUM (x); - return scm_make_complex (xx - SCM_COMPLEX_REAL (y), - -SCM_COMPLEX_IMAG (y)); - } else { - SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); - } - } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) { - /* big-x - inum-y */ - long yy = SCM_INUM (y); - int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x)); + if (xx >= 0) + mpz_ui_sub (SCM_I_BIG_MPZ (result), xx, SCM_I_BIG_MPZ (y)); + else + { + /* x - y == -(y + -x) */ + mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), -xx); + mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result)); + } + scm_remember_upto_here_1 (y); - scm_remember_upto_here_1 (x); - if (sgn_x == 0) - return SCM_FIXABLE (-yy) ? SCM_MAKINUM (-yy) : scm_long2num (-yy); + if ((xx < 0 && (sgn_y > 0)) || ((xx > 0) && sgn_y < 0)) + /* we know the result will have to be a bignum */ + return result; + else + return scm_i_normbig (result); + } + } + else if (SCM_REALP (y)) + { + long int 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); + return scm_c_make_rectangular (xx - SCM_COMPLEX_REAL (y), + - SCM_COMPLEX_IMAG (y)); + } + else if (SCM_FRACTIONP (y)) + /* a - b/c = (ac - b) / c */ + return scm_i_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)), + SCM_FRACTION_NUMERATOR (y)), + SCM_FRACTION_DENOMINATOR (y)); else - { - SCM result = scm_i_mkbig (); + SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); + } + else if (SCM_BIGP (x)) + { + if (SCM_I_INUMP (y)) + { + /* big-x - inum-y */ + long 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)); + else + { + SCM result = scm_i_mkbig (); - mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy); - scm_remember_upto_here_1 (x); + if (yy >= 0) + mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy); + else + mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), -yy); + scm_remember_upto_here_1 (x); - if ((sgn_x < 0 && (yy > 0)) || ((sgn_x > 0) && yy < 0)) - /* we know the result will have to be a bignum */ - return result; - else - return scm_i_normbig (result); - } + if ((sgn_x < 0 && (yy > 0)) || ((sgn_x > 0) && yy < 0)) + /* we know the result will have to be a bignum */ + return result; + else + return scm_i_normbig (result); + } + } + else if (SCM_BIGP (y)) + { + int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x)); + int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); + SCM result = scm_i_mkbig (); + mpz_sub (SCM_I_BIG_MPZ (result), + SCM_I_BIG_MPZ (x), + SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + /* we know the result will have to be a bignum */ + if ((sgn_x == 1) && (sgn_y == -1)) + return result; + if ((sgn_x == -1) && (sgn_y == 1)) + return result; + return scm_i_normbig (result); + } + else if (SCM_REALP (y)) + { + double result = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_REAL_VALUE (y); + scm_remember_upto_here_1 (x); + return scm_from_double (result); + } + else if (SCM_COMPLEXP (y)) + { + double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x)) + - SCM_COMPLEX_REAL (y)); + scm_remember_upto_here_1 (x); + return scm_c_make_rectangular (real_part, - SCM_COMPLEX_IMAG (y)); + } + else if (SCM_FRACTIONP (y)) + 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 if (SCM_BIGP (y)) - { - int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x)); - int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); - SCM result = scm_i_mkbig (); - mpz_sub (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_2 (x, y); - /* we know the result will have to be a bignum */ - if ((sgn_x == 1) && (sgn_y == -1)) return result; - if ((sgn_x == -1) && (sgn_y == 1)) return result; - return scm_i_normbig (result); - } - else if (SCM_REALP (y)) { - double result = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_REAL_VALUE (y); - scm_remember_upto_here_1 (x); - return scm_make_real (result); + else if (SCM_REALP (x)) + { + if (SCM_I_INUMP (y)) + return scm_from_double (SCM_REAL_VALUE (x) - SCM_I_INUM (y)); + else if (SCM_BIGP (y)) + { + double result = SCM_REAL_VALUE (x) - mpz_get_d (SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_1 (x); + return scm_from_double (result); + } + else if (SCM_REALP (y)) + return scm_from_double (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y)); + else if (SCM_COMPLEXP (y)) + return scm_c_make_rectangular (SCM_REAL_VALUE (x) - SCM_COMPLEX_REAL (y), + -SCM_COMPLEX_IMAG (y)); + else if (SCM_FRACTIONP (y)) + return scm_from_double (SCM_REAL_VALUE (x) - scm_i_fraction2double (y)); + else + SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); } - else if (SCM_COMPLEXP (y)) { - double real_part = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_COMPLEX_REAL (y); - scm_remember_upto_here_1 (x); - return scm_make_complex (real_part, - SCM_COMPLEX_IMAG (y)); - } - else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); - } else if (SCM_REALP (x)) { - if (SCM_INUMP (y)) { - return scm_make_real (SCM_REAL_VALUE (x) - SCM_INUM (y)); - } else if (SCM_BIGP (y)) { - double result = SCM_REAL_VALUE (x) - mpz_get_d (SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_1 (x); - return scm_make_real (result); - } else if (SCM_REALP (y)) { - return scm_make_real (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y)); - } else if (SCM_COMPLEXP (y)) { - return scm_make_complex (SCM_REAL_VALUE (x) - SCM_COMPLEX_REAL (y), - -SCM_COMPLEX_IMAG (y)); - } else { - SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); - } - } else if (SCM_COMPLEXP (x)) { - if (SCM_INUMP (y)) { - return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_INUM (y), - SCM_COMPLEX_IMAG (x)); - } else if (SCM_BIGP (y)) { - double real_part = SCM_COMPLEX_REAL (x) - mpz_get_d (SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_1 (x); - return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y)); - } else if (SCM_REALP (y)) { - return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_REAL_VALUE (y), - SCM_COMPLEX_IMAG (x)); - } else if (SCM_COMPLEXP (y)) { - return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_COMPLEX_REAL (y), - SCM_COMPLEX_IMAG (x) - SCM_COMPLEX_IMAG (y)); - } else { - SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); + else if (SCM_COMPLEXP (x)) + { + if (SCM_I_INUMP (y)) + return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - SCM_I_INUM (y), + SCM_COMPLEX_IMAG (x)); + else if (SCM_BIGP (y)) + { + double real_part = (SCM_COMPLEX_REAL (x) + - mpz_get_d (SCM_I_BIG_MPZ (y))); + scm_remember_upto_here_1 (x); + return scm_c_make_rectangular (real_part, SCM_COMPLEX_IMAG (y)); + } + else if (SCM_REALP (y)) + return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - SCM_REAL_VALUE (y), + SCM_COMPLEX_IMAG (x)); + else if (SCM_COMPLEXP (y)) + return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - SCM_COMPLEX_REAL (y), + SCM_COMPLEX_IMAG (x) - SCM_COMPLEX_IMAG (y)); + else if (SCM_FRACTIONP (y)) + 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); } - } else { + else if (SCM_FRACTIONP (x)) + { + if (SCM_I_INUMP (y)) + /* a/b - c = (a - cb) / b */ + return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), + scm_product(y, SCM_FRACTION_DENOMINATOR (x))), + SCM_FRACTION_DENOMINATOR (x)); + else if (SCM_BIGP (y)) + return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), + scm_product(y, SCM_FRACTION_DENOMINATOR (x))), + SCM_FRACTION_DENOMINATOR (x)); + else if (SCM_REALP (y)) + return scm_from_double (scm_i_fraction2double (x) - SCM_REAL_VALUE (y)); + else if (SCM_COMPLEXP (y)) + return scm_c_make_rectangular (scm_i_fraction2double (x) - SCM_COMPLEX_REAL (y), + -SCM_COMPLEX_IMAG (y)); + else if (SCM_FRACTIONP (y)) + /* a/b - c/d = (ad - bc) / bd */ + return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)), + 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); + } + else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference); - } +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_oneminus, "1-", 1, 0, 0, + (SCM x), + "Return @math{@var{x}-1}.") +#define FUNC_NAME s_scm_oneminus +{ + return scm_difference (x, SCM_I_MAKINUM (1)); } #undef FUNC_NAME @@ -3230,130 +4369,175 @@ SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product); SCM scm_product (SCM x, SCM y) { - if (SCM_UNBNDP (y)) { - if (SCM_UNBNDP (x)) { - return SCM_MAKINUM (1L); - } else if (SCM_NUMBERP (x)) { - return x; - } else { - SCM_WTA_DISPATCH_1 (g_product, x, SCM_ARG1, s_product); + if (SCM_UNBNDP (y)) + { + if (SCM_UNBNDP (x)) + return SCM_I_MAKINUM (1L); + else if (SCM_NUMBERP (x)) + return x; + else + SCM_WTA_DISPATCH_1 (g_product, x, SCM_ARG1, s_product); } - } - if (SCM_INUMP (x)) { - long xx; + if (SCM_I_INUMP (x)) + { + long xx; - intbig: - xx = SCM_INUM (x); + intbig: + xx = SCM_I_INUM (x); - switch (xx) - { + switch (xx) + { case 0: return x; break; case 1: return y; break; - } + } - if (SCM_INUMP (y)) { - long yy = SCM_INUM (y); - long kk = xx * yy; - SCM k = SCM_MAKINUM (kk); - if ((kk == SCM_INUM (k)) && (kk / xx == yy)) { - return k; - } else { - SCM result = scm_i_long2big (xx); - mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), yy); - return scm_i_normbig (result); - } - } else if (SCM_BIGP (y)) { - SCM result = scm_i_mkbig (); - mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), xx); - scm_remember_upto_here_1 (y); - return result; - } else if (SCM_REALP (y)) { - return scm_make_real (xx * SCM_REAL_VALUE (y)); - } else if (SCM_COMPLEXP (y)) { - return scm_make_complex (xx * SCM_COMPLEX_REAL (y), - xx * SCM_COMPLEX_IMAG (y)); - } else { - SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); - } - } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) { - SCM_SWAP (x, y); - goto intbig; - } else if (SCM_BIGP (y)) { - SCM result = scm_i_mkbig (); - mpz_mul (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_2 (x, y); - return result; - } else if (SCM_REALP (y)) { - double result = mpz_get_d (SCM_I_BIG_MPZ (x)) * SCM_REAL_VALUE (y); - scm_remember_upto_here_1 (x); - return scm_make_real (result); - } else if (SCM_COMPLEXP (y)) { - double z = mpz_get_d (SCM_I_BIG_MPZ (x)); - scm_remember_upto_here_1 (x); - return scm_make_complex (z * SCM_COMPLEX_REAL (y), - z * SCM_COMPLEX_IMAG (y)); - } else { - SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); - } - } else if (SCM_REALP (x)) { - if (SCM_INUMP (y)) { - return scm_make_real (SCM_INUM (y) * SCM_REAL_VALUE (x)); - } else if (SCM_BIGP (y)) { - double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x); - scm_remember_upto_here_1 (y); - return scm_make_real (result); - } else if (SCM_REALP (y)) { - return scm_make_real (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y)); - } else if (SCM_COMPLEXP (y)) { - return scm_make_complex (SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y), - SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y)); - } else { - SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); - } - } else if (SCM_COMPLEXP (x)) { - if (SCM_INUMP (y)) { - return scm_make_complex (SCM_INUM (y) * SCM_COMPLEX_REAL (x), - SCM_INUM (y) * SCM_COMPLEX_IMAG (x)); - } else if (SCM_BIGP (y)) { - double z = mpz_get_d (SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_1 (y); - return scm_make_complex (z * SCM_COMPLEX_REAL (y), - z * SCM_COMPLEX_IMAG (y)); - } else if (SCM_REALP (y)) { - return scm_make_complex (SCM_REAL_VALUE (y) * SCM_COMPLEX_REAL (x), - SCM_REAL_VALUE (y) * SCM_COMPLEX_IMAG (x)); - } else if (SCM_COMPLEXP (y)) { - return scm_make_complex (SCM_COMPLEX_REAL (x) * SCM_COMPLEX_REAL (y) - - SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_IMAG (y), - SCM_COMPLEX_REAL (x) * SCM_COMPLEX_IMAG (y) - + SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_REAL (y)); - } else { - SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); + if (SCM_I_INUMP (y)) + { + long yy = SCM_I_INUM (y); + long 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); + mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), yy); + return scm_i_normbig (result); + } + } + else if (SCM_BIGP (y)) + { + SCM result = scm_i_mkbig (); + mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), xx); + scm_remember_upto_here_1 (y); + return result; + } + else if (SCM_REALP (y)) + return scm_from_double (xx * SCM_REAL_VALUE (y)); + else if (SCM_COMPLEXP (y)) + return scm_c_make_rectangular (xx * SCM_COMPLEX_REAL (y), + xx * SCM_COMPLEX_IMAG (y)); + else if (SCM_FRACTIONP (y)) + 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); } - } else { + else if (SCM_BIGP (x)) + { + if (SCM_I_INUMP (y)) + { + SCM_SWAP (x, y); + goto intbig; + } + else if (SCM_BIGP (y)) + { + SCM result = scm_i_mkbig (); + mpz_mul (SCM_I_BIG_MPZ (result), + SCM_I_BIG_MPZ (x), + SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + return result; + } + else if (SCM_REALP (y)) + { + double result = mpz_get_d (SCM_I_BIG_MPZ (x)) * SCM_REAL_VALUE (y); + scm_remember_upto_here_1 (x); + return scm_from_double (result); + } + else if (SCM_COMPLEXP (y)) + { + double z = mpz_get_d (SCM_I_BIG_MPZ (x)); + scm_remember_upto_here_1 (x); + return scm_c_make_rectangular (z * SCM_COMPLEX_REAL (y), + z * SCM_COMPLEX_IMAG (y)); + } + else if (SCM_FRACTIONP (y)) + 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); + } + else if (SCM_REALP (x)) + { + if (SCM_I_INUMP (y)) + return scm_from_double (SCM_I_INUM (y) * SCM_REAL_VALUE (x)); + else if (SCM_BIGP (y)) + { + double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x); + scm_remember_upto_here_1 (y); + return scm_from_double (result); + } + else if (SCM_REALP (y)) + return scm_from_double (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y)); + else if (SCM_COMPLEXP (y)) + return scm_c_make_rectangular (SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y), + SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y)); + else if (SCM_FRACTIONP (y)) + return scm_from_double (SCM_REAL_VALUE (x) * scm_i_fraction2double (y)); + else + SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); + } + else if (SCM_COMPLEXP (x)) + { + if (SCM_I_INUMP (y)) + return scm_c_make_rectangular (SCM_I_INUM (y) * SCM_COMPLEX_REAL (x), + SCM_I_INUM (y) * SCM_COMPLEX_IMAG (x)); + else if (SCM_BIGP (y)) + { + double z = mpz_get_d (SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_1 (y); + return scm_c_make_rectangular (z * SCM_COMPLEX_REAL (x), + z * SCM_COMPLEX_IMAG (x)); + } + else if (SCM_REALP (y)) + return scm_c_make_rectangular (SCM_REAL_VALUE (y) * SCM_COMPLEX_REAL (x), + SCM_REAL_VALUE (y) * SCM_COMPLEX_IMAG (x)); + else if (SCM_COMPLEXP (y)) + { + return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) * SCM_COMPLEX_REAL (y) + - SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_IMAG (y), + SCM_COMPLEX_REAL (x) * SCM_COMPLEX_IMAG (y) + + SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_REAL (y)); + } + else if (SCM_FRACTIONP (y)) + { + double yy = scm_i_fraction2double (y); + return scm_c_make_rectangular (yy * SCM_COMPLEX_REAL (x), + yy * SCM_COMPLEX_IMAG (x)); + } + else + SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_I_INUMP (y)) + return scm_i_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)), + SCM_FRACTION_DENOMINATOR (x)); + else if (SCM_BIGP (y)) + return scm_i_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)), + SCM_FRACTION_DENOMINATOR (x)); + else if (SCM_REALP (y)) + return scm_from_double (scm_i_fraction2double (x) * SCM_REAL_VALUE (y)); + else if (SCM_COMPLEXP (y)) + { + double xx = scm_i_fraction2double (x); + return scm_c_make_rectangular (xx * SCM_COMPLEX_REAL (y), + xx * SCM_COMPLEX_IMAG (y)); + } + else if (SCM_FRACTIONP (y)) + /* a/b * c/d = ac / bd */ + return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x), + SCM_FRACTION_NUMERATOR (y)), + scm_product (SCM_FRACTION_DENOMINATOR (x), + SCM_FRACTION_DENOMINATOR (y))); + else + 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); - } -} - -double -scm_num2dbl (SCM a, const char *why) -#define FUNC_NAME why -{ - if (SCM_INUMP (a)) { - return (double) SCM_INUM (a); - } else if (SCM_BIGP (a)) { - double result = mpz_get_d (SCM_I_BIG_MPZ (a)); - scm_remember_upto_here_1 (a); - return result; - } else if (SCM_REALP (a)) { - return (SCM_REAL_VALUE (a)); - } else { - SCM_WRONG_TYPE_ARG (SCM_ARGn, a); - } } -#undef FUNC_NAME #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \ || (defined (HAVE_FINITE) && defined (HAVE_ISNAN))) @@ -3393,319 +4577,608 @@ SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide); arguments. If called with one argument @var{z1}, 1/@var{z1} is returned. */ #define FUNC_NAME s_divide -SCM -scm_divide (SCM x, SCM y) +static SCM +scm_i_divide (SCM x, SCM y, int inexact) { double a; - if (SCM_UNBNDP (y)) { - if (SCM_UNBNDP (x)) { - SCM_WTA_DISPATCH_0 (g_divide, s_divide); - } else if (SCM_INUMP (x)) { - long xx = SCM_INUM (x); - if (xx == 1 || xx == -1) { - return x; + if (SCM_UNBNDP (y)) + { + if (SCM_UNBNDP (x)) + SCM_WTA_DISPATCH_0 (g_divide, s_divide); + else if (SCM_I_INUMP (x)) + { + long xx = SCM_I_INUM (x); + if (xx == 1 || xx == -1) + return x; #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO - } else if (xx == 0) { - scm_num_overflow (s_divide); + else if (xx == 0) + scm_num_overflow (s_divide); #endif - } else { - return scm_make_real (1.0 / (double) xx); - } - } else if (SCM_BIGP (x)) { - return scm_make_real (1.0 / scm_i_big2dbl (x)); - } else if (SCM_REALP (x)) { - double xx = SCM_REAL_VALUE (x); + else + { + if (inexact) + return scm_from_double (1.0 / (double) xx); + else return scm_i_make_ratio (SCM_I_MAKINUM(1), 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_I_MAKINUM(1), x); + } + else if (SCM_REALP (x)) + { + double xx = SCM_REAL_VALUE (x); #ifndef ALLOW_DIVIDE_BY_ZERO - if (xx == 0.0) - scm_num_overflow (s_divide); - else + if (xx == 0.0) + scm_num_overflow (s_divide); + else #endif - return scm_make_real (1.0 / xx); - } else if (SCM_COMPLEXP (x)) { - double r = SCM_COMPLEX_REAL (x); - double i = SCM_COMPLEX_IMAG (x); - if (r <= i) { - double t = r / i; - double d = i * (1.0 + t * t); - return scm_make_complex (t / d, -1.0 / d); - } else { - double t = i / r; - double d = r * (1.0 + t * t); - return scm_make_complex (1.0 / d, -t / d); - } - } else { - SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide); + return scm_from_double (1.0 / xx); + } + else if (SCM_COMPLEXP (x)) + { + double r = SCM_COMPLEX_REAL (x); + double i = SCM_COMPLEX_IMAG (x); + if (fabs(r) <= fabs(i)) + { + double t = r / i; + double d = i * (1.0 + t * t); + return scm_c_make_rectangular (t / d, -1.0 / d); + } + else + { + double t = i / r; + double d = r * (1.0 + t * t); + return scm_c_make_rectangular (1.0 / d, -t / d); + } + } + else if (SCM_FRACTIONP (x)) + return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x), + SCM_FRACTION_NUMERATOR (x)); + else + SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide); } - } - if (SCM_INUMP (x)) { - long xx = SCM_INUM (x); - if (SCM_INUMP (y)) { - long yy = SCM_INUM (y); - if (yy == 0) { + if (SCM_I_INUMP (x)) + { + long xx = SCM_I_INUM (x); + if (SCM_I_INUMP (y)) + { + long yy = SCM_I_INUM (y); + if (yy == 0) + { #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO - scm_num_overflow (s_divide); + scm_num_overflow (s_divide); #else - return scm_make_real ((double) xx / (double) yy); + return scm_from_double ((double) xx / (double) yy); #endif - } else if (xx % yy != 0) { - return scm_make_real ((double) xx / (double) yy); - } else { - long z = xx / yy; - if (SCM_FIXABLE (z)) { - return SCM_MAKINUM (z); - } else { - return scm_i_long2big (z); + } + else if (xx % yy != 0) + { + if (inexact) + return scm_from_double ((double) xx / (double) yy); + else return scm_i_make_ratio (x, y); + } + else + { + long z = xx / yy; + if (SCM_FIXABLE (z)) + return SCM_I_MAKINUM (z); + else + return scm_i_long2big (z); + } } - } - } else if (SCM_BIGP (y)) { - return scm_make_real ((double) xx / scm_i_big2dbl (y)); - } else if (SCM_REALP (y)) { - double yy = SCM_REAL_VALUE (y); + 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); + } + else if (SCM_REALP (y)) + { + double yy = SCM_REAL_VALUE (y); #ifndef ALLOW_DIVIDE_BY_ZERO - if (yy == 0.0) - scm_num_overflow (s_divide); - else + if (yy == 0.0) + scm_num_overflow (s_divide); + else #endif - return scm_make_real ((double) xx / yy); - } else if (SCM_COMPLEXP (y)) { - a = xx; - complex_div: /* y _must_ be a complex number */ - { - double r = SCM_COMPLEX_REAL (y); - double i = SCM_COMPLEX_IMAG (y); - if (r <= i) { - double t = r / i; - double d = i * (1.0 + t * t); - return scm_make_complex ((a * t) / d, -a / d); - } else { - double t = i / r; - double d = r * (1.0 + t * t); - return scm_make_complex (a / d, -(a * t) / d); + return scm_from_double ((double) xx / yy); } - } - } else { - SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); + else if (SCM_COMPLEXP (y)) + { + a = xx; + complex_div: /* y _must_ be a complex number */ + { + double r = SCM_COMPLEX_REAL (y); + double i = SCM_COMPLEX_IMAG (y); + if (fabs(r) <= fabs(i)) + { + double t = r / i; + double d = i * (1.0 + t * t); + return scm_c_make_rectangular ((a * t) / d, -a / d); + } + else + { + double t = i / r; + double d = r * (1.0 + t * t); + return scm_c_make_rectangular (a / d, -(a * t) / d); + } + } + } + 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)); + else + SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); } - } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) { - long int yy = SCM_INUM (y); - if (yy == 0) { + else if (SCM_BIGP (x)) + { + if (SCM_I_INUMP (y)) + { + long int yy = SCM_I_INUM (y); + if (yy == 0) + { #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO - scm_num_overflow (s_divide); + scm_num_overflow (s_divide); #else - int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); - scm_remember_upto_here_1 (x); - return (sgn == 0) ? scm_nan () : scm_inf (); + int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); + scm_remember_upto_here_1 (x); + return (sgn == 0) ? scm_nan () : scm_inf (); #endif - } else if (yy == 1) { - return x; - } else { - /* FIXME: HMM, what are the relative performance issues here? - We need to test. Is it faster on average to test - divisible_p, then perform whichever operation, or is it - faster to perform the integer div opportunistically and - switch to real if there's a remainder? For now we take the - middle ground: test, then if divisible, use the faster div - func. */ - - long abs_yy = yy < 0 ? -yy : yy; - int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (x), abs_yy); - - if (divisible_p) { - SCM result = scm_i_mkbig (); - mpz_divexact_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), abs_yy); - scm_remember_upto_here_1 (x); - if (yy < 0) - mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result)); - return scm_i_normbig (result); - } - else { - return scm_make_real (scm_i_big2dbl (x) / (double) yy); - } - } - } else if (SCM_BIGP (y)) { - int y_is_zero = (mpz_sgn (SCM_I_BIG_MPZ (y)) == 0); - if (y_is_zero) { + } + else if (yy == 1) + return x; + else + { + /* FIXME: HMM, what are the relative performance issues here? + We need to test. Is it faster on average to test + divisible_p, then perform whichever operation, or is it + faster to perform the integer div opportunistically and + switch to real if there's a remainder? For now we take the + middle ground: test, then if divisible, use the faster div + func. */ + + long abs_yy = yy < 0 ? -yy : yy; + int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (x), abs_yy); + + if (divisible_p) + { + SCM result = scm_i_mkbig (); + mpz_divexact_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), abs_yy); + scm_remember_upto_here_1 (x); + if (yy < 0) + mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result)); + 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); + } + } + } + else if (SCM_BIGP (y)) + { + int y_is_zero = (mpz_sgn (SCM_I_BIG_MPZ (y)) == 0); + if (y_is_zero) + { #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO - scm_num_overflow (s_divide); + scm_num_overflow (s_divide); #else - int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); - scm_remember_upto_here_1 (x); - return (sgn == 0) ? scm_nan () : scm_inf (); + int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); + scm_remember_upto_here_1 (x); + return (sgn == 0) ? scm_nan () : scm_inf (); #endif - } else { - /* big_x / big_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 { - double dbx = mpz_get_d (SCM_I_BIG_MPZ (x)); - double dby = mpz_get_d (SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_2 (x, y); - return scm_make_real (dbx / dby); - } - } - } else if (SCM_REALP (y)) { - double yy = SCM_REAL_VALUE (y); + } + else + { + /* big_x / big_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 + { + if (inexact) + { + double dbx = mpz_get_d (SCM_I_BIG_MPZ (x)); + double dby = mpz_get_d (SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + return scm_from_double (dbx / dby); + } + else return scm_i_make_ratio (x, y); + } + } + } + else if (SCM_REALP (y)) + { + double yy = SCM_REAL_VALUE (y); #ifndef ALLOW_DIVIDE_BY_ZERO - if (yy == 0.0) - scm_num_overflow (s_divide); - else + if (yy == 0.0) + scm_num_overflow (s_divide); + else #endif - return scm_make_real (scm_i_big2dbl (x) / yy); - } else if (SCM_COMPLEXP (y)) { - a = scm_i_big2dbl (x); - goto complex_div; - } else { - SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); - } - } else if (SCM_REALP (x)) { - double rx = SCM_REAL_VALUE (x); - if (SCM_INUMP (y)) { - long int yy = SCM_INUM (y); -#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO - if (yy == 0) - scm_num_overflow (s_divide); + return scm_from_double (scm_i_big2dbl (x) / yy); + } + else if (SCM_COMPLEXP (y)) + { + a = scm_i_big2dbl (x); + goto complex_div; + } + else if (SCM_FRACTIONP (y)) + return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)), + SCM_FRACTION_NUMERATOR (y)); else + SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); + } + else if (SCM_REALP (x)) + { + double rx = SCM_REAL_VALUE (x); + if (SCM_I_INUMP (y)) + { + long int yy = SCM_I_INUM (y); +#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO + if (yy == 0) + scm_num_overflow (s_divide); + else #endif - return scm_make_real (rx / (double) yy); - } else if (SCM_BIGP (y)) { - double dby = mpz_get_d (SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_1 (y); - return scm_make_real (rx / dby); - } else if (SCM_REALP (y)) { - double yy = SCM_REAL_VALUE (y); + return scm_from_double (rx / (double) yy); + } + else if (SCM_BIGP (y)) + { + 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_REALP (y)) + { + double yy = SCM_REAL_VALUE (y); #ifndef ALLOW_DIVIDE_BY_ZERO - if (yy == 0.0) - scm_num_overflow (s_divide); - else + if (yy == 0.0) + scm_num_overflow (s_divide); + else #endif - return scm_make_real (rx / yy); - } else if (SCM_COMPLEXP (y)) { - a = rx; - goto complex_div; - } else { - SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); - } - } else if (SCM_COMPLEXP (x)) { - double rx = SCM_COMPLEX_REAL (x); - double ix = SCM_COMPLEX_IMAG (x); - if (SCM_INUMP (y)) { - long int yy = SCM_INUM (y); -#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO - if (yy == 0) - scm_num_overflow (s_divide); + return scm_from_double (rx / yy); + } + else if (SCM_COMPLEXP (y)) + { + a = rx; + goto complex_div; + } + 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); + } + else if (SCM_COMPLEXP (x)) + { + double rx = SCM_COMPLEX_REAL (x); + double ix = SCM_COMPLEX_IMAG (x); + if (SCM_I_INUMP (y)) + { + long int yy = SCM_I_INUM (y); +#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO + if (yy == 0) + scm_num_overflow (s_divide); + else #endif - { - double d = yy; - return scm_make_complex (rx / d, ix / d); - } - } else if (SCM_BIGP (y)) { - double dby = mpz_get_d (SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_1 (y); - return scm_make_complex (rx / dby, ix / dby); - } else if (SCM_REALP (y)) { - double yy = SCM_REAL_VALUE (y); + { + double d = yy; + return scm_c_make_rectangular (rx / d, ix / d); + } + } + else if (SCM_BIGP (y)) + { + 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_REALP (y)) + { + double yy = SCM_REAL_VALUE (y); #ifndef ALLOW_DIVIDE_BY_ZERO - if (yy == 0.0) - scm_num_overflow (s_divide); + if (yy == 0.0) + scm_num_overflow (s_divide); + else +#endif + return scm_c_make_rectangular (rx / yy, ix / yy); + } + else if (SCM_COMPLEXP (y)) + { + double ry = SCM_COMPLEX_REAL (y); + double iy = SCM_COMPLEX_IMAG (y); + if (fabs(ry) <= fabs(iy)) + { + double t = ry / iy; + double d = iy * (1.0 + t * t); + return scm_c_make_rectangular ((rx * t + ix) / d, (ix * t - rx) / d); + } + else + { + double t = iy / ry; + double d = ry * (1.0 + t * t); + return scm_c_make_rectangular ((rx + ix * t) / d, (ix - rx * t) / d); + } + } + else if (SCM_FRACTIONP (y)) + { + 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); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_I_INUMP (y)) + { + long int yy = SCM_I_INUM (y); +#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO + if (yy == 0) + scm_num_overflow (s_divide); + else #endif - return scm_make_complex (rx / yy, ix / yy); - } else if (SCM_COMPLEXP (y)) { - double ry = SCM_COMPLEX_REAL (y); - double iy = SCM_COMPLEX_IMAG (y); - if (ry <= iy) { - double t = ry / iy; - double d = iy * (1.0 + t * t); - return scm_make_complex ((rx * t + ix) / d, (ix * t - rx) / d); - } else { - double t = iy / ry; - double d = ry * (1.0 + t * t); - return scm_make_complex ((rx + ix * t) / d, (ix - rx * t) / d); - } - } else { - SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); + return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x), + 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)); + } + else if (SCM_REALP (y)) + { + double yy = SCM_REAL_VALUE (y); +#ifndef ALLOW_DIVIDE_BY_ZERO + if (yy == 0.0) + scm_num_overflow (s_divide); + else +#endif + return scm_from_double (scm_i_fraction2double (x) / yy); + } + else if (SCM_COMPLEXP (y)) + { + 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))); + else + SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); } - } else { + else SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide); - } +} + +SCM +scm_divide (SCM x, SCM y) +{ + return scm_i_divide (x, y, 0); +} + +static SCM scm_divide2real (SCM x, SCM y) +{ + return scm_i_divide (x, y, 1); } #undef FUNC_NAME -SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_dsubr, (SCM (*)()) scm_asinh, g_asinh); -/* "Return the inverse hyperbolic sine of @var{x}." - */ + double scm_asinh (double x) { +#if HAVE_ASINH + return asinh (x); +#else +#define asinh scm_asinh return log (x + sqrt (x * x + 1)); +#endif } +SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_dsubr, (SCM (*)()) asinh, g_asinh); +/* "Return the inverse hyperbolic sine of @var{x}." + */ -SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_dsubr, (SCM (*)()) scm_acosh, g_acosh); -/* "Return the inverse hyperbolic cosine of @var{x}." - */ double scm_acosh (double x) { +#if HAVE_ACOSH + return acosh (x); +#else +#define acosh scm_acosh return log (x + sqrt (x * x - 1)); +#endif } +SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_dsubr, (SCM (*)()) acosh, g_acosh); +/* "Return the inverse hyperbolic cosine of @var{x}." + */ -SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_dsubr, (SCM (*)()) scm_atanh, g_atanh); -/* "Return the inverse hyperbolic tangent of @var{x}." - */ double scm_atanh (double x) { +#if HAVE_ATANH + return atanh (x); +#else +#define atanh scm_atanh return 0.5 * log ((1 + x) / (1 - x)); +#endif } +SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_dsubr, (SCM (*)()) atanh, g_atanh); +/* "Return the inverse hyperbolic tangent of @var{x}." + */ -SCM_GPROC1 (s_truncate, "truncate", scm_tc7_dsubr, (SCM (*)()) scm_truncate, g_truncate); -/* "Round the inexact number @var{x} towards zero." - */ double -scm_truncate (double x) +scm_c_truncate (double x) { +#if HAVE_TRUNC + return trunc (x); +#else if (x < 0.0) return -floor (-x); return floor (x); +#endif } +/* scm_c_round is done using floor(x+0.5) to round to nearest and with + half-way case (ie. when x is an integer plus 0.5) going upwards. + Then half-way cases are identified and adjusted down if the + round-upwards didn't give the desired even integer. + + "plus_half == result" identifies a half-way case. If plus_half, which is + x + 0.5, is an integer then x must be an integer plus 0.5. + + An odd "result" value is identified with result/2 != floor(result/2). + This is done with plus_half, since that value is ready for use sooner in + a pipelined cpu, and we're already requiring plus_half == result. + + Note however that we need to be careful when x is big and already an + integer. In that case "x+0.5" may round to an adjacent integer, causing + us to return such a value, incorrectly. For instance if the hardware is + in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF + (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value + returned. Or if the hardware is in round-upwards mode, then other bigger + values like say x == 2^128 will see x+0.5 rounding up to the next higher + representable value, 2^128+2^76 (or whatever), again incorrect. + + These bad roundings of x+0.5 are avoided by testing at the start whether + x is already an integer. If it is then clearly that's the desired result + already. And if it's not then the exponent must be small enough to allow + an 0.5 to be represented, and hence added without a bad rounding. */ + +double +scm_c_round (double x) +{ + double plus_half, result; + + if (x == floor (x)) + return x; + + plus_half = x + 0.5; + result = floor (plus_half); + /* Adjust so that the rounding is towards even. */ + return ((plus_half == result && plus_half / 2 != floor (plus_half / 2)) + ? result - 1 + : result); +} + +SCM_DEFINE (scm_truncate_number, "truncate", 1, 0, 0, + (SCM x), + "Round the number @var{x} towards zero.") +#define FUNC_NAME s_scm_truncate_number +{ + if (scm_is_false (scm_negative_p (x))) + return scm_floor (x); + else + return scm_ceiling (x); +} +#undef FUNC_NAME + +static SCM exactly_one_half; + +SCM_DEFINE (scm_round_number, "round", 1, 0, 0, + (SCM x), + "Round the number @var{x} towards the nearest integer. " + "When it is exactly halfway between two integers, " + "round towards the even one.") +#define FUNC_NAME s_scm_round_number +{ + if (SCM_I_INUMP (x) || SCM_BIGP (x)) + return x; + else if (SCM_REALP (x)) + return scm_from_double (scm_c_round (SCM_REAL_VALUE (x))); + else + { + /* OPTIMIZE-ME: Fraction case could be done more efficiently by a + single quotient+remainder division then examining to see which way + the rounding should go. */ + SCM plus_half = scm_sum (x, exactly_one_half); + SCM result = scm_floor (plus_half); + /* Adjust so that the rounding is towards even. */ + if (scm_is_true (scm_num_eq_p (plus_half, result)) + && scm_is_true (scm_odd_p (result))) + return scm_difference (result, SCM_I_MAKINUM (1)); + else + return result; + } +} +#undef FUNC_NAME + +SCM_PRIMITIVE_GENERIC (scm_floor, "floor", 1, 0, 0, + (SCM x), + "Round the number @var{x} towards minus infinity.") +#define FUNC_NAME s_scm_floor +{ + if (SCM_I_INUMP (x) || SCM_BIGP (x)) + return x; + else if (SCM_REALP (x)) + return scm_from_double (floor (SCM_REAL_VALUE (x))); + else if (SCM_FRACTIONP (x)) + { + SCM q = scm_quotient (SCM_FRACTION_NUMERATOR (x), + SCM_FRACTION_DENOMINATOR (x)); + if (scm_is_false (scm_negative_p (x))) + { + /* For positive x, rounding towards zero is correct. */ + return q; + } + else + { + /* For negative x, we need to return q-1 unless x is an + integer. But fractions are never integer, per our + assumptions. */ + return scm_difference (q, SCM_I_MAKINUM (1)); + } + } + else + SCM_WTA_DISPATCH_1 (g_scm_floor, x, 1, s_scm_floor); +} +#undef FUNC_NAME -SCM_GPROC1 (s_round, "round", scm_tc7_dsubr, (SCM (*)()) scm_round, g_round); -/* "Round the inexact number @var{x}. If @var{x} is halfway between two\n" - * "numbers, round towards even." - */ -double -scm_round (double x) +SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0, + (SCM x), + "Round the number @var{x} towards infinity.") +#define FUNC_NAME s_scm_ceiling { - double plus_half = x + 0.5; - double result = floor (plus_half); - /* Adjust so that the scm_round is towards even. */ - return (plus_half == result && plus_half / 2 != floor (plus_half / 2)) - ? result - 1 : result; + if (SCM_I_INUMP (x) || SCM_BIGP (x)) + return x; + else if (SCM_REALP (x)) + return scm_from_double (ceil (SCM_REAL_VALUE (x))); + else if (SCM_FRACTIONP (x)) + { + SCM q = scm_quotient (SCM_FRACTION_NUMERATOR (x), + SCM_FRACTION_DENOMINATOR (x)); + if (scm_is_false (scm_positive_p (x))) + { + /* For negative x, rounding towards zero is correct. */ + return q; + } + else + { + /* For positive x, we need to return q+1 unless x is an + integer. But fractions are never integer, per our + assumptions. */ + return scm_sum (q, SCM_I_MAKINUM (1)); + } + } + else + SCM_WTA_DISPATCH_1 (g_scm_ceiling, x, 1, s_scm_ceiling); } +#undef FUNC_NAME - -SCM_GPROC1 (s_i_floor, "floor", scm_tc7_dsubr, (SCM (*)()) floor, g_i_floor); -/* "Round the number @var{x} towards minus infinity." - */ -SCM_GPROC1 (s_i_ceil, "ceiling", scm_tc7_dsubr, (SCM (*)()) ceil, g_i_ceil); -/* "Round the number @var{x} towards infinity." - */ SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_dsubr, (SCM (*)()) sqrt, g_i_sqrt); /* "Return the square root of the real number @var{x}." */ @@ -3759,25 +5232,27 @@ static void scm_two_doubles (SCM x, static void scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy) { - if (SCM_INUMP (x)) { - xy->x = SCM_INUM (x); - } else if (SCM_BIGP (x)) { + if (SCM_I_INUMP (x)) + xy->x = SCM_I_INUM (x); + else if (SCM_BIGP (x)) xy->x = scm_i_big2dbl (x); - } else if (SCM_REALP (x)) { + else if (SCM_REALP (x)) xy->x = SCM_REAL_VALUE (x); - } else { + else if (SCM_FRACTIONP (x)) + xy->x = scm_i_fraction2double (x); + else scm_wrong_type_arg (sstring, SCM_ARG1, x); - } - if (SCM_INUMP (y)) { - xy->y = SCM_INUM (y); - } else if (SCM_BIGP (y)) { + if (SCM_I_INUMP (y)) + xy->y = SCM_I_INUM (y); + else if (SCM_BIGP (y)) xy->y = scm_i_big2dbl (y); - } else if (SCM_REALP (y)) { + else if (SCM_REALP (y)) xy->y = SCM_REAL_VALUE (y); - } else { + else if (SCM_FRACTIONP (y)) + xy->y = scm_i_fraction2double (y); + else scm_wrong_type_arg (sstring, SCM_ARG2, y); - } } @@ -3789,7 +5264,7 @@ SCM_DEFINE (scm_sys_expt, "$expt", 2, 0, 0, { struct dpair xy; scm_two_doubles (x, y, FUNC_NAME, &xy); - return scm_make_real (pow (xy.x, xy.y)); + return scm_from_double (pow (xy.x, xy.y)); } #undef FUNC_NAME @@ -3805,10 +5280,25 @@ SCM_DEFINE (scm_sys_atan2, "$atan2", 2, 0, 0, { struct dpair xy; scm_two_doubles (x, y, FUNC_NAME, &xy); - return scm_make_real (atan2 (xy.x, xy.y)); + return scm_from_double (atan2 (xy.x, xy.y)); } #undef FUNC_NAME +SCM +scm_c_make_rectangular (double re, double im) +{ + if (im == 0.0) + return scm_from_double (re); + else + { + SCM z; + SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (sizeof (scm_t_complex), + "complex")); + SCM_COMPLEX_REAL (z) = re; + SCM_COMPLEX_IMAG (z) = im; + return z; + } +} SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0, (SCM real, SCM imaginary), @@ -3818,11 +5308,22 @@ SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0, { struct dpair xy; scm_two_doubles (real, imaginary, FUNC_NAME, &xy); - return scm_make_complex (xy.x, xy.y); + return scm_c_make_rectangular (xy.x, xy.y); } #undef FUNC_NAME - +SCM +scm_c_make_polar (double mag, double ang) +{ + double s, c; +#if HAVE_SINCOS + sincos (ang, &s, &c); +#else + s = sin (ang); + c = cos (ang); +#endif + return scm_c_make_rectangular (mag * c, mag * s); +} SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0, (SCM x, SCM y), @@ -3831,7 +5332,7 @@ SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0, { struct dpair xy; scm_two_doubles (x, y, FUNC_NAME, &xy); - return scm_make_complex (xy.x * cos (xy.y), xy.x * sin (xy.y)); + return scm_c_make_polar (xy.x, xy.y); } #undef FUNC_NAME @@ -3842,17 +5343,18 @@ SCM_GPROC (s_real_part, "real-part", 1, 0, 0, scm_real_part, g_real_part); SCM scm_real_part (SCM z) { - if (SCM_INUMP (z)) { + if (SCM_I_INUMP (z)) + return z; + else if (SCM_BIGP (z)) return z; - } else if (SCM_BIGP (z)) { + else if (SCM_REALP (z)) return z; - } else if (SCM_REALP (z)) { + else if (SCM_COMPLEXP (z)) + return scm_from_double (SCM_COMPLEX_REAL (z)); + else if (SCM_FRACTIONP (z)) return z; - } else if (SCM_COMPLEXP (z)) { - return scm_make_real (SCM_COMPLEX_REAL (z)); - } else { + else SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part); - } } @@ -3862,19 +5364,62 @@ SCM_GPROC (s_imag_part, "imag-part", 1, 0, 0, scm_imag_part, g_imag_part); SCM scm_imag_part (SCM z) { - if (SCM_INUMP (z)) { + if (SCM_I_INUMP (z)) return SCM_INUM0; - } else if (SCM_BIGP (z)) { + else if (SCM_BIGP (z)) return SCM_INUM0; - } else if (SCM_REALP (z)) { + else if (SCM_REALP (z)) return scm_flo0; - } else if (SCM_COMPLEXP (z)) { - return scm_make_real (SCM_COMPLEX_IMAG (z)); - } else { + else if (SCM_COMPLEXP (z)) + return scm_from_double (SCM_COMPLEX_IMAG (z)); + else if (SCM_FRACTIONP (z)) + return SCM_INUM0; + else SCM_WTA_DISPATCH_1 (g_imag_part, z, SCM_ARG1, s_imag_part); - } } +SCM_GPROC (s_numerator, "numerator", 1, 0, 0, scm_numerator, g_numerator); +/* "Return the numerator of the number @var{z}." + */ +SCM +scm_numerator (SCM z) +{ + if (SCM_I_INUMP (z)) + return z; + else if (SCM_BIGP (z)) + return z; + else if (SCM_FRACTIONP (z)) + { + scm_i_fraction_reduce (z); + return SCM_FRACTION_NUMERATOR (z); + } + else if (SCM_REALP (z)) + return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z))); + else + SCM_WTA_DISPATCH_1 (g_numerator, z, SCM_ARG1, s_numerator); +} + + +SCM_GPROC (s_denominator, "denominator", 1, 0, 0, scm_denominator, g_denominator); +/* "Return the denominator of the number @var{z}." + */ +SCM +scm_denominator (SCM z) +{ + if (SCM_I_INUMP (z)) + return SCM_I_MAKINUM (1); + else if (SCM_BIGP (z)) + return SCM_I_MAKINUM (1); + else if (SCM_FRACTIONP (z)) + { + scm_i_fraction_reduce (z); + return SCM_FRACTION_DENOMINATOR (z); + } + else if (SCM_REALP (z)) + return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z))); + else + SCM_WTA_DISPATCH_1 (g_denominator, z, SCM_ARG1, s_denominator); +} SCM_GPROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude, g_magnitude); /* "Return the magnitude of the number @var{z}. This is the same as\n" @@ -3883,32 +5428,38 @@ SCM_GPROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude, g_magnitude); SCM scm_magnitude (SCM z) { - if (SCM_INUMP (z)) { - long int zz = SCM_INUM (z); - if (zz >= 0) { - return z; - } else if (SCM_POSFIXABLE (-zz)) { - return SCM_MAKINUM (-zz); - } else { - return scm_i_long2big (-zz); - } - } else if (SCM_BIGP (z)) { - int sgn = mpz_sgn (SCM_I_BIG_MPZ (z)); - scm_remember_upto_here_1 (z); - if (sgn < 0) { - return scm_i_clonebig (z, 0); - } else { - return z; + if (SCM_I_INUMP (z)) + { + long int 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); } - } else if (SCM_REALP (z)) { - return scm_make_real (fabs (SCM_REAL_VALUE (z))); - } else if (SCM_COMPLEXP (z)) { - double r = SCM_COMPLEX_REAL (z); - double i = SCM_COMPLEX_IMAG (z); - return scm_make_real (sqrt (i * i + r * r)); - } else { + else if (SCM_BIGP (z)) + { + int sgn = mpz_sgn (SCM_I_BIG_MPZ (z)); + scm_remember_upto_here_1 (z); + if (sgn < 0) + return scm_i_clonebig (z, 0); + else + return z; + } + else if (SCM_REALP (z)) + return scm_from_double (fabs (SCM_REAL_VALUE (z))); + else if (SCM_COMPLEXP (z)) + return scm_from_double (hypot (SCM_COMPLEX_REAL (z), SCM_COMPLEX_IMAG (z))); + else if (SCM_FRACTIONP (z)) + { + 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)); + } + else SCM_WTA_DISPATCH_1 (g_magnitude, z, SCM_ARG1, s_magnitude); - } } @@ -3918,27 +5469,43 @@ SCM_GPROC (s_angle, "angle", 1, 0, 0, scm_angle, g_angle); SCM scm_angle (SCM z) { - if (SCM_INUMP (z)) { - if (SCM_INUM (z) >= 0) { - return scm_make_real (atan2 (0.0, 1.0)); - } else { - return scm_make_real (atan2 (0.0, -1.0)); - } - } else if (SCM_BIGP (z)) { - int sgn = mpz_sgn (SCM_I_BIG_MPZ (z)); - scm_remember_upto_here_1 (z); - if (sgn < 0) { - return scm_make_real (atan2 (0.0, -1.0)); - } else { - return scm_make_real (atan2 (0.0, 1.0)); - } - } else if (SCM_REALP (z)) { - return scm_make_real (atan2 (0.0, SCM_REAL_VALUE (z))); - } else if (SCM_COMPLEXP (z)) { - return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z))); - } else { + /* atan(0,-1) is pi and it'd be possible to have that as a constant like + scm_flo0 to save allocating a new flonum with scm_from_double each time. + But if atan2 follows the floating point rounding mode, then the value + is not a constant. Maybe it'd be close enough though. */ + if (SCM_I_INUMP (z)) + { + if (SCM_I_INUM (z) >= 0) + return scm_flo0; + else + return scm_from_double (atan2 (0.0, -1.0)); + } + else if (SCM_BIGP (z)) + { + int sgn = mpz_sgn (SCM_I_BIG_MPZ (z)); + scm_remember_upto_here_1 (z); + if (sgn < 0) + return scm_from_double (atan2 (0.0, -1.0)); + else + return scm_flo0; + } + else if (SCM_REALP (z)) + { + if (SCM_REAL_VALUE (z) >= 0) + return scm_flo0; + else + return scm_from_double (atan2 (0.0, -1.0)); + } + else if (SCM_COMPLEXP (z)) + return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z))); + else if (SCM_FRACTIONP (z)) + { + if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z)))) + return scm_flo0; + else return scm_from_double (atan2 (0.0, -1.0)); + } + else SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle); - } } @@ -3948,10 +5515,12 @@ SCM_GPROC (s_exact_to_inexact, "exact->inexact", 1, 0, 0, scm_exact_to_inexact, SCM scm_exact_to_inexact (SCM z) { - if (SCM_INUMP (z)) - return scm_make_real ((double) SCM_INUM (z)); + if (SCM_I_INUMP (z)) + return scm_from_double ((double) SCM_I_INUM (z)); else if (SCM_BIGP (z)) - return scm_make_real (scm_i_big2dbl (z)); + return scm_from_double (scm_i_big2dbl (z)); + else if (SCM_FRACTIONP (z)) + return scm_from_double (scm_i_fraction2double (z)); else if (SCM_INEXACTP (z)) return z; else @@ -3964,280 +5533,446 @@ SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, "Return an exact number that is numerically closest to @var{z}.") #define FUNC_NAME s_scm_inexact_to_exact { - if (SCM_INUMP (z)) { + if (SCM_I_INUMP (z)) return z; - } else if (SCM_BIGP (z)) { + else if (SCM_BIGP (z)) return z; - } else if (SCM_REALP (z)) { - double u = floor (SCM_REAL_VALUE (z) + 0.5); - long lu = (long) u; - if (SCM_FIXABLE (lu)) { - return SCM_MAKINUM (lu); - } else if (isfinite (u) && !xisnan (u)) { - return scm_i_dbl2big (u); - } else { - scm_num_overflow (s_scm_inexact_to_exact); + else if (SCM_REALP (z)) + { + if (xisinf (SCM_REAL_VALUE (z)) || xisnan (SCM_REAL_VALUE (z))) + SCM_OUT_OF_RANGE (1, z); + else + { + mpq_t frac; + SCM q; + + mpq_init (frac); + mpq_set_d (frac, SCM_REAL_VALUE (z)); + q = scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac)), + scm_i_mpz2num (mpq_denref (frac))); + + /* When scm_i_make_ratio throws, we leak the memory allocated + for frac... + */ + mpq_clear (frac); + return q; + } } - } else { + else if (SCM_FRACTIONP (z)) + return z; + else SCM_WRONG_TYPE_ARG (1, z); - } } #undef FUNC_NAME -/* if you need to change this, change test-num2integral.c as well */ -#if SCM_SIZEOF_LONG_LONG != 0 -# ifndef LLONG_MAX -# define ULLONG_MAX ((unsigned long long) (-1)) -# define LLONG_MAX ((long long) (ULLONG_MAX >> 1)) -# define LLONG_MIN (~LLONG_MAX) -# endif -#endif - -/* Parameters for creating integer conversion routines. +SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0, + (SCM x, SCM err), + "Return an exact number that is within @var{err} of @var{x}.") +#define FUNC_NAME s_scm_rationalize +{ + if (SCM_I_INUMP (x)) + return x; + else if (SCM_BIGP (x)) + return x; + else if ((SCM_REALP (x)) || SCM_FRACTIONP (x)) + { + /* Use continued fractions to find closest ratio. All + arithmetic is done with exact numbers. + */ - Define the following preprocessor macros before including - "libguile/num2integral.i.c": + SCM ex = scm_inexact_to_exact (x); + SCM int_part = scm_floor (ex); + SCM tt = SCM_I_MAKINUM (1); + SCM a1 = SCM_I_MAKINUM (0), a2 = SCM_I_MAKINUM (1), a = SCM_I_MAKINUM (0); + SCM b1 = SCM_I_MAKINUM (1), b2 = SCM_I_MAKINUM (0), b = SCM_I_MAKINUM (0); + SCM rx; + int i = 0; + + if (scm_is_true (scm_num_eq_p (ex, int_part))) + return ex; + + ex = scm_difference (ex, int_part); /* x = x-int_part */ + rx = scm_divide (ex, SCM_UNDEFINED); /* rx = 1/x */ + + /* We stop after a million iterations just to be absolutely sure + that we don't go into an infinite loop. The process normally + converges after less than a dozen iterations. + */ - NUM2INTEGRAL - the name of the function for converting from a - Scheme object to the integral type. This function will be - defined when including "num2integral.i.c". + err = scm_abs (err); + while (++i < 1000000) + { + a = scm_sum (scm_product (a1, tt), a2); /* a = a1*tt + a2 */ + b = scm_sum (scm_product (b1, tt), b2); /* b = b1*tt + b2 */ + if (scm_is_false (scm_zero_p (b)) && /* b != 0 */ + scm_is_false + (scm_gr_p (scm_abs (scm_difference (ex, scm_divide (a, b))), + err))) /* abs(x-a/b) <= err */ + { + SCM res = scm_sum (int_part, scm_divide (a, b)); + if (scm_is_false (scm_exact_p (x)) + || scm_is_false (scm_exact_p (err))) + return scm_exact_to_inexact (res); + else + return res; + } + rx = scm_divide (scm_difference (rx, tt), /* rx = 1/(rx - tt) */ + SCM_UNDEFINED); + tt = scm_floor (rx); /* tt = floor (rx) */ + a2 = a1; + b2 = b1; + a1 = a; + b1 = b; + } + scm_num_overflow (s_scm_rationalize); + } + else + SCM_WRONG_TYPE_ARG (1, x); +} +#undef FUNC_NAME - INTEGRAL2NUM - the name of the function for converting from the - integral type to a Scheme object. This function will be defined. +/* conversion functions */ - INTEGRAL2BIG - the name of an internal function that createas a - bignum from the integral type. This function will be defined. - The name should start with "scm_i_". +int +scm_is_integer (SCM val) +{ + return scm_is_true (scm_integer_p (val)); +} - ITYPE - the name of the integral type. +int +scm_is_signed_integer (SCM val, scm_t_intmax min, scm_t_intmax max) +{ + if (SCM_I_INUMP (val)) + { + scm_t_signed_bits n = SCM_I_INUM (val); + return n >= min && n <= max; + } + else if (SCM_BIGP (val)) + { + if (min >= SCM_MOST_NEGATIVE_FIXNUM && max <= SCM_MOST_POSITIVE_FIXNUM) + return 0; + else if (min >= LONG_MIN && max <= LONG_MAX) + { + if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val))) + { + long n = mpz_get_si (SCM_I_BIG_MPZ (val)); + return n >= min && n <= max; + } + else + return 0; + } + else + { + scm_t_intmax n; + size_t count; - UNSIGNED - Define this to 1 when ITYPE is an unsigned type. Define - it to 0 otherwise. + if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2) + > CHAR_BIT*sizeof (scm_t_uintmax)) + return 0; + + mpz_export (&n, &count, 1, sizeof (scm_t_uintmax), 0, 0, + SCM_I_BIG_MPZ (val)); - UNSIGNED_ITYPE - the name of the the unsigned variant of the - integral type. If you don't define this, it defaults to - "unsigned ITYPE" for signed types and simply "ITYPE" for unsigned - ones. + if (mpz_sgn (SCM_I_BIG_MPZ (val)) >= 0) + { + if (n < 0) + return 0; + } + else + { + n = -n; + if (n >= 0) + return 0; + } - SIZEOF_ITYPE - an expression giving the size of the integral type - in bytes. This expression must be computable by the - preprocessor. (SIZEOF_FOO values are calculated by configure.in - for common types). + return n >= min && n <= max; + } + } + else + return 0; +} -*/ +int +scm_is_unsigned_integer (SCM val, scm_t_uintmax min, scm_t_uintmax max) +{ + if (SCM_I_INUMP (val)) + { + scm_t_signed_bits n = SCM_I_INUM (val); + return n >= 0 && ((scm_t_uintmax)n) >= min && ((scm_t_uintmax)n) <= max; + } + else if (SCM_BIGP (val)) + { + if (max <= SCM_MOST_POSITIVE_FIXNUM) + return 0; + else if (max <= ULONG_MAX) + { + if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val))) + { + unsigned long n = mpz_get_ui (SCM_I_BIG_MPZ (val)); + return n >= min && n <= max; + } + else + return 0; + } + else + { + scm_t_uintmax n; + size_t count; -#define NUM2INTEGRAL scm_num2short -#define INTEGRAL2NUM scm_short2num -#define INTEGRAL2BIG scm_i_short2big -#define UNSIGNED 0 -#define ITYPE short -#define SIZEOF_ITYPE SIZEOF_SHORT -#include "libguile/num2integral.i.c" - -#define NUM2INTEGRAL scm_num2ushort -#define INTEGRAL2NUM scm_ushort2num -#define INTEGRAL2BIG scm_i_ushort2big -#define UNSIGNED 1 -#define ITYPE unsigned short -#define SIZEOF_ITYPE SIZEOF_UNSIGNED_SHORT -#include "libguile/num2integral.i.c" - -#define NUM2INTEGRAL scm_num2int -#define INTEGRAL2NUM scm_int2num -#define INTEGRAL2BIG scm_i_int2big -#define UNSIGNED 0 -#define ITYPE int -#define SIZEOF_ITYPE SIZEOF_INT -#include "libguile/num2integral.i.c" - -#define NUM2INTEGRAL scm_num2uint -#define INTEGRAL2NUM scm_uint2num -#define INTEGRAL2BIG scm_i_uint2big -#define UNSIGNED 1 -#define ITYPE unsigned int -#define SIZEOF_ITYPE SIZEOF_UNSIGNED_INT -#include "libguile/num2integral.i.c" - -#define NUM2INTEGRAL scm_num2long -#define INTEGRAL2NUM scm_long2num -#define INTEGRAL2BIG scm_i_long2big -#define UNSIGNED 0 -#define ITYPE long -#define SIZEOF_ITYPE SIZEOF_LONG -#include "libguile/num2integral.i.c" - -#define NUM2INTEGRAL scm_num2ulong -#define INTEGRAL2NUM scm_ulong2num -#define INTEGRAL2BIG scm_i_ulong2big -#define UNSIGNED 1 -#define ITYPE unsigned long -#define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG -#include "libguile/num2integral.i.c" - -#define NUM2INTEGRAL scm_num2ptrdiff -#define INTEGRAL2NUM scm_ptrdiff2num -#define INTEGRAL2BIG scm_i_ptrdiff2big -#define UNSIGNED 0 -#define ITYPE scm_t_ptrdiff -#define UNSIGNED_ITYPE size_t -#define SIZEOF_ITYPE SCM_SIZEOF_SCM_T_PTRDIFF -#include "libguile/num2integral.i.c" - -#define NUM2INTEGRAL scm_num2size -#define INTEGRAL2NUM scm_size2num -#define INTEGRAL2BIG scm_i_size2big -#define UNSIGNED 1 -#define ITYPE size_t -#define SIZEOF_ITYPE SIZEOF_SIZE_T -#include "libguile/num2integral.i.c" - -#if SCM_SIZEOF_LONG_LONG != 0 - -#ifndef ULONG_LONG_MAX -#define ULONG_LONG_MAX (~0ULL) -#endif + if (mpz_sgn (SCM_I_BIG_MPZ (val)) < 0) + return 0; -#define NUM2INTEGRAL scm_num2long_long -#define INTEGRAL2NUM scm_long_long2num -#define INTEGRAL2BIG scm_i_long_long2big -#define UNSIGNED 0 -#define ITYPE long long -#define SIZEOF_ITYPE SIZEOF_LONG_LONG -#include "libguile/num2integral.i.c" - -#define NUM2INTEGRAL scm_num2ulong_long -#define INTEGRAL2NUM scm_ulong_long2num -#define INTEGRAL2BIG scm_i_ulong_long2big -#define UNSIGNED 1 -#define ITYPE unsigned long long -#define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG_LONG -#include "libguile/num2integral.i.c" - -#endif /* SCM_SIZEOF_LONG_LONG != 0 */ - -#define NUM2FLOAT scm_num2float -#define FLOAT2NUM scm_float2num -#define FTYPE float -#include "libguile/num2float.i.c" - -#define NUM2FLOAT scm_num2double -#define FLOAT2NUM scm_double2num -#define FTYPE double -#include "libguile/num2float.i.c" - -#ifdef GUILE_DEBUG - -#ifndef SIZE_MAX -#define SIZE_MAX ((size_t) (-1)) -#endif -#ifndef PTRDIFF_MIN -#define PTRDIFF_MIN \ - ((scm_t_ptrdiff) ((scm_t_ptrdiff) 1 \ - << ((sizeof (scm_t_ptrdiff) * SCM_CHAR_BIT) - 1))) -#endif -#ifndef PTRDIFF_MAX -#define PTRDIFF_MAX (~ PTRDIFF_MIN) -#endif + if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2) + > CHAR_BIT*sizeof (scm_t_uintmax)) + return 0; + + mpz_export (&n, &count, 1, sizeof (scm_t_uintmax), 0, 0, + SCM_I_BIG_MPZ (val)); -#define CHECK(type, v) \ - do { \ - if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \ - abort (); \ - } while (0); + return n >= min && n <= max; + } + } + else + return 0; +} static void -check_sanity () -{ - CHECK (short, 0); - CHECK (ushort, 0U); - CHECK (int, 0); - CHECK (uint, 0U); - CHECK (long, 0L); - CHECK (ulong, 0UL); - CHECK (size, 0); - CHECK (ptrdiff, 0); - - CHECK (short, -1); - CHECK (int, -1); - CHECK (long, -1L); - CHECK (ptrdiff, -1); - - CHECK (short, SHRT_MAX); - CHECK (short, SHRT_MIN); - CHECK (ushort, USHRT_MAX); - CHECK (int, INT_MAX); - CHECK (int, INT_MIN); - CHECK (uint, UINT_MAX); - CHECK (long, LONG_MAX); - CHECK (long, LONG_MIN); - CHECK (ulong, ULONG_MAX); - CHECK (size, SIZE_MAX); - CHECK (ptrdiff, PTRDIFF_MAX); - CHECK (ptrdiff, PTRDIFF_MIN); - -#if SCM_SIZEOF_LONG_LONG != 0 - CHECK (long_long, 0LL); - CHECK (ulong_long, 0ULL); - CHECK (long_long, -1LL); - CHECK (long_long, LLONG_MAX); - CHECK (long_long, LLONG_MIN); - CHECK (ulong_long, ULLONG_MAX); +scm_i_range_error (SCM bad_val, SCM min, SCM max) +{ + scm_error (scm_out_of_range_key, + NULL, + "Value out of range ~S to ~S: ~S", + scm_list_3 (min, max, bad_val), + scm_list_1 (bad_val)); +} + +#define TYPE scm_t_intmax +#define TYPE_MIN min +#define TYPE_MAX max +#define SIZEOF_TYPE 0 +#define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg) +#include "libguile/conv-integer.i.c" + +#define TYPE scm_t_uintmax +#define TYPE_MIN min +#define TYPE_MAX max +#define SIZEOF_TYPE 0 +#define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg) +#include "libguile/conv-uinteger.i.c" + +#define TYPE scm_t_int8 +#define TYPE_MIN SCM_T_INT8_MIN +#define TYPE_MAX SCM_T_INT8_MAX +#define SIZEOF_TYPE 1 +#define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg) +#include "libguile/conv-integer.i.c" + +#define TYPE scm_t_uint8 +#define TYPE_MIN 0 +#define TYPE_MAX SCM_T_UINT8_MAX +#define SIZEOF_TYPE 1 +#define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg) +#include "libguile/conv-uinteger.i.c" + +#define TYPE scm_t_int16 +#define TYPE_MIN SCM_T_INT16_MIN +#define TYPE_MAX SCM_T_INT16_MAX +#define SIZEOF_TYPE 2 +#define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg) +#include "libguile/conv-integer.i.c" + +#define TYPE scm_t_uint16 +#define TYPE_MIN 0 +#define TYPE_MAX SCM_T_UINT16_MAX +#define SIZEOF_TYPE 2 +#define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg) +#include "libguile/conv-uinteger.i.c" + +#define TYPE scm_t_int32 +#define TYPE_MIN SCM_T_INT32_MIN +#define TYPE_MAX SCM_T_INT32_MAX +#define SIZEOF_TYPE 4 +#define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg) +#include "libguile/conv-integer.i.c" + +#define TYPE scm_t_uint32 +#define TYPE_MIN 0 +#define TYPE_MAX SCM_T_UINT32_MAX +#define SIZEOF_TYPE 4 +#define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg) +#include "libguile/conv-uinteger.i.c" + +#if SCM_HAVE_T_INT64 + +#define TYPE scm_t_int64 +#define TYPE_MIN SCM_T_INT64_MIN +#define TYPE_MAX SCM_T_INT64_MAX +#define SIZEOF_TYPE 8 +#define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg) +#include "libguile/conv-integer.i.c" + +#define TYPE scm_t_uint64 +#define TYPE_MIN 0 +#define TYPE_MAX SCM_T_UINT64_MAX +#define SIZEOF_TYPE 8 +#define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg) +#include "libguile/conv-uinteger.i.c" + #endif + +void +scm_to_mpz (SCM val, mpz_t rop) +{ + if (SCM_I_INUMP (val)) + mpz_set_si (rop, SCM_I_INUM (val)); + else if (SCM_BIGP (val)) + mpz_set (rop, SCM_I_BIG_MPZ (val)); + else + scm_wrong_type_arg_msg (NULL, 0, val, "exact integer"); } -#undef CHECK +SCM +scm_from_mpz (mpz_t val) +{ + return scm_i_mpz2num (val); +} -#define CHECK \ - scm_internal_catch (SCM_BOOL_T, check_body, &data, check_handler, &data); \ - if (!SCM_FALSEP (data)) abort(); +int +scm_is_real (SCM val) +{ + return scm_is_true (scm_real_p (val)); +} -static SCM -check_body (void *data) +int +scm_is_rational (SCM val) { - SCM num = *(SCM *) data; - scm_num2ulong (num, 1, NULL); - - return SCM_UNSPECIFIED; + return scm_is_true (scm_rational_p (val)); } -static SCM -check_handler (void *data, SCM tag, SCM throw_args) +double +scm_to_double (SCM val) +{ + if (SCM_I_INUMP (val)) + return SCM_I_INUM (val); + else if (SCM_BIGP (val)) + return scm_i_big2dbl (val); + else if (SCM_FRACTIONP (val)) + return scm_i_fraction2double (val); + else if (SCM_REALP (val)) + return SCM_REAL_VALUE (val); + else + scm_wrong_type_arg_msg (NULL, 0, val, "real number"); +} + +SCM +scm_from_double (double val) { - SCM *num = (SCM *) data; - *num = SCM_BOOL_F; + SCM z = scm_double_cell (scm_tc16_real, 0, 0, 0); + SCM_REAL_VALUE (z) = val; + return z; +} - return SCM_UNSPECIFIED; +#if SCM_ENABLE_DISCOURAGED == 1 + +float +scm_num2float (SCM num, unsigned long int pos, const char *s_caller) +{ + if (SCM_BIGP (num)) + { + float res = mpz_get_d (SCM_I_BIG_MPZ (num)); + if (!xisinf (res)) + return res; + else + scm_out_of_range (NULL, num); + } + else + return scm_to_double (num); } - -SCM_DEFINE (scm_sys_check_number_conversions, "%check-number-conversions", 0, 0, 0, - (void), - "Number conversion sanity checking.") -#define FUNC_NAME s_scm_sys_check_number_conversions -{ - SCM data = SCM_MAKINUM (-1); - CHECK; - data = scm_int2num (INT_MIN); - CHECK; - data = scm_ulong2num (ULONG_MAX); - data = scm_difference (SCM_INUM0, data); - CHECK; - data = scm_ulong2num (ULONG_MAX); - data = scm_sum (SCM_MAKINUM (1), data); data = scm_difference (SCM_INUM0, data); - CHECK; - data = scm_int2num (-10000); data = scm_product (data, data); data = scm_product (data, data); - CHECK; - - return SCM_UNSPECIFIED; + +double +scm_num2double (SCM num, unsigned long int pos, const char *s_caller) +{ + if (SCM_BIGP (num)) + { + double res = mpz_get_d (SCM_I_BIG_MPZ (num)); + if (!xisinf (res)) + return res; + else + scm_out_of_range (NULL, num); + } + else + return scm_to_double (num); } -#undef FUNC_NAME #endif +int +scm_is_complex (SCM val) +{ + return scm_is_true (scm_complex_p (val)); +} + +double +scm_c_real_part (SCM z) +{ + if (SCM_COMPLEXP (z)) + return SCM_COMPLEX_REAL (z); + else + { + /* Use the scm_real_part to get proper error checking and + dispatching. + */ + return scm_to_double (scm_real_part (z)); + } +} + +double +scm_c_imag_part (SCM z) +{ + if (SCM_COMPLEXP (z)) + return SCM_COMPLEX_IMAG (z); + else + { + /* Use the scm_imag_part to get proper error checking and + dispatching. The result will almost always be 0.0, but not + always. + */ + return scm_to_double (scm_imag_part (z)); + } +} + +double +scm_c_magnitude (SCM z) +{ + return scm_to_double (scm_magnitude (z)); +} + +double +scm_c_angle (SCM z) +{ + return scm_to_double (scm_angle (z)); +} + +int +scm_is_number (SCM z) +{ + return scm_is_true (scm_number_p (z)); +} + void scm_init_numbers () { - abs_most_negative_fixnum = scm_i_long2big (- SCM_MOST_NEGATIVE_FIXNUM); - scm_permanent_object (abs_most_negative_fixnum); + int i; mpz_init_set_si (z_negative_one, -1); @@ -4246,35 +5981,27 @@ scm_init_numbers () * using these values, remember the two rules of program optimization: * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */ scm_c_define ("most-positive-fixnum", - SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)); + SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)); scm_c_define ("most-negative-fixnum", - SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)); + SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)); scm_add_feature ("complex"); scm_add_feature ("inexact"); - scm_flo0 = scm_make_real (0.0); -#ifdef DBL_DIG - scm_dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG; -#else - { /* determine floating point precision */ - double f = 0.1; - double fsum = 1.0 + f; - while (fsum != 1.0) { - if (++scm_dblprec > 20) { - fsum = 1.0; - } else { - f /= 10.0; - fsum = f + 1.0; - } - } - scm_dblprec = scm_dblprec - 1; - } -#endif /* DBL_DIG */ + scm_flo0 = scm_from_double (0.0); -#ifdef GUILE_DEBUG - check_sanity (); + /* 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 - + + exactly_one_half = scm_permanent_object (scm_divide (SCM_I_MAKINUM (1), + SCM_I_MAKINUM (2))); #include "libguile/numbers.x" }