X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/9c4443d38c72daafc7ac10656f04929618e6d4ed..63947c7ad3431e4d99eb73fae84dfd8207d0e6a2:/libguile/numbers.c?ds=sidebyside diff --git a/libguile/numbers.c b/libguile/numbers.c index 602682df6..c80b77c60 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 Free Software Foundation, Inc. * * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories * and Bellcore. See scm_divide. @@ -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 @@ -47,6 +51,7 @@ #include #include #include + #include "libguile/_scm.h" #include "libguile/feature.h" #include "libguile/ports.h" @@ -58,6 +63,8 @@ #include "libguile/numbers.h" #include "libguile/deprecation.h" +#include "libguile/eq.h" + /* @@ -73,9 +80,10 @@ #define SCM_I_NUMTAG(x) \ (SCM_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 +91,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) @@ -105,15 +113,49 @@ isinf (double x) #endif #endif - -static SCM abs_most_negative_fixnum; +/* 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) +#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 const char s_bignum[] = "bignum"; +static mpz_t z_negative_one; -SCM_C_INLINE SCM + + +SCM_C_INLINE_KEYWORD SCM scm_i_mkbig () { /* Return a newly created bignum. */ @@ -122,17 +164,18 @@ scm_i_mkbig () return z; } -SCM_C_INLINE static SCM +SCM_C_INLINE_KEYWORD static 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 */ @@ -142,7 +185,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 */ @@ -151,15 +194,101 @@ 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_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. it truncates towards zero), then adjust to get the closest double by + examining the next lower bit and adding 1 if necessary. + + Note that 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 is done on the absolute value of the mpz_t, which means we + must use mpz_getlimbn. mpz_tstbit is not right, it treats negatives as + twos complement. + + Prior to GMP 4.2, the rounding done by mpz_get_d was unspecified. It + happened to follow the hardware rounding mode, but on the absolute value + of its operand. This is not what we want, so we put the high + DBL_MANT_DIG bits into a temporary. This extra init/clear is a slowdown, + but doesn't matter too much since it's only for older GMP. */ + +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 __GNU_MP_VERSION < 4 \ + || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR < 2) + { + /* GMP prior to 4.2, force truncate 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 + /* GMP 4.2 and up */ + 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 */ @@ -173,15 +302,150 @@ scm_i_normbig (SCM b) 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_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); + +SCM +scm_make_ratio (SCM numerator, SCM denominator) +#define FUNC_NAME "make-ratio" +{ + /* First make sure the arguments are proper. + */ + if (SCM_INUMP (denominator)) + { + if (SCM_EQ_P (denominator, SCM_INUM0)) + scm_num_overflow ("make-ratio"); + if (SCM_EQ_P (denominator, SCM_MAKINUM(1))) + return numerator; + } + else + { + if (!(SCM_BIGP(denominator))) + SCM_WRONG_TYPE_ARG (2, denominator); + } + if (!SCM_INUMP (numerator) && !SCM_BIGP (numerator)) + SCM_WRONG_TYPE_ARG (1, numerator); + + /* Then flip signs so that the denominator is positive. + */ + if (SCM_NFALSEP (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_INUMP (numerator)) + { + long x = SCM_INUM (numerator); + if (SCM_EQ_P (numerator, SCM_INUM0)) + return SCM_INUM0; + if (SCM_INUMP (denominator)) + { + long y; + y = SCM_INUM (denominator); + if (x == y) + return SCM_MAKINUM(1); + if ((x % y) == 0) + return SCM_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_MAKINUM(-1); + } + } + else if (SCM_BIGP (numerator)) + { + if (SCM_INUMP (denominator)) + { + long yy = SCM_INUM (denominator); + if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator), yy)) + return scm_divide (numerator, denominator); + } + else + { + if (SCM_EQ_P (numerator, denominator)) + return SCM_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_EQ_P (divisor, SCM_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_num2dbl (scm_divide2real (SCM_FRACTION_NUMERATOR (z), + SCM_FRACTION_DENOMINATOR (z)), + "fraction2real"); +} + 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_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 @@ -192,18 +456,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_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_FALSEP (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 @@ -214,59 +491,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_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_FALSEP (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.") #define FUNC_NAME s_scm_inf_p { - if (SCM_REALP (n)) { + if (SCM_REALP (n)) return SCM_BOOL (xisinf (SCM_REAL_VALUE (n))); - } else if (SCM_COMPLEXP (n)) { + else if (SCM_COMPLEXP (n)) return SCM_BOOL (xisinf (SCM_COMPLEX_REAL (n)) || xisinf (SCM_COMPLEX_IMAG (n))); - } else { + else return SCM_BOOL_F; - } } #undef FUNC_NAME @@ -276,14 +541,13 @@ SCM_DEFINE (scm_nan_p, "nan?", 1, 0, 0, "otherwise.") #define FUNC_NAME s_scm_nan_p { - if (SCM_REALP (n)) { + if (SCM_REALP (n)) return SCM_BOOL (xisnan (SCM_REAL_VALUE (n))); - } else if (SCM_COMPLEXP (n)) { + else if (SCM_COMPLEXP (n)) return SCM_BOOL (xisnan (SCM_COMPLEX_REAL (n)) || xisnan (SCM_COMPLEX_IMAG (n))); - } else { + else return SCM_BOOL_F; - } } #undef FUNC_NAME @@ -301,10 +565,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 @@ -323,7 +592,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 @@ -354,7 +627,7 @@ 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; @@ -369,27 +642,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_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)) + { + /* 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_make_real (-xx); + else + return x; + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (x)))) + return x; + return scm_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 @@ -400,63 +688,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_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); + } } - } - } 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_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_MAKINUM (-1); + } + else + return SCM_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_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); + } + 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); @@ -469,56 +772,70 @@ 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_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)) { - /* Special case: x == fixnum-min && y == abs (fixnum-min) */ - return SCM_MAKINUM (0); + if ((SCM_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_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); - } -} - - -SCM_GPROC (s_modulo, "modulo", 2, 0, 0, scm_modulo, g_modulo); + 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); + } + 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" * "(modulo 13 4) @result{} 1\n" @@ -528,109 +845,125 @@ 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_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)); + { + 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_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)) + { + { + 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); @@ -641,7 +974,7 @@ 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)) { @@ -652,52 +985,49 @@ scm_gcd (SCM x, SCM 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_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); @@ -707,20 +1037,26 @@ scm_gcd (SCM x, SCM y) if (SCM_INUMP (y)) { unsigned long result; - long yy = SCM_INUM (y); - if (yy < 0) yy = -yy; + long yy; + big_inum: + yy = SCM_INUM (y); + if (yy == 0) + return scm_abs (x); + 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_MAKINUM (result) + : scm_ulong2num (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 @@ -843,62 +1179,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_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); + if (SCM_INUMP (n1)) + { 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_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 { + 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); + } + else SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); - } } #undef FUNC_NAME @@ -915,54 +1261,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); + if (SCM_INUMP (n1)) + { 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_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 { + 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); + } + else SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); - } } #undef FUNC_NAME @@ -981,53 +1337,62 @@ 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); + if (SCM_INUMP (n1)) + { 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_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 { + 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); + } + else SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); - } } #undef FUNC_NAME @@ -1043,49 +1408,59 @@ 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); + if (SCM_INUMP (j)) + { 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_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 { + 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); + } + else SCM_WRONG_TYPE_ARG (SCM_ARG1, j); - } } #undef FUNC_NAME @@ -1107,22 +1482,27 @@ SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0, 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_INUMP (j)) + { + /* bits above what's in an inum follow the sign bit */ + iindex = min (iindex, SCM_LONG_BIT - 1); + 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 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" @@ -1133,7 +1513,140 @@ 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_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_MAKINUM (~ SCM_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_INUMP (in)) + mpz_set_si (out, SCM_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_EQ_P (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 @@ -1166,7 +1679,6 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, 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; } @@ -1178,7 +1690,7 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, 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); + mpz_set_d (SCM_I_BIG_MPZ (z_i2), r); i2_is_big = 1; } else @@ -1200,12 +1712,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)) @@ -1238,20 +1748,24 @@ 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 { @@ -1269,6 +1783,8 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0, */ SCM div = scm_integer_expt (SCM_MAKINUM (2), SCM_MAKINUM (-bits_to_shift)); + + /* scm_quotient assumes its arguments are integers, but it's legal to (ash 1/2 -1) */ if (SCM_FALSEP (scm_negative_p (n))) return scm_quotient (n, div); else @@ -1296,56 +1812,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; + unsigned long int istart, iend, bits; SCM_VALIDATE_INUM_MIN_COPY (2, start,0, istart); SCM_VALIDATE_INUM_MIN_COPY (3, end, 0, iend); 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_INUMP (n)) + { + long int in = SCM_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_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_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n), istart)); + } + else + { + /* ENHANCE-ME: It'd be nice not to allocate a new bignum when + bits= 0) + count = mpz_popcount (SCM_I_BIG_MPZ (n)); else - { - count = mpz_popcount (SCM_I_BIG_MPZ (n)); - scm_remember_upto_here_1 (n); - } + count = mpz_hamdist (SCM_I_BIG_MPZ (n), z_negative_one); + scm_remember_upto_here_1 (n); return SCM_MAKINUM (count); } else @@ -1424,43 +1939,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)) { - size_t size = mpz_sizeinbase (SCM_I_BIG_MPZ (n), 2); - scm_remember_upto_here_1 (n); - return SCM_MAKINUM (size); - } else { + 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 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) { @@ -1470,7 +2047,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;} */ } @@ -1496,10 +2072,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++] = '.'; @@ -1507,10 +2088,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++] = '.'; @@ -1518,25 +2099,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; @@ -1563,15 +2146,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++] = '.'; } @@ -1606,26 +2189,25 @@ 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; } } return ch; } - static size_t -iflo2str (SCM flt, char *str) +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 = idbl2str (SCM_COMPLEX_REAL (flt), str); + i = idbl2str (SCM_COMPLEX_REAL (flt), str, radix); if (SCM_COMPLEX_IMAG (flt) != 0.0) { double imag = SCM_COMPLEX_IMAG (flt); @@ -1633,7 +2215,7 @@ iflo2str (SCM flt, char *str) NaN. They will provide their own sign. */ if (0 <= imag && !xisinf (imag) && !xisnan (imag)) str[i++] = '+'; - i += idbl2str (imag, &str[i]); + i += idbl2str (imag, &str[i], radix); str[i++] = 'i'; } } @@ -1673,7 +2255,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" @@ -1683,29 +2264,42 @@ 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 + { + 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)); + } - 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_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_FRACTIONP (n)) + { + scm_i_fraction_reduce (n); + return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n), radix), + scm_mem2string ("/", 1), + scm_number_to_string (SCM_FRACTION_DENOMINATOR (n), radix))); + } + else if (SCM_INEXACTP (n)) + { + char num_buf [FLOBUFLEN]; + return scm_mem2string (num_buf, iflo2str (n, num_buf, base)); + } + else SCM_WRONG_TYPE_ARG (1, n); - } } #undef FUNC_NAME @@ -1717,15 +2311,27 @@ 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; } 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), port); + scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port); + return !0; +} + +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_STRING_CHARS (str), SCM_STRING_LENGTH (str), port); + scm_remember_upto_here_1 (str); return !0; } @@ -1771,7 +2377,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, @@ -1789,7 +2398,7 @@ 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) @@ -1800,7 +2409,7 @@ mem2uinteger (const char* mem, size_t len, unsigned int *p_idx, while (idx != len) { char c = mem[idx]; - if (isxdigit (c)) + if (isxdigit ((int) (unsigned char) c)) { if (hash_seen) break; @@ -1877,7 +2486,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)) { if (x == INEXACT) return SCM_BOOL_F; @@ -1958,7 +2567,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++; @@ -1966,7 +2575,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) @@ -1988,7 +2597,7 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, 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; @@ -2030,8 +2639,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; @@ -2044,7 +2653,7 @@ 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, @@ -2071,7 +2680,8 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, if (SCM_FALSEP (divisor)) return SCM_BOOL_F; - result = scm_divide (uinteger, divisor); + /* both are int/big here, I assume */ + result = scm_make_ratio (uinteger, divisor); } else if (radix == 10) { @@ -2305,7 +2915,6 @@ scm_i_mem2number (const char* mem, size_t len, unsigned int default_radix) { case EXACT: if (SCM_INEXACTP (result)) - /* FIXME: This may change the value. */ return scm_inexact_to_exact (result); else return result; @@ -2346,8 +2955,8 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, 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); + SCM_STRING_LENGTH (string), + base); return scm_return_first (answer, string); } #undef FUNC_NAME @@ -2369,23 +2978,24 @@ scm_make_real (double x) SCM scm_make_complex (double x, double y) { - if (y == 0.0) { + 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; - } + else + { + SCM z; + SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (sizeof (scm_t_complex), + "complex")); + SCM_COMPLEX_REAL (z) = x; + SCM_COMPLEX_IMAG (z) = y; + return z; + } } 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); } @@ -2403,6 +3013,19 @@ scm_complex_equalp (SCM x, SCM 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_FALSEP (scm_equal_p (SCM_FRACTION_NUMERATOR (x), + SCM_FRACTION_NUMERATOR (y))) + || SCM_FALSEP (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); @@ -2425,33 +3048,41 @@ SCM_DEFINE (scm_number_p, "complex?", 1, 0, 0, #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_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_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_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 @@ -2487,7 +3118,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 @@ -2497,81 +3132,176 @@ 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 = mpz_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; - cmp = mpz_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 = mpz_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; - cmp = mpz_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_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 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_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 if (SCM_FRACTIONP (y)) + return SCM_BOOL_F; + 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 if (SCM_FRACTIONP (y)) + { + double xx = SCM_REAL_VALUE (x); + if (xisnan (xx)) + return SCM_BOOL_F; + if (xisinf (xx)) + return SCM_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_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 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_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_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_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_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." @@ -2579,63 +3309,137 @@ SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p); 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); + again: + 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 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_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 = mpz_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 = mpz_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_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 if (SCM_FRACTIONP (y)) + goto int_frac; + 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); - } -} - - -SCM_GPROC1 (s_scm_gr_p, ">", scm_tc7_rpsubr, scm_gr_p, g_gr_p); -/* "Return @code{#t} if the list of parameters is monotonically\n" - * "decreasing." - */ -#define FUNC_NAME s_scm_gr_p -SCM -scm_gr_p (SCM x, SCM y) -{ - if (!SCM_NUMBERP (x)) + 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 if (SCM_FRACTIONP (y)) + { + double xx = SCM_REAL_VALUE (x); + if (xisnan (xx)) + return SCM_BOOL_F; + if (xisinf (xx)) + return SCM_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_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_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); +} + + +SCM_GPROC1 (s_scm_gr_p, ">", scm_tc7_rpsubr, scm_gr_p, g_gr_p); +/* "Return @code{#t} if the list of parameters is monotonically\n" + * "decreasing." + */ +#define FUNC_NAME s_scm_gr_p +SCM +scm_gr_p (SCM x, SCM y) +{ + if (!SCM_NUMBERP (x)) SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG1, FUNC_NAME); else if (!SCM_NUMBERP (y)) SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG2, FUNC_NAME); @@ -2692,18 +3496,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)) { + if (SCM_INUMP (z)) return SCM_BOOL (SCM_EQ_P (z, SCM_INUM0)); - } else if (SCM_BIGP (z)) { + else if (SCM_BIGP (z)) return SCM_BOOL_F; - } else if (SCM_REALP (z)) { + else if (SCM_REALP (z)) return SCM_BOOL (SCM_REAL_VALUE (z) == 0.0); - } else if (SCM_COMPLEXP (z)) { + else if (SCM_COMPLEXP (z)) return SCM_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); - } } @@ -2714,17 +3519,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)) { + 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)) { + 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 { + 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); - } } @@ -2735,83 +3543,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)) { + 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)) { + 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 { + 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_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; - return (z <= SCM_REAL_VALUE (y)) ? y : scm_make_real (z); - } 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)) { - int cmp = mpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y)); - 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); - return (SCM_REAL_VALUE (x) < z) ? scm_make_real (z) : x; - } else if (SCM_BIGP (y)) { - int cmp = mpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x)); - scm_remember_upto_here_1 (y); - return (cmp < 0) ? x : y; - } else if (SCM_REALP (y)) { - return (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y)) ? y : x; - } else { - SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, 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 if (SCM_FRACTIONP (y)) + { + use_less: + return (SCM_FALSEP (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_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_make_real (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_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)) + { + 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_make_real (yy) : x; + } + else + SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_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_make_real (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); - } } @@ -2821,63 +3704,129 @@ 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_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; - 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)) { - int cmp = mpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y)); - 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); - return (SCM_REAL_VALUE (x) <= z) ? x : scm_make_real (z); - } else if (SCM_BIGP (y)) { - int cmp = mpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x)); - scm_remember_upto_here_1 (y); - return (cmp < 0) ? y : x; - } else if (SCM_REALP (y)) { - return (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y)) ? x : y; - } else { - SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, 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 if (SCM_FRACTIONP (y)) + { + use_less: + return (SCM_FALSEP (scm_less_p (x, y)) ? y : x); + } + else + SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min); } - } else { + 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)) + { + /* 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) + 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 && (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); + 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 if (SCM_FRACTIONP (y)) + /* a - b/c = (ac - b) / c */ + return scm_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 (x)) { - if (SCM_INUMP (y)) { - /* big-x - inum-y */ - long yy = SCM_INUM (y); - int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x)); + 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)); - scm_remember_upto_here_1 (x); - if (sgn_x == 0) - return SCM_FIXABLE (-yy) ? SCM_MAKINUM (-yy) : scm_long2num (-yy); - else - { - SCM result = scm_i_mkbig (); + scm_remember_upto_here_1 (x); + if (sgn_x == 0) + return SCM_FIXABLE (-yy) ? SCM_MAKINUM (-yy) : scm_long2num (-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_make_real (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_make_complex (real_part, - SCM_COMPLEX_IMAG (y)); + } + else if (SCM_FRACTIONP (y)) + return scm_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_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 if (SCM_FRACTIONP (y)) + return scm_make_real (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_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 if (SCM_FRACTIONP (y)) + return scm_make_complex (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_INUMP (y)) + /* a/b - c = (a - cb) / b */ + return scm_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_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_make_real (scm_i_fraction2double (x) - SCM_REAL_VALUE (y)); + else if (SCM_COMPLEXP (y)) + return scm_make_complex (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_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 @@ -3178,128 +4253,194 @@ 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_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_INUMP (x)) + { + long xx; - intbig: - xx = SCM_INUM (x); + intbig: + xx = SCM_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_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 if (SCM_FRACTIONP (y)) + return scm_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_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 if (SCM_FRACTIONP (y)) + return scm_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_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 if (SCM_FRACTIONP (y)) + return scm_make_real (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_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 (x), + z * SCM_COMPLEX_IMAG (x)); + } + 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 if (SCM_FRACTIONP (y)) + { + double yy = scm_i_fraction2double (y); + return scm_make_complex (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_INUMP (y)) + return scm_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)), + SCM_FRACTION_DENOMINATOR (x)); + else if (SCM_BIGP (y)) + return scm_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)), + SCM_FRACTION_DENOMINATOR (x)); + else if (SCM_REALP (y)) + return scm_make_real (scm_i_fraction2double (x) * SCM_REAL_VALUE (y)); + else if (SCM_COMPLEXP (y)) + { + double xx = scm_i_fraction2double (x); + return scm_make_complex (xx * SCM_COMPLEX_REAL (y), + xx * SCM_COMPLEX_IMAG (y)); + } + else if (SCM_FRACTIONP (y)) + /* a/b * c/d = ac / bd */ + return scm_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)) { + 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)) { + 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 { + else if (SCM_FRACTIONP (a)) + return scm_i_fraction2double (a); + else SCM_WRONG_TYPE_ARG (SCM_ARGn, a); - } } #undef FUNC_NAME @@ -3341,356 +4482,641 @@ 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_INUMP (x)) + { + long xx = SCM_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_make_real (1.0 / (double) xx); + else return scm_make_ratio (SCM_MAKINUM(1), x); + } + } + else if (SCM_BIGP (x)) + { + if (inexact) + return scm_make_real (1.0 / scm_i_big2dbl (x)); + else return scm_make_ratio (SCM_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_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 if (SCM_FRACTIONP (x)) + return scm_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_INUMP (x)) + { + long xx = SCM_INUM (x); + if (SCM_INUMP (y)) + { + long yy = SCM_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_make_real ((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_make_real ((double) xx / (double) yy); + else return scm_make_ratio (x, y); + } + else + { + long z = xx / yy; + if (SCM_FIXABLE (z)) + return SCM_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_make_real ((double) xx / scm_i_big2dbl (y)); + else return scm_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_make_real ((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 (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); + } + } + } + else if (SCM_FRACTIONP (y)) + /* a / b/c = ac / b */ + return scm_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_INUMP (y)) + { + long int yy = SCM_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_make_real (scm_i_big2dbl (x) / (double) yy); + else return scm_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 + { + 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_make_real (dbx / dby); + } + else return scm_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 +#endif + return scm_make_real (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_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_INUMP (y)) + { + long int yy = SCM_INUM (y); +#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO + if (yy == 0) + scm_num_overflow (s_divide); + else #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); + 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); #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_make_real (rx / yy); + } + else if (SCM_COMPLEXP (y)) + { + a = rx; + goto complex_div; + } + else if (SCM_FRACTIONP (y)) + return scm_make_real (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_INUMP (y)) + { + long int yy = SCM_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); + { + 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); #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_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 if (SCM_FRACTIONP (y)) + { + double yy = scm_i_fraction2double (y); + return scm_make_complex (rx / yy, ix / yy); + } else + SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); + } + else if (SCM_FRACTIONP (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); + 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); + return scm_make_ratio (SCM_FRACTION_NUMERATOR (x), + scm_product (SCM_FRACTION_DENOMINATOR (x), y)); + } + else if (SCM_BIGP (y)) + { + return scm_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 + if (yy == 0.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_make_real (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_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_cxr, (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_cxr, (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_cxr, (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_cxr, (SCM (*)()) scm_truncate, g_truncate); -/* "Round the inexact number @var{x} towards zero." +/* XXX - eventually, we should remove this definition of scm_round and + rename scm_round_number to scm_round. Likewise for scm_truncate + and scm_truncate_number. */ + double scm_truncate (double x) { +#if HAVE_TRUNC + return trunc (x); +#else +#define trunc scm_truncate if (x < 0.0) return -floor (-x); return floor (x); +#endif } +/* scm_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. */ -SCM_GPROC1 (s_round, "round", scm_tc7_cxr, (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) { - double plus_half = x + 0.5; - double result = floor (plus_half); + double plus_half, result; + + if (x == floor (x)) + return x; + + plus_half = x + 0.5; + 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; + 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_FALSEP (scm_negative_p (x))) + return scm_floor (x); + else + return scm_ceiling (x); +} +#undef FUNC_NAME -SCM_GPROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor, g_i_floor); -/* "Round the number @var{x} towards minus infinity." - */ -SCM_GPROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil, g_i_ceil); -/* "Round the number @var{x} towards infinity." - */ -SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)()) sqrt, g_i_sqrt); +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 +{ + SCM plus_half = scm_sum (x, exactly_one_half); + SCM result = scm_floor (plus_half); + /* Adjust so that the scm_round is towards even. */ + if (!SCM_FALSEP (scm_num_eq_p (plus_half, result)) + && !SCM_FALSEP (scm_odd_p (result))) + return scm_difference (result, SCM_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_INUMP (x) || SCM_BIGP (x)) + return x; + else if (SCM_REALP (x)) + return scm_make_real (floor (SCM_REAL_VALUE (x))); + else if (SCM_FRACTIONP (x)) + { + SCM q = scm_quotient (SCM_FRACTION_NUMERATOR (x), + SCM_FRACTION_DENOMINATOR (x)); + if (SCM_FALSEP (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_MAKINUM (1)); + } + } + else + SCM_WTA_DISPATCH_1 (g_scm_floor, x, 1, s_scm_floor); +} +#undef FUNC_NAME + +SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0, + (SCM x), + "Round the number @var{x} towards infinity.") +#define FUNC_NAME s_scm_ceiling +{ + if (SCM_INUMP (x) || SCM_BIGP (x)) + return x; + else if (SCM_REALP (x)) + return scm_make_real (ceil (SCM_REAL_VALUE (x))); + else if (SCM_FRACTIONP (x)) + { + SCM q = scm_quotient (SCM_FRACTION_NUMERATOR (x), + SCM_FRACTION_DENOMINATOR (x)); + if (SCM_FALSEP (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_MAKINUM (1)); + } + } + else + SCM_WTA_DISPATCH_1 (g_scm_ceiling, x, 1, s_scm_ceiling); +} +#undef FUNC_NAME + +SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_dsubr, (SCM (*)()) sqrt, g_i_sqrt); /* "Return the square root of the real number @var{x}." */ -SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_cxr, (SCM (*)()) fabs, g_i_abs); +SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_dsubr, (SCM (*)()) fabs, g_i_abs); /* "Return the absolute value of the real number @var{x}." */ -SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)()) exp, g_i_exp); +SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_dsubr, (SCM (*)()) exp, g_i_exp); /* "Return the @var{x}th power of e." */ -SCM_GPROC1 (s_i_log, "$log", scm_tc7_cxr, (SCM (*)()) log, g_i_log); +SCM_GPROC1 (s_i_log, "$log", scm_tc7_dsubr, (SCM (*)()) log, g_i_log); /* "Return the natural logarithm of the real number @var{x}." */ -SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_cxr, (SCM (*)()) sin, g_i_sin); +SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_dsubr, (SCM (*)()) sin, g_i_sin); /* "Return the sine of the real number @var{x}." */ -SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_cxr, (SCM (*)()) cos, g_i_cos); +SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_dsubr, (SCM (*)()) cos, g_i_cos); /* "Return the cosine of the real number @var{x}." */ -SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_cxr, (SCM (*)()) tan, g_i_tan); +SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_dsubr, (SCM (*)()) tan, g_i_tan); /* "Return the tangent of the real number @var{x}." */ -SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_cxr, (SCM (*)()) asin, g_i_asin); +SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_dsubr, (SCM (*)()) asin, g_i_asin); /* "Return the arc sine of the real number @var{x}." */ -SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_cxr, (SCM (*)()) acos, g_i_acos); +SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_dsubr, (SCM (*)()) acos, g_i_acos); /* "Return the arc cosine of the real number @var{x}." */ -SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_cxr, (SCM (*)()) atan, g_i_atan); +SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_dsubr, (SCM (*)()) atan, g_i_atan); /* "Return the arc tangent of the real number @var{x}." */ -SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_cxr, (SCM (*)()) sinh, g_i_sinh); +SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_dsubr, (SCM (*)()) sinh, g_i_sinh); /* "Return the hyperbolic sine of the real number @var{x}." */ -SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_cxr, (SCM (*)()) cosh, g_i_cosh); +SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_dsubr, (SCM (*)()) cosh, g_i_cosh); /* "Return the hyperbolic cosine of the real number @var{x}." */ -SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)()) tanh, g_i_tanh); +SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_dsubr, (SCM (*)()) tanh, g_i_tanh); /* "Return the hyperbolic tangent of the real number @var{x}." */ @@ -3707,25 +5133,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)) { + if (SCM_INUMP (x)) xy->x = SCM_INUM (x); - } else if (SCM_BIGP (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)) { + if (SCM_INUMP (y)) xy->y = SCM_INUM (y); - } else if (SCM_BIGP (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); - } } @@ -3778,8 +5206,15 @@ SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0, #define FUNC_NAME s_scm_make_polar { struct dpair xy; + double s, c; scm_two_doubles (x, y, FUNC_NAME, &xy); - return scm_make_complex (xy.x * cos (xy.y), xy.x * sin (xy.y)); +#if HAVE_SINCOS + sincos (xy.y, &s, &c); +#else + s = sin (xy.y); + c = cos (xy.y); +#endif + return scm_make_complex (xy.x * c, xy.x * s); } #undef FUNC_NAME @@ -3790,17 +5225,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_INUMP (z)) return z; - } else if (SCM_BIGP (z)) { + else if (SCM_BIGP (z)) return z; - } else if (SCM_REALP (z)) { + else if (SCM_REALP (z)) return z; - } else if (SCM_COMPLEXP (z)) { + else if (SCM_COMPLEXP (z)) return scm_make_real (SCM_COMPLEX_REAL (z)); - } else { + else if (SCM_FRACTIONP (z)) + return z; + else SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part); - } } @@ -3810,19 +5246,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_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)) { + else if (SCM_COMPLEXP (z)) return scm_make_real (SCM_COMPLEX_IMAG (z)); - } else { + 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_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_INUMP (z)) + return SCM_MAKINUM (1); + else if (SCM_BIGP (z)) + return SCM_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" @@ -3831,32 +5310,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_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; } - } else if (SCM_REALP (z)) { + 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_COMPLEXP (z)) + return scm_make_real (hypot (SCM_COMPLEX_REAL (z), SCM_COMPLEX_IMAG (z))); + else if (SCM_FRACTIONP (z)) + { + if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (z)))) + return z; + return scm_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); - } } @@ -3866,27 +5351,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)) { + /* 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_make_real 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_INUMP (z)) + { + if (SCM_INUM (z) >= 0) + return scm_flo0; + 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_flo0; + } + else if (SCM_REALP (z)) + { + if (SCM_REAL_VALUE (z) >= 0) + return scm_flo0; + else + return scm_make_real (atan2 (0.0, -1.0)); + } + else if (SCM_COMPLEXP (z)) return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z))); - } else { + else if (SCM_FRACTIONP (z)) + { + if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (z)))) + return scm_flo0; + else return scm_make_real (atan2 (0.0, -1.0)); + } + else SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle); - } } @@ -3900,6 +5401,8 @@ scm_exact_to_inexact (SCM z) return scm_make_real ((double) SCM_INUM (z)); else if (SCM_BIGP (z)) return scm_make_real (scm_i_big2dbl (z)); + else if (SCM_FRACTIONP (z)) + return scm_make_real (scm_i_fraction2double (z)); else if (SCM_INEXACTP (z)) return z; else @@ -3912,23 +5415,101 @@ 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_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_make_ratio (scm_i_mpz2num (mpq_numref (frac)), + scm_i_mpz2num (mpq_denref (frac))); + + /* When scm_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 + +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_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. + */ + + SCM ex = scm_inexact_to_exact (x); + SCM int_part = scm_floor (ex); + SCM tt = SCM_MAKINUM (1); + SCM a1 = SCM_MAKINUM (0), a2 = SCM_MAKINUM (1), a = SCM_MAKINUM (0); + SCM b1 = SCM_MAKINUM (1), b2 = SCM_MAKINUM (0), b = SCM_MAKINUM (0); + SCM rx; + int i = 0; + + if (!SCM_FALSEP (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. + */ + + 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_FALSEP (scm_zero_p (b)) && /* b != 0 */ + SCM_FALSEP + (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_FALSEP (scm_exact_p (x)) + || SCM_FALSEP (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 @@ -4087,11 +5668,13 @@ SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, #define PTRDIFF_MAX (~ PTRDIFF_MIN) #endif -#define CHECK(type, v) \ - do { \ - if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \ - abort (); \ - } while (0); +#define CHECK(type, v) \ + do \ + { \ + if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \ + abort (); \ + } \ + while (0) static void check_sanity () @@ -4184,8 +5767,9 @@ SCM_DEFINE (scm_sys_check_number_conversions, "%check-number-conversions", 0, 0, 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); /* It may be possible to tune the performance of some algorithms by using * the following constants to avoid the creation of bignums. Please, before @@ -4199,28 +5783,24 @@ scm_init_numbers () 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; - } + + /* 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); } - scm_dblprec = scm_dblprec - 1; - } -#endif /* DBL_DIG */ +#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 #ifdef GUILE_DEBUG check_sanity (); #endif - + + exactly_one_half = scm_permanent_object (scm_divide (SCM_MAKINUM (1), + SCM_MAKINUM (2))); #include "libguile/numbers.x" }