X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/16d4699b6ba33685f1318636ffe4990c7db4fdc6..05fa9121e9b9fc133117e3cc581d6bcb560fe9f0:/libguile/numbers.c diff --git a/libguile/numbers.c b/libguile/numbers.c index daf8d5da7..6ea71b65e 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1,48 +1,57 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004 Free Software Foundation, Inc. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories + * and Bellcore. See scm_divide. * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ +/* General assumptions: + * All objects satisfying SCM_COMPLEXP() have a non-zero complex component. + * 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: + + - see if special casing bignums and reals in integer-exponent when + possible (to use mpz_pow and mpf_pow_ui) is faster. + + - look in to better short-circuiting of common cases in + integer-expt and elsewhere. + + - see if direct mpz operations can help in ash and elsewhere. + + */ + +/* tell glibc (2.3) to give prototype for C99 trunc() */ +#define _GNU_SOURCE + +#if HAVE_CONFIG_H +# include +#endif #include #include +#include +#include + #include "libguile/_scm.h" #include "libguile/feature.h" #include "libguile/ports.h" @@ -54,42 +63,370 @@ #include "libguile/numbers.h" #include "libguile/deprecation.h" - +#include "libguile/eq.h" -static SCM scm_divbigbig (SCM_BIGDIG *x, size_t nx, SCM_BIGDIG *y, size_t ny, int sgn, int modes); -static SCM scm_divbigint (SCM x, long z, int sgn, int mode); + +/* + Wonder if this might be faster for some of our code? A switch on + the numtag would jump directly to the right case, and the + SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests... + + #define SCM_I_NUMTAG_NOTNUM 0 + #define SCM_I_NUMTAG_INUM 1 + #define SCM_I_NUMTAG_BIG scm_tc16_big + #define SCM_I_NUMTAG_REAL scm_tc16_real + #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex + #define SCM_I_NUMTAG(x) \ + (SCM_INUMP(x) ? SCM_I_NUMTAG_INUM \ + : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \ + : (((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) +#define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0) /* 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) +#if defined (SCO) +#if ! defined (HAVE_ISNAN) +#define HAVE_ISNAN +static int +isnan (double x) +{ + return (IsNANorINF (x) && NaN (x) && ! IsINF (x)) ? 1 : 0; +} +#endif +#if ! defined (HAVE_ISINF) +#define HAVE_ISINF +static int +isinf (double x) +{ + return (IsNANorINF (x) && IsINF (x)) ? 1 : 0; +} -/* IS_INF tests its floating point number for infiniteness - Dirk:FIXME:: This test does not work if x == 0 - */ -#ifndef IS_INF -#define IS_INF(x) ((x) == (x) / 2) +#endif #endif -/* Return true if X is not infinite and is not a NaN - Dirk:FIXME:: Since IS_INF is broken, this test does not work if x == 0 - */ -#ifndef isfinite -#define isfinite(x) (!IS_INF (x) && (x) == (x)) +/* 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 + +static int +xisinf (double x) +{ +#if defined (HAVE_ISINF) + return isinf (x); +#elif defined (HAVE_FINITE) && defined (HAVE_ISNAN) + return (! (finite (x) || isnan (x))); +#else + return 0; #endif +} + +static int +xisnan (double x) +{ +#if defined (HAVE_ISNAN) + return isnan (x); +#else + return 0; +#endif +} -static SCM abs_most_negative_fixnum; +static mpz_t z_negative_one; +SCM_C_INLINE_KEYWORD SCM +scm_i_mkbig () +{ + /* Return a newly created bignum. */ + SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + mpz_init (SCM_I_BIG_MPZ (z)); + return z; +} + +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)); + return z; +} + +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 */ + /* presume we already know x and y are bignums */ + int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + return result; +} + +SCM_C_INLINE_KEYWORD SCM +scm_i_dbl2big (double d) +{ + /* results are only defined if d is an integer */ + SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + mpz_init_set_d (SCM_I_BIG_MPZ (z), d); + return z; +} + +/* 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; + 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_KEYWORD SCM +scm_i_normbig (SCM b) +{ + /* convert a big back to a fixnum if it'll fit */ + /* presume b is a bignum */ + if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b))) + { + long val = mpz_get_si (SCM_I_BIG_MPZ (b)); + if (SCM_FIXABLE (val)) + b = SCM_MAKINUM (val); + } + return b; +} + +static SCM_C_INLINE_KEYWORD SCM +scm_i_mpz2num (mpz_t b) +{ + /* convert a mpz number to a SCM number. */ + if (mpz_fits_slong_p (b)) + { + long val = mpz_get_si (b); + if (SCM_FIXABLE (val)) + return SCM_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), @@ -97,13 +434,15 @@ SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0, "otherwise.") #define FUNC_NAME s_scm_exact_p { - if (SCM_INUMP (x)) { + if (SCM_INUMP (x)) return SCM_BOOL_T; - } else if (SCM_BIGP (x)) { + if (SCM_BIGP (x)) return SCM_BOOL_T; - } else { + 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 @@ -114,13 +453,31 @@ SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0, "otherwise.") #define FUNC_NAME s_scm_odd_p { - if (SCM_INUMP (n)) { - return SCM_BOOL ((4 & SCM_UNPACK (n)) != 0); - } else if (SCM_BIGP (n)) { - return SCM_BOOL ((1 & SCM_BDIGITS (n) [0]) != 0); - } else { + 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 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 @@ -131,48 +488,195 @@ SCM_DEFINE (scm_even_p, "even?", 1, 0, 0, "otherwise.") #define FUNC_NAME s_scm_even_p { - if (SCM_INUMP (n)) { - return SCM_BOOL ((4 & SCM_UNPACK (n)) == 0); - } else if (SCM_BIGP (n)) { - return SCM_BOOL ((1 & SCM_BDIGITS (n) [0]) == 0); - } else { + 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 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 +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)) + return SCM_BOOL (xisinf (SCM_REAL_VALUE (n))); + else if (SCM_COMPLEXP (n)) + return SCM_BOOL (xisinf (SCM_COMPLEX_REAL (n)) + || xisinf (SCM_COMPLEX_IMAG (n))); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_nan_p, "nan?", 1, 0, 0, + (SCM n), + "Return @code{#t} if @var{n} is a NaN, @code{#f}\n" + "otherwise.") +#define FUNC_NAME s_scm_nan_p +{ + if (SCM_REALP (n)) + return SCM_BOOL (xisnan (SCM_REAL_VALUE (n))); + else if (SCM_COMPLEXP (n)) + return SCM_BOOL (xisnan (SCM_COMPLEX_REAL (n)) + || xisnan (SCM_COMPLEX_IMAG (n))); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + +/* Guile's idea of infinity. */ +static double guile_Inf; -SCM_GPROC (s_abs, "abs", 1, 0, 0, scm_abs, g_abs); -/* "Return the absolute value of @var{x}." - */ -SCM -scm_abs (SCM x) +/* Guile's idea of not a number. */ +static double guile_NaN; + +static void +guile_ieee_init (void) { - 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 { -#ifdef SCM_BIGDIG - return scm_i_long2big (-xx); +#if defined (HAVE_ISINF) || defined (HAVE_FINITE) + +/* Some version of gcc on some old version of Linux used to crash when + trying to make Inf and NaN. */ + +#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 + double tmp = 1e+10; + guile_Inf = tmp; + for (;;) + { + guile_Inf *= 1e+10; + if (guile_Inf == tmp) + break; + tmp = guile_Inf; + } +#endif + +#endif + +#if defined (HAVE_ISNAN) + +#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 - scm_num_overflow (s_abs); + guile_NaN = guile_Inf / guile_Inf; +#endif + #endif +} + +SCM_DEFINE (scm_inf, "inf", 0, 0, 0, + (void), + "Return Inf.") +#define FUNC_NAME s_scm_inf +{ + static int initialized = 0; + if (! initialized) + { + guile_ieee_init (); + initialized = 1; } - } else if (SCM_BIGP (x)) { - if (!SCM_BIGSIGN (x)) { - return x; - } else { - return scm_i_copybig (x, 0); + return scm_make_real (guile_Inf); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_nan, "nan", 0, 0, 0, + (void), + "Return NaN.") +#define FUNC_NAME s_scm_nan +{ + static int initialized = 0; + if (!initialized) + { + guile_ieee_init (); + initialized = 1; } - } else if (SCM_REALP (x)) { - return scm_make_real (fabs (SCM_REAL_VALUE (x))); - } else { - SCM_WTA_DISPATCH_1 (g_abs, x, 1, s_abs); - } + return scm_make_real (guile_NaN); +} +#undef FUNC_NAME + + +SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0, + (SCM x), + "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)) + { + /* 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 SCM_GPROC (s_quotient, "quotient", 2, 0, 0, scm_quotient, g_quotient); @@ -181,78 +685,80 @@ 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 { -#ifdef SCM_BIGDIG - return scm_i_long2big (z); -#else - scm_num_overflow (s_quotient); -#endif + 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_bigcomp (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 { - long z = yy < 0 ? -yy : yy; - - if (z < SCM_BIGRAD) { - SCM sw = scm_i_copybig (x, SCM_BIGSIGN (x) ? (yy > 0) : (yy < 0)); - scm_divbigdig (SCM_BDIGITS (sw), SCM_NUMDIGS (sw), (SCM_BIGDIG) z); - return scm_i_normbig (sw); - } else { -#ifndef SCM_DIGSTOOBIG - long w = scm_pseudolong (z); - return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), - (SCM_BIGDIG *) & w, SCM_DIGSPERLONG, - SCM_BIGSIGN (x) ? (yy > 0) : (yy < 0), 2); -#else - SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs (z, zdigs); - return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), - zdigs, SCM_DIGSPERLONG, - SCM_BIGSIGN (x) ? (yy > 0) : (yy < 0), 2); -#endif + 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)) { - return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), - SCM_BDIGITS (y), SCM_NUMDIGS (y), - SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y), 2); - } else { - SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient); + 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 { + 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); /* "Return the remainder of the numbers @var{x} and @var{y}.\n" * "@lisp\n" @@ -263,45 +769,66 @@ 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_bigcomp (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 { - return scm_divbigint (x, yy, SCM_BIGSIGN (x), 0); - } - } else if (SCM_BIGP (y)) { - return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), - SCM_BDIGITS (y), SCM_NUMDIGS (y), - SCM_BIGSIGN (x), 0); - } 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 { + 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); - } } @@ -315,44 +842,127 @@ 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 { - long z = xx % yy; - return SCM_MAKINUM (((yy < 0) ? (z > 0) : (z < 0)) ? z + yy : z); - } - } else if (SCM_BIGP (y)) { - return (SCM_BIGSIGN (y) ? (xx > 0) : (xx < 0)) ? scm_sum (x, y) : x; - } 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 { - return scm_divbigint (x, yy, yy < 0, - (SCM_BIGSIGN (x) ? (yy > 0) : (yy < 0)) ? 1 : 0); - } - } else if (SCM_BIGP (y)) { - return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), - SCM_BDIGITS (y), SCM_NUMDIGS (y), - SCM_BIGSIGN (y), - (SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y)) ? 1 : 0); - } else { - SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo); + 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 { + 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); + } + 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); /* "Return the greatest common divisor of all arguments.\n" * "If called without arguments, 0 is returned." @@ -360,114 +970,104 @@ SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd); SCM scm_gcd (SCM x, SCM y) { - if (SCM_UNBNDP (y)) { - if (SCM_UNBNDP (x)) { - return SCM_INUM0; - } else { - return x; + if (SCM_UNBNDP (y)) + return SCM_UNBNDP (x) ? SCM_INUM0 : x; + + if (SCM_INUMP (x)) + { + if (SCM_INUMP (y)) + { + long xx = SCM_INUM (x); + long yy = SCM_INUM (y); + long u = xx < 0 ? -xx : xx; + long v = yy < 0 ? -yy : yy; + long result; + if (xx == 0) + result = v; + else if (yy == 0) + result = u; + else + { + long k = 1; + long t; + /* Determine a common factor 2^k */ + while (!(1 & (u | v))) + { + k <<= 1; + u >>= 1; + v >>= 1; + } + /* Now, any factor 2^n can be eliminated */ + if (u & 1) + t = -v; + else + { + t = u; + b3: + t = SCM_SRS (t, 1); + } + if (!(1 & t)) + goto b3; + if (t > 0) + u = t; + else + v = -t; + t = u - v; + if (t != 0) + goto b3; + result = u * k; + } + return (SCM_POSFIXABLE (result) + ? SCM_MAKINUM (result) + : scm_i_long2big (result)); + } + 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); + } + else + SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd); } - } - - tailrec: - if (SCM_INUMP (x)) { - if (SCM_INUMP (y)) { - long xx = SCM_INUM (x); - long yy = SCM_INUM (y); - long u = xx < 0 ? -xx : xx; - long v = yy < 0 ? -yy : yy; - long result; - - if (xx == 0) { - result = v; - } else if (yy == 0) { - result = u; - } else { - long k = 1; - long t; - - /* Determine a common factor 2^k */ - while (!(1 & (u | v))) { - k <<= 1; - u >>= 1; - v >>= 1; - } - - /* Now, any factor 2^n can be eliminated */ - if (u & 1) { - t = -v; - } else { - t = u; - b3: - t = SCM_SRS (t, 1); - } - if (!(1 & t)) - goto b3; - if (t > 0) - u = t; - else - v = -t; - t = u - v; - if (t != 0) - goto b3; - - result = u * k; - } - if (SCM_POSFIXABLE (result)) { - return SCM_MAKINUM (result); - } else { -#ifdef SCM_BIGDIG - return scm_i_long2big (result); -#else - scm_num_overflow (s_gcd); -#endif - } - } else if (SCM_BIGP (y)) { - SCM_SWAP (x, y); - goto big_gcd; - } else { - SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd); - } - } else if (SCM_BIGP (x)) { - big_gcd: - if (SCM_BIGSIGN (x)) - x = scm_i_copybig (x, 0); - newy: - if (SCM_INUMP (y)) { - if (SCM_EQ_P (y, SCM_INUM0)) { - return x; - } else { - goto swaprec; - } - } else if (SCM_BIGP (y)) { - if (SCM_BIGSIGN (y)) - y = scm_i_copybig (y, 0); - switch (scm_bigcomp (x, y)) - { - case -1: /* x > y */ - swaprec: - { - SCM t = scm_remainder (x, y); - x = y; - y = t; - } - goto tailrec; - case 1: /* x < y */ - y = scm_remainder (y, x); - goto newy; - default: /* x == y */ - return x; - } - /* instead of the switch, we could just - return scm_gcd (y, scm_modulo (x, y)); */ - } else { - SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd); + else if (SCM_BIGP (x)) + { + if (SCM_INUMP (y)) + { + unsigned long result; + long 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)); + } + 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); + return scm_i_normbig (result); + } + else + SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd); } - } else { + else SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG1, s_gcd); - } } - SCM_GPROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm, g_lcm); /* "Return the least common multiple of the arguments.\n" * "If called without arguments, 1 is returned." @@ -475,42 +1075,70 @@ SCM_GPROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm, g_lcm); SCM scm_lcm (SCM n1, SCM n2) { - if (SCM_UNBNDP (n2)) { - if (SCM_UNBNDP (n1)) { - return SCM_MAKINUM (1L); - } else { + if (SCM_UNBNDP (n2)) + { + if (SCM_UNBNDP (n1)) + return SCM_MAKINUM (1L); n2 = SCM_MAKINUM (1L); } - }; -#ifndef SCM_BIGDIG - SCM_GASSERT2 (SCM_INUMP (n1), g_lcm, n1, n2, SCM_ARG1, s_lcm); - SCM_GASSERT2 (SCM_INUMP (n2), g_lcm, n1, n2, SCM_ARGn, s_lcm); -#else SCM_GASSERT2 (SCM_INUMP (n1) || SCM_BIGP (n1), - g_lcm, n1, n2, SCM_ARG1, s_lcm); + g_lcm, n1, n2, SCM_ARG1, s_lcm); SCM_GASSERT2 (SCM_INUMP (n2) || SCM_BIGP (n2), - g_lcm, n1, n2, SCM_ARGn, s_lcm); -#endif + g_lcm, n1, n2, SCM_ARGn, s_lcm); - { - SCM d = scm_gcd (n1, n2); - if (SCM_EQ_P (d, SCM_INUM0)) { - return d; - } else { - return scm_abs (scm_product (n1, scm_quotient (n2, d))); + if (SCM_INUMP (n1)) + { + if (SCM_INUMP (n2)) + { + SCM d = scm_gcd (n1, n2); + if (SCM_EQ_P (d, SCM_INUM0)) + return d; + else + return scm_abs (scm_product (n1, scm_quotient (n2, d))); + } + else + { + /* inum n1, big n2 */ + inumbig: + { + SCM result = scm_i_mkbig (); + long nn1 = SCM_INUM (n1); + if (nn1 == 0) return SCM_INUM0; + if (nn1 < 0) nn1 = - nn1; + mpz_lcm_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n2), nn1); + scm_remember_upto_here_1 (n2); + return result; + } + } + } + else + { + /* big n1 */ + if (SCM_INUMP (n2)) + { + SCM_SWAP (n1, n2); + goto inumbig; + } + else + { + SCM result = scm_i_mkbig (); + mpz_lcm(SCM_I_BIG_MPZ (result), + SCM_I_BIG_MPZ (n1), + SCM_I_BIG_MPZ (n2)); + scm_remember_upto_here_2(n1, n2); + /* shouldn't need to normalize b/c lcm of 2 bigs should be big */ + return result; + } } - } } - #ifndef scm_long2num #define SCM_LOGOP_RETURN(x) scm_ulong2num(x) #else #define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x) #endif - /* Emulating 2's complement bignums with sign magnitude arithmetic: Logand: @@ -547,275 +1175,78 @@ scm_lcm (SCM n1, SCM n2) */ -#ifdef SCM_BIGDIG - -SCM scm_copy_big_dec(SCM b, int sign); -SCM scm_copy_smaller(SCM_BIGDIG *x, size_t nx, int zsgn); -SCM scm_big_ior(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy); -SCM scm_big_xor(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy); -SCM scm_big_and(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy, int zsgn); -SCM scm_big_test(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy); - -SCM scm_copy_big_dec(SCM b, int sign) -{ - long num = -1; - size_t nx = SCM_NUMDIGS(b); - size_t i = 0; - SCM ans = scm_i_mkbig(nx, sign); - SCM_BIGDIG *src = SCM_BDIGITS(b), *dst = SCM_BDIGITS(ans); - if SCM_BIGSIGN(b) do { - num += src[i]; - if (num < 0) {dst[i] = num + SCM_BIGRAD; num = -1;} - else {dst[i] = SCM_BIGLO(num); num = 0;} - } while (++i < nx); - else - while (nx--) dst[nx] = src[nx]; - return ans; -} - -SCM scm_copy_smaller(SCM_BIGDIG *x, size_t nx, int zsgn) -{ - long num = -1; - size_t i = 0; - SCM z = scm_i_mkbig(nx, zsgn); - SCM_BIGDIG *zds = SCM_BDIGITS(z); - if (zsgn) do { - num += x[i]; - if (num < 0) {zds[i] = num + SCM_BIGRAD; num = -1;} - else {zds[i] = SCM_BIGLO(num); num = 0;} - } while (++i < nx); - else do zds[i] = x[i]; while (++i < nx); - return z; -} - -SCM scm_big_ior(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy) -/* Assumes nx <= SCM_NUMDIGS(bigy) */ -/* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */ -{ - long num = -1; - size_t i = 0, ny = SCM_NUMDIGS(bigy); - SCM z = scm_copy_big_dec (bigy, xsgn & SCM_BIGSIGN (bigy)); - SCM_BIGDIG *zds = SCM_BDIGITS(z); - if (xsgn) { - do { - num += x[i]; - if (num < 0) {zds[i] |= num + SCM_BIGRAD; num = -1;} - else {zds[i] |= SCM_BIGLO(num); num = 0;} - } while (++i < nx); - /* ========= Need to increment zds now =========== */ - i = 0; num = 1; - while (i < ny) { - num += zds[i]; - zds[i++] = SCM_BIGLO(num); - num = SCM_BIGDN(num); - if (!num) return z; - } - scm_i_adjbig(z, 1 + ny); /* OOPS, overflowed into next digit. */ - SCM_BDIGITS(z)[ny] = 1; - return z; - } - else do zds[i] = zds[i] | x[i]; while (++i < nx); - return z; -} - -SCM scm_big_xor(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy) -/* Assumes nx <= SCM_NUMDIGS(bigy) */ -/* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */ -{ - long num = -1; - size_t i = 0, ny = SCM_NUMDIGS(bigy); - SCM z = scm_copy_big_dec(bigy, xsgn ^ SCM_BIGSIGN(bigy)); - SCM_BIGDIG *zds = SCM_BDIGITS(z); - if (xsgn) do { - num += x[i]; - if (num < 0) {zds[i] ^= num + SCM_BIGRAD; num = -1;} - else {zds[i] ^= SCM_BIGLO(num); num = 0;} - } while (++i < nx); - else do { - zds[i] = zds[i] ^ x[i]; - } while (++i < nx); - - if (xsgn ^ SCM_BIGSIGN(bigy)) { - /* ========= Need to increment zds now =========== */ - i = 0; num = 1; - while (i < ny) { - num += zds[i]; - zds[i++] = SCM_BIGLO(num); - num = SCM_BIGDN(num); - if (!num) return scm_i_normbig(z); - } - } - return scm_i_normbig(z); -} - -SCM scm_big_and(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy, int zsgn) -/* Assumes nx <= SCM_NUMDIGS(bigy) */ -/* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */ -/* return sign equals either 0 or SCM_BIGSIGNFLAG */ -{ - long num = -1; - size_t i = 0; - SCM z; - SCM_BIGDIG *zds; - if (xsgn==zsgn) { - z = scm_copy_smaller(x, nx, zsgn); - x = SCM_BDIGITS(bigy); - xsgn = SCM_BIGSIGN(bigy); - } - else z = scm_copy_big_dec(bigy, zsgn); - zds = SCM_BDIGITS(z); - - if (zsgn) { - if (xsgn) do { - num += x[i]; - if (num < 0) {zds[i] &= num + SCM_BIGRAD; num = -1;} - else {zds[i] &= SCM_BIGLO(num); num = 0;} - } while (++i < nx); - else do zds[i] = zds[i] & ~x[i]; while (++i < nx); - /* ========= need to increment zds now =========== */ - i = 0; num = 1; - while (i < nx) { - num += zds[i]; - zds[i++] = SCM_BIGLO(num); - num = SCM_BIGDN(num); - if (!num) return scm_i_normbig(z); - } - } - else if (xsgn) { - unsigned long int carry = 1; - do { - unsigned long int mask = (SCM_BIGDIG) ~x[i] + carry; - zds[i] = zds[i] & (SCM_BIGDIG) mask; - carry = (mask >= SCM_BIGRAD) ? 1 : 0; - } while (++i < nx); - } else do zds[i] = zds[i] & x[i]; while (++i < nx); - return scm_i_normbig(z); -} - -SCM scm_big_test(SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy) -/* Assumes nx <= SCM_NUMDIGS(bigy) */ -/* Assumes xsgn equals either 0 or SCM_BIGSIGNFLAG */ -{ - SCM_BIGDIG *y; - size_t i = 0; - long num = -1; - if (SCM_BIGSIGN(bigy) & xsgn) return SCM_BOOL_T; - if (SCM_NUMDIGS(bigy) != nx && xsgn) return SCM_BOOL_T; - y = SCM_BDIGITS(bigy); - if (xsgn) - do { - num += x[i]; - if (num < 0) { - if (y[i] & ~(num + SCM_BIGRAD)) return SCM_BOOL_T; - num = -1; - } - else { - if (y[i] & ~SCM_BIGLO(num)) return SCM_BOOL_T; - num = 0; - } - } while (++i < nx); - else if SCM_BIGSIGN(bigy) - do { - num += y[i]; - if (num < 0) { - if (x[i] & ~(num + SCM_BIGRAD)) return SCM_BOOL_T; - num = -1; - } - else { - if (x[i] & ~SCM_BIGLO(num)) return SCM_BOOL_T; - num = 0; - } - } while (++i < nx); - else - do if (x[i] & y[i]) return SCM_BOOL_T; - while (++i < nx); - return SCM_BOOL_F; -} - -#endif - SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr, (SCM n1, SCM n2), "Return the bitwise AND of the integer arguments.\n\n" "@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); -#ifndef SCM_RECKLESS - } else if (SCM_NUMBERP (n1)) { - return n1; - } else { - SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); -#else - } else { - return n1; -#endif + 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: - { -# ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong (nn1); - if ((nn1 < 0) && SCM_BIGSIGN (n2)) { - return scm_big_ior ((SCM_BIGDIG *) & z, SCM_DIGSPERLONG, - SCM_BIGSIGNFLAG, n2); - } else { - return scm_big_and ((SCM_BIGDIG *) & z, SCM_DIGSPERLONG, - (nn1 < 0) ? SCM_BIGSIGNFLAG : 0, n2, 0); - } -# else - SCM_BIGDIG zdigs [SCM_DIGSPERLONG]; - scm_longdigs (nn1, zdigs); - if ((nn1 < 0) && SCM_BIGSIGN (n2)) { - return scm_big_ior (zdigs, SCM_DIGSPERLONG, SCM_BIGSIGNFLAG, n2); - } else { - return scm_big_and (zdigs, SCM_DIGSPERLONG, - (nn1 < 0) ? SCM_BIGSIGNFLAG : 0, n2, 0); + if (SCM_INUMP (n1)) + { + nn1 = SCM_INUM (n1); + if (SCM_INUMP (n2)) + { + long nn2 = SCM_INUM (n2); + return SCM_MAKINUM (nn1 & nn2); } -# endif - } - } else { - SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); + else if SCM_BIGP (n2) + { + intbig: + if (n1 == 0) + return SCM_INUM0; + { + SCM result_z = scm_i_mkbig (); + mpz_t nn1_z; + mpz_init_set_si (nn1_z, nn1); + mpz_and (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2)); + scm_remember_upto_here_1 (n2); + mpz_clear (nn1_z); + return scm_i_normbig (result_z); + } + } + else + SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); } - } else if (SCM_BIGP (n1)) { - if (SCM_INUMP (n2)) { - SCM_SWAP (n1, n2); - nn1 = SCM_INUM (n1); - goto intbig; - } else if (SCM_BIGP (n2)) { - if (SCM_NUMDIGS (n1) > SCM_NUMDIGS (n2)) { - SCM_SWAP (n1, n2); - }; - if ((SCM_BIGSIGN (n1)) && SCM_BIGSIGN (n2)) { - return scm_big_ior (SCM_BDIGITS (n1), SCM_NUMDIGS (n1), - SCM_BIGSIGNFLAG, n2); - } else { - return scm_big_and (SCM_BDIGITS (n1), SCM_NUMDIGS (n1), - SCM_BIGSIGN (n1), n2, 0); - } - } else { - SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); + else if (SCM_BIGP (n1)) + { + if (SCM_INUMP (n2)) + { + SCM_SWAP (n1, n2); + nn1 = SCM_INUM (n1); + goto intbig; + } + else if (SCM_BIGP (n2)) + { + SCM result_z = scm_i_mkbig (); + mpz_and (SCM_I_BIG_MPZ (result_z), + SCM_I_BIG_MPZ (n1), + SCM_I_BIG_MPZ (n2)); + scm_remember_upto_here_2 (n1, n2); + return scm_i_normbig (result_z); + } + else + SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); } - } else { + else SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); - } } #undef FUNC_NAME @@ -832,75 +1263,64 @@ SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr, { long int nn1; - if (SCM_UNBNDP (n2)) { - if (SCM_UNBNDP (n1)) { - return SCM_INUM0; -#ifndef SCM_RECKLESS - } else if (SCM_NUMBERP (n1)) { - return n1; - } else { - SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); -#else - } else { - return n1; -#endif + 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: - { -# ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong (nn1); - if ((!(nn1 < 0)) && !SCM_BIGSIGN (n2)) { - return scm_big_ior ((SCM_BIGDIG *) & z, SCM_DIGSPERLONG, - (nn1 < 0) ? SCM_BIGSIGNFLAG : 0, n2); - } else { - return scm_big_and ((SCM_BIGDIG *) & z, SCM_DIGSPERLONG, - (nn1 < 0) ? SCM_BIGSIGNFLAG : 0, n2, SCM_BIGSIGNFLAG); - } -# else - SCM_BIGDIG zdigs [SCM_DIGSPERLONG]; - scm_longdigs (nn1, zdigs); - if ((!(nn1 < 0)) && !SCM_BIGSIGN (n2)) { - return scm_big_ior (zdigs, SCM_DIGSPERLONG, - (nn1 < 0) ? SCM_BIGSIGNFLAG : 0, n2); - } else { - return scm_big_and (zdigs, SCM_DIGSPERLONG, - (nn1 < 0) ? SCM_BIGSIGNFLAG : 0, n2, SCM_BIGSIGNFLAG); + if (SCM_INUMP (n1)) + { + nn1 = SCM_INUM (n1); + if (SCM_INUMP (n2)) + { + long nn2 = SCM_INUM (n2); + return SCM_MAKINUM (nn1 | nn2); } -# endif - } - } else { - SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); + else if (SCM_BIGP (n2)) + { + intbig: + if (nn1 == 0) + return n2; + { + SCM result_z = scm_i_mkbig (); + mpz_t nn1_z; + mpz_init_set_si (nn1_z, nn1); + mpz_ior (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2)); + scm_remember_upto_here_1 (n2); + mpz_clear (nn1_z); + return result_z; + } + } + else + SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); } - } else if (SCM_BIGP (n1)) { - if (SCM_INUMP (n2)) { - SCM_SWAP (n1, n2); - nn1 = SCM_INUM (n1); - goto intbig; - } else if (SCM_BIGP (n2)) { - if (SCM_NUMDIGS (n1) > SCM_NUMDIGS (n2)) { - SCM_SWAP (n1, n2); - }; - if ((!SCM_BIGSIGN (n1)) && !SCM_BIGSIGN (n2)) { - return scm_big_ior (SCM_BDIGITS (n1), SCM_NUMDIGS (n1), - SCM_BIGSIGN (n1), n2); - } else { - return scm_big_and (SCM_BDIGITS (n1), SCM_NUMDIGS (n1), - SCM_BIGSIGN (n1), n2, SCM_BIGSIGNFLAG); - } - } else { - SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); + else if (SCM_BIGP (n1)) + { + if (SCM_INUMP (n2)) + { + SCM_SWAP (n1, n2); + nn1 = SCM_INUM (n1); + goto intbig; + } + else if (SCM_BIGP (n2)) + { + SCM result_z = scm_i_mkbig (); + mpz_ior (SCM_I_BIG_MPZ (result_z), + SCM_I_BIG_MPZ (n1), + SCM_I_BIG_MPZ (n2)); + scm_remember_upto_here_2 (n1, n2); + return result_z; + } + else + SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); } - } else { + else SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); - } } #undef FUNC_NAME @@ -919,60 +1339,62 @@ SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr, { long int nn1; - if (SCM_UNBNDP (n2)) { - if (SCM_UNBNDP (n1)) { - return SCM_INUM0; -#ifndef SCM_RECKLESS - } else if (SCM_NUMBERP (n1)) { - return n1; - } else { - SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); -#else - } else { - return n1; -#endif + 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: - { -# ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong (nn1); - return scm_big_xor ((SCM_BIGDIG *) & z, SCM_DIGSPERLONG, - (nn1 < 0) ? SCM_BIGSIGNFLAG : 0, n2); -# else - SCM_BIGDIG zdigs [SCM_DIGSPERLONG]; - scm_longdigs (nn1, zdigs); - return scm_big_xor (zdigs, SCM_DIGSPERLONG, - (nn1 < 0) ? SCM_BIGSIGNFLAG : 0, n2); -# endif - } - } 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)) { - if (SCM_NUMDIGS(n1) > SCM_NUMDIGS(n2)) { - SCM_SWAP (n1, n2); - } - return scm_big_xor (SCM_BDIGITS (n1), SCM_NUMDIGS (n1), - SCM_BIGSIGN (n1), n2); - } 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 @@ -988,45 +1410,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: - { -# ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong (nj); - return scm_big_test ((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, - (nj < 0) ? SCM_BIGSIGNFLAG : 0, k); -# else - SCM_BIGDIG zdigs [SCM_DIGSPERLONG]; - scm_longdigs (nj, zdigs); - return scm_big_test (zdigs, SCM_DIGSPERLONG, - (nj < 0) ? SCM_BIGSIGNFLAG : 0, k); -# endif - } - } 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)) { - if (SCM_NUMDIGS (j) > SCM_NUMDIGS (k)) { - SCM_SWAP (j, k); - } - return scm_big_test (SCM_BDIGITS (j), SCM_NUMDIGS (j), - SCM_BIGSIGN (j), k); - } 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 @@ -1048,40 +1484,23 @@ 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)) { + if (SCM_INUMP (j)) return SCM_BOOL ((1L << iindex) & SCM_INUM (j)); - } else if (SCM_BIGP (j)) { - if (SCM_NUMDIGS (j) * SCM_BITSPERDIG < iindex) { - return SCM_BOOL_F; - } else if (SCM_BIGSIGN (j)) { - long num = -1; - size_t i = 0; - SCM_BIGDIG * x = SCM_BDIGITS (j); - size_t nx = iindex / SCM_BITSPERDIG; - while (1) { - num += x[i]; - if (nx == i++) { - return SCM_BOOL (((1L << (iindex % SCM_BITSPERDIG)) & num) == 0); - } else if (num < 0) { - num = -1; - } else { - num = 0; - } - } - } else { - return SCM_BOOL (SCM_BDIGITS (j) [iindex / SCM_BITSPERDIG] - & (1L << (iindex % SCM_BITSPERDIG))); + 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 { + 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" @@ -1092,7 +1511,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 @@ -1109,100 +1661,143 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, "@end lisp") #define FUNC_NAME s_scm_integer_expt { + long i2 = 0; + SCM z_i2 = SCM_BOOL_F; + int i2_is_big = 0; SCM acc = SCM_MAKINUM (1L); - int i2; -#ifdef SCM_BIGDIG + + /* 0^0 == 1 according to R5RS */ if (SCM_EQ_P (n, SCM_INUM0) || SCM_EQ_P (n, acc)) - return n; + return SCM_FALSEP (scm_zero_p(k)) ? n : acc; else if (SCM_EQ_P (n, SCM_MAKINUM (-1L))) return SCM_FALSEP (scm_even_p (k)) ? n : acc; -#endif - if (SCM_REALP (k)) + + if (SCM_INUMP (k)) + i2 = SCM_INUM (k); + else if (SCM_BIGP (k)) + { + z_i2 = scm_i_clonebig (k, 1); + scm_remember_upto_here_1 (k); + i2_is_big = 1; + } + else if (SCM_REALP (k)) { double r = SCM_REAL_VALUE (k); - i2 = r; - if (i2 != r) - SCM_WRONG_TYPE_ARG (2, k); + if (floor (r) != r) + SCM_WRONG_TYPE_ARG (2, k); + if ((r > SCM_MOST_POSITIVE_FIXNUM) || (r < SCM_MOST_NEGATIVE_FIXNUM)) + { + z_i2 = scm_i_mkbig (); + mpz_set_d (SCM_I_BIG_MPZ (z_i2), r); + i2_is_big = 1; + } + else + { + i2 = r; + } } else - SCM_VALIDATE_ULONG_COPY (2,k,i2); - if (i2 < 0) + SCM_WRONG_TYPE_ARG (2, k); + + if (i2_is_big) { - i2 = -i2; - n = scm_divide (n, SCM_UNDEFINED); + if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == -1) + { + mpz_neg (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2)); + n = scm_divide (n, SCM_UNDEFINED); + } + while (1) + { + if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == 0) + { + return acc; + } + if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2), 1) == 0) + { + return scm_product (acc, n); + } + if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2), 0)) + acc = scm_product (acc, n); + n = scm_product (n, n); + mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2), 1); + } } - while (1) + else { - if (0 == i2) - return acc; - if (1 == i2) - return scm_product (acc, n); - if (i2 & 1) - acc = scm_product (acc, n); - n = scm_product (n, n); - i2 >>= 1; + if (i2 < 0) + { + i2 = -i2; + n = scm_divide (n, SCM_UNDEFINED); + } + while (1) + { + if (0 == i2) + return acc; + if (1 == i2) + return scm_product (acc, n); + if (i2 & 1) + acc = scm_product (acc, n); + n = scm_product (n, n); + i2 >>= 1; + } } } #undef FUNC_NAME 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" + "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" - "Formally, the function returns an integer equivalent to\n" - "@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}.\n" + "With @var{n} viewed as an infinite precision twos complement,\n" + "@code{ash} means a left shift introducing zero bits, or a right\n" + "shift dropping bits.\n" "\n" "@lisp\n" "(number->string (ash #b1 3) 2) @result{} \"1000\"\n" "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n" + "\n" + ";; -23 is bits ...11101001, -6 is bits ...111010\n" + "(ash -23 -2) @result{} -6\n" "@end lisp") #define FUNC_NAME s_scm_ash { long bits_to_shift; -#ifndef SCM_BIGDIG - SCM_VALIDATE_INUM (1, n) -#endif SCM_VALIDATE_INUM (2, cnt); bits_to_shift = SCM_INUM (cnt); -#ifdef SCM_BIGDIG - if (bits_to_shift < 0) { - /* Shift right by abs(cnt) bits. This is realized as a division by - div:=2^abs(cnt). However, to guarantee the floor rounding, negative - values require some special treatment. - */ - SCM div = scm_integer_expt (SCM_MAKINUM (2), SCM_MAKINUM (-bits_to_shift)); - if (SCM_FALSEP (scm_negative_p (n))) - return scm_quotient (n, div); - else - return scm_sum (SCM_MAKINUM (-1L), - scm_quotient (scm_sum (SCM_MAKINUM (1L), n), div)); - } else + + if (bits_to_shift < 0) + { + /* Shift right by abs(cnt) bits. This is realized as a division + by div:=2^abs(cnt). However, to guarantee the floor + rounding, negative values require some special treatment. + */ + SCM div = scm_integer_expt (SCM_MAKINUM (2), + SCM_MAKINUM (-bits_to_shift)); + + /* 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 + return scm_sum (SCM_MAKINUM (-1L), + scm_quotient (scm_sum (SCM_MAKINUM (1L), n), div)); + } + else /* Shift left is done by multiplication with 2^CNT */ return scm_product (n, scm_integer_expt (SCM_MAKINUM (2), cnt)); -#else - if (bits_to_shift < 0) - /* Signed right shift (SCM_SRS does it right) by abs(cnt) bits. */ - return SCM_MAKINUM (SCM_SRS (SCM_INUM (n), -bits_to_shift)); - else { - /* Shift left, but make sure not to leave the range of inums */ - SCM res = SCM_MAKINUM (SCM_INUM (n) << cnt); - if (SCM_INUM (res) >> cnt != SCM_INUM (n)) - scm_num_overflow (FUNC_NAME); - return res; - } -#endif } #undef FUNC_NAME +#define MIN(x,y) ((x) < (y) ? (x) : (y)) + SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0, (SCM n, SCM start, SCM end), "Return the integer composed of the @var{start} (inclusive)\n" @@ -1217,53 +1812,62 @@ SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0, "@end lisp") #define FUNC_NAME s_scm_bit_extract { - unsigned long int istart, iend; - SCM_VALIDATE_INUM_MIN_COPY (2,start,0,istart); + 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". + FIXME: This shift relies on signed right shifts being arithmetic, + which is not guaranteed by C99. */ + 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>= 4; - }; - return SCM_MAKINUM (c); - } else if (SCM_BIGP (n)) { - if (SCM_BIGSIGN (n)) { - return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n)); - } else { + if (SCM_INUMP (n)) + { unsigned long int c = 0; - size_t i = SCM_NUMDIGS (n); - SCM_BIGDIG * ds = SCM_BDIGITS (n); - while (i--) { - SCM_BIGDIG d; - for (d = ds[i]; d; d >>= 4) { - c += scm_logtab[15 & d]; - } - } + long int nn = SCM_INUM (n); + if (nn < 0) + nn = -1 - nn; + while (nn) + { + c += scm_logtab[15 & nn]; + nn >>= 4; + } return SCM_MAKINUM (c); } - } else { + else if (SCM_BIGP (n)) + { + unsigned long count; + if (mpz_sgn (SCM_I_BIG_MPZ (n)) >= 0) + count = mpz_popcount (SCM_I_BIG_MPZ (n)); + else + count = mpz_hamdist (SCM_I_BIG_MPZ (n), z_negative_one); + scm_remember_upto_here_1 (n); + return SCM_MAKINUM (count); + } + else SCM_WRONG_TYPE_ARG (SCM_ARG1, n); - } } #undef FUNC_NAME @@ -1326,9 +1926,10 @@ static const char scm_ilentab[] = { 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4 }; + SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0, (SCM n), - "Return the number of bits neccessary to represent @var{n}.\n" + "Return the number of bits necessary to represent @var{n}.\n" "\n" "@lisp\n" "(integer-length #b10101010)\n" @@ -1340,628 +1941,110 @@ 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)) { - if (SCM_BIGSIGN (n)) { - return scm_integer_length (scm_difference (SCM_MAKINUM (-1L), n)); - } else { - unsigned long int digs = SCM_NUMDIGS (n) - 1; - unsigned long int c = digs * SCM_BITSPERDIG; + if (SCM_INUMP (n)) + { + unsigned long int c = 0; unsigned int l = 4; - SCM_BIGDIG * ds = SCM_BDIGITS (n); - SCM_BIGDIG d = ds [digs]; - while (d) { - c += 4; - l = scm_ilentab [15 & d]; - d >>= 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 { + 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}; -#ifdef SCM_BIGDIG -static const char s_bignum[] = "bignum"; - -SCM -scm_i_mkbig (size_t nlen, int sign) +static size_t +idbl2str (double f, char *a) { - SCM v; - SCM_BIGDIG *base; - - if (((nlen << SCM_BIGSIZEFIELD) >> SCM_BIGSIZEFIELD) != nlen) - scm_memory_error (s_bignum); - - base = scm_must_malloc (nlen * sizeof (SCM_BIGDIG), s_bignum); - - v = scm_alloc_cell (SCM_MAKE_BIGNUM_TAG (nlen, sign), (scm_t_bits) base); - return v; -} + int efmt, dpt, d, i, wp = scm_dblprec; + size_t ch = 0; + int exp = 0; -SCM -scm_i_big2inum (SCM b, size_t l) -{ - unsigned long num = 0; - SCM_BIGDIG *tmp = SCM_BDIGITS (b); - while (l--) - num = SCM_BIGUP (num) + tmp[l]; - if (!SCM_BIGSIGN (b)) + if (f == 0.0) { - if (SCM_POSFIXABLE (num)) - return SCM_MAKINUM (num); - } - else if (num <= -SCM_MOST_NEGATIVE_FIXNUM) - return SCM_MAKINUM (-num); - return b; -} - -static const char s_adjbig[] = "scm_i_adjbig"; - -SCM -scm_i_adjbig (SCM b, size_t nlen) -{ - size_t nsiz = nlen; - if (((nsiz << SCM_BIGSIZEFIELD) >> SCM_BIGSIZEFIELD) != nlen) - scm_memory_error (s_adjbig); +#ifdef HAVE_COPYSIGN + double sgn = copysign (1.0, f); - SCM_DEFER_INTS; - { - SCM_BIGDIG *digits - = ((SCM_BIGDIG *) - scm_must_realloc ((char *) SCM_BDIGITS (b), - (long) (SCM_NUMDIGS (b) * sizeof (SCM_BIGDIG)), - (long) (nsiz * sizeof (SCM_BIGDIG)), s_bignum)); - - SCM_SET_BIGNUM_BASE (b, digits); - SCM_SETNUMDIGS (b, nsiz, SCM_BIGSIGN (b)); - } - SCM_ALLOW_INTS; - return b; -} - -SCM -scm_i_normbig (SCM b) -{ -#ifndef _UNICOS - size_t nlen = SCM_NUMDIGS (b); -#else - int nlen = SCM_NUMDIGS (b); /* unsigned nlen breaks on Cray when nlen => 0 */ + if (sgn < 0.0) + a[ch++] = '-'; #endif - SCM_BIGDIG *zds = SCM_BDIGITS (b); - while (nlen-- && !zds[nlen]); - nlen++; - if (nlen * SCM_BITSPERDIG / SCM_CHAR_BIT <= sizeof (SCM)) - if (SCM_INUMP (b = scm_i_big2inum (b, (size_t) nlen))) - return b; - if (SCM_NUMDIGS (b) == nlen) - return b; - return scm_i_adjbig (b, (size_t) nlen); -} - -SCM -scm_i_copybig (SCM b, int sign) -{ - size_t i = SCM_NUMDIGS (b); - SCM ans = scm_i_mkbig (i, sign); - SCM_BIGDIG *src = SCM_BDIGITS (b), *dst = SCM_BDIGITS (ans); - while (i--) - dst[i] = src[i]; - return ans; -} - -int -scm_bigcomp (SCM x, SCM y) -{ - int xsign = SCM_BIGSIGN (x); - int ysign = SCM_BIGSIGN (y); - size_t xlen, ylen; - - /* Look at the signs, first. */ - if (ysign < xsign) - return 1; - if (ysign > xsign) - return -1; - - /* They're the same sign, so see which one has more digits. Note - that, if they are negative, the longer number is the lesser. */ - ylen = SCM_NUMDIGS (y); - xlen = SCM_NUMDIGS (x); - if (ylen > xlen) - return (xsign) ? -1 : 1; - if (ylen < xlen) - return (xsign) ? 1 : -1; - - /* They have the same number of digits, so find the most significant - digit where they differ. */ - while (xlen) - { - --xlen; - if (SCM_BDIGITS (y)[xlen] != SCM_BDIGITS (x)[xlen]) - /* Make the discrimination based on the digit that differs. */ - return ((SCM_BDIGITS (y)[xlen] > SCM_BDIGITS (x)[xlen]) - ? (xsign ? -1 : 1) - : (xsign ? 1 : -1)); - } - - /* The numbers are identical. */ - return 0; -} - -#ifndef SCM_DIGSTOOBIG + goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */ + } -long -scm_pseudolong (long x) -{ - union - { - long l; - SCM_BIGDIG bd[SCM_DIGSPERLONG]; - } - p; - size_t i = 0; - if (x < 0) - x = -x; - while (i < SCM_DIGSPERLONG) + if (xisinf (f)) { - p.bd[i++] = SCM_BIGLO (x); - x = SCM_BIGDN (x); + if (f < 0) + strcpy (a, "-inf.0"); + else + strcpy (a, "+inf.0"); + return ch+6; } - /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */ - return p.l; -} - -#else - - -void -scm_longdigs (long x, SCM_BIGDIG digs[]) -{ - size_t i = 0; - if (x < 0) - x = -x; - while (i < SCM_DIGSPERLONG) + else if (xisnan (f)) { - digs[i++] = SCM_BIGLO (x); - x = SCM_BIGDN (x); + strcpy (a, "+nan.0"); + return ch+6; } -} -#endif - - -SCM -scm_addbig (SCM_BIGDIG *x, size_t nx, int xsgn, SCM bigy, int sgny) -{ - /* Assumes nx <= SCM_NUMDIGS(bigy) */ - /* Assumes xsgn and sgny scm_equal either 0 or SCM_BIGSIGNFLAG */ - long num = 0; - size_t i = 0, ny = SCM_NUMDIGS (bigy); - SCM z = scm_i_copybig (bigy, SCM_BIGSIGN (bigy) ^ sgny); - SCM_BIGDIG *zds = SCM_BDIGITS (z); - if (xsgn ^ SCM_BIGSIGN (z)) - { - do - { - num += (long) zds[i] - x[i]; - if (num < 0) - { - zds[i] = num + SCM_BIGRAD; - num = -1; - } - else - { - zds[i] = SCM_BIGLO (num); - num = 0; - } - } - while (++i < nx); - if (num && nx == ny) - { - num = 1; - i = 0; - SCM_SET_CELL_WORD_0 (z, SCM_CELL_WORD_0 (z) ^ SCM_BIGSIGNFLAG); - do - { - num += (SCM_BIGRAD - 1) - zds[i]; - zds[i++] = SCM_BIGLO (num); - num = SCM_BIGDN (num); - } - while (i < ny); - } - else - while (i < ny) - { - num += zds[i]; - if (num < 0) - { - zds[i++] = num + SCM_BIGRAD; - num = -1; - } - else - { - zds[i++] = SCM_BIGLO (num); - num = 0; - } - } + if (f < 0.0) + { + f = -f; + a[ch++] = '-'; } - else + +#ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from + make-uniform-vector, from causing infinite loops. */ + while (f < 1.0) { - do - { - num += (long) zds[i] + x[i]; - zds[i++] = SCM_BIGLO (num); - num = SCM_BIGDN (num); - } - while (i < nx); - if (!num) - return z; - while (i < ny) - { - num += zds[i]; - zds[i++] = SCM_BIGLO (num); - num = SCM_BIGDN (num); - if (!num) - return z; - } - if (num) + f *= 10.0; + if (exp-- < DBL_MIN_10_EXP) { - z = scm_i_adjbig (z, ny + 1); - SCM_BDIGITS (z)[ny] = num; - return z; + a[ch++] = '#'; + a[ch++] = '.'; + a[ch++] = '#'; + return ch; } } - return scm_i_normbig (z); -} - - -SCM -scm_mulbig (SCM_BIGDIG *x, size_t nx, SCM_BIGDIG *y, size_t ny, int sgn) -{ - size_t i = 0, j = nx + ny; - unsigned long n = 0; - SCM z = scm_i_mkbig (j, sgn); - SCM_BIGDIG *zds = SCM_BDIGITS (z); - while (j--) - zds[j] = 0; - do + while (f > 10.0) { - j = 0; - if (x[i]) + f *= 0.10; + if (exp++ > DBL_MAX_10_EXP) { - do - { - n += zds[i + j] + ((unsigned long) x[i] * y[j]); - zds[i + j++] = SCM_BIGLO (n); - n = SCM_BIGDN (n); - } - while (j < ny); - if (n) - { - zds[i + j] = n; - n = 0; - } + a[ch++] = '#'; + a[ch++] = '.'; + a[ch++] = '#'; + return ch; } } - while (++i < nx); - return scm_i_normbig (z); -} - - -unsigned int -scm_divbigdig (SCM_BIGDIG * ds, size_t h, SCM_BIGDIG div) -{ - register unsigned long t2 = 0; - while (h--) - { - t2 = SCM_BIGUP (t2) + ds[h]; - ds[h] = t2 / div; - t2 %= div; - } - return t2; -} - - - -static SCM -scm_divbigint (SCM x, long z, int sgn, int mode) -{ - if (z < 0) - z = -z; - if (z < SCM_BIGRAD) - { - register unsigned long t2 = 0; - register SCM_BIGDIG *ds = SCM_BDIGITS (x); - size_t nd = SCM_NUMDIGS (x); - while (nd--) - t2 = (SCM_BIGUP (t2) + ds[nd]) % z; - if (mode && t2) - t2 = z - t2; - return SCM_MAKINUM (sgn ? -t2 : t2); - } - { -#ifndef SCM_DIGSTOOBIG - unsigned long t2 = scm_pseudolong (z); - return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), - (SCM_BIGDIG *) & t2, SCM_DIGSPERLONG, - sgn, mode); -#else - SCM_BIGDIG t2[SCM_DIGSPERLONG]; - scm_longdigs (z, t2); - return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), - t2, SCM_DIGSPERLONG, - sgn, mode); -#endif - } -} - - -static SCM -scm_divbigbig (SCM_BIGDIG *x, size_t nx, SCM_BIGDIG *y, size_t ny, int sgn, int modes) -{ - /* modes description - 0 remainder - 1 scm_modulo - 2 quotient - 3 quotient but returns SCM_UNDEFINED if division is not exact. */ - size_t i = 0, j = 0; - long num = 0; - unsigned long t2 = 0; - SCM z, newy; - SCM_BIGDIG d = 0, qhat, *zds, *yds; - /* algorithm requires nx >= ny */ - if (nx < ny) - switch (modes) - { - case 0: /* remainder -- just return x */ - z = scm_i_mkbig (nx, sgn); - zds = SCM_BDIGITS (z); - do - { - zds[i] = x[i]; - } - while (++i < nx); - return z; - case 1: /* scm_modulo -- return y-x */ - z = scm_i_mkbig (ny, sgn); - zds = SCM_BDIGITS (z); - do - { - num += (long) y[i] - x[i]; - if (num < 0) - { - zds[i] = num + SCM_BIGRAD; - num = -1; - } - else - { - zds[i] = num; - num = 0; - } - } - while (++i < nx); - while (i < ny) - { - num += y[i]; - if (num < 0) - { - zds[i++] = num + SCM_BIGRAD; - num = -1; - } - else - { - zds[i++] = num; - num = 0; - } - } - goto doadj; - case 2: - return SCM_INUM0; /* quotient is zero */ - case 3: - return SCM_UNDEFINED; /* the division is not exact */ - } - - z = scm_i_mkbig (nx == ny ? nx + 2 : nx + 1, sgn); - zds = SCM_BDIGITS (z); - if (nx == ny) - zds[nx + 1] = 0; - while (!y[ny - 1]) - ny--; /* in case y came in as a psuedolong */ - if (y[ny - 1] < (SCM_BIGRAD >> 1)) - { /* normalize operands */ - d = SCM_BIGRAD / (y[ny - 1] + 1); - newy = scm_i_mkbig (ny, 0); - yds = SCM_BDIGITS (newy); - while (j < ny) - { - t2 += (unsigned long) y[j] * d; - yds[j++] = SCM_BIGLO (t2); - t2 = SCM_BIGDN (t2); - } - y = yds; - j = 0; - t2 = 0; - while (j < nx) - { - t2 += (unsigned long) x[j] * d; - zds[j++] = SCM_BIGLO (t2); - t2 = SCM_BIGDN (t2); - } - zds[j] = t2; - } - else - { - zds[j = nx] = 0; - while (j--) - zds[j] = x[j]; - } - j = nx == ny ? nx + 1 : nx; /* dividend needs more digits than divisor */ - do - { /* loop over digits of quotient */ - if (zds[j] == y[ny - 1]) - qhat = SCM_BIGRAD - 1; - else - qhat = (SCM_BIGUP (zds[j]) + zds[j - 1]) / y[ny - 1]; - if (!qhat) - continue; - i = 0; - num = 0; - t2 = 0; - do - { /* multiply and subtract */ - t2 += (unsigned long) y[i] * qhat; - num += zds[j - ny + i] - SCM_BIGLO (t2); - if (num < 0) - { - zds[j - ny + i] = num + SCM_BIGRAD; - num = -1; - } - else - { - zds[j - ny + i] = num; - num = 0; - } - t2 = SCM_BIGDN (t2); - } - while (++i < ny); - num += zds[j - ny + i] - t2; /* borrow from high digit; don't update */ - while (num) - { /* "add back" required */ - i = 0; - num = 0; - qhat--; - do - { - num += (long) zds[j - ny + i] + y[i]; - zds[j - ny + i] = SCM_BIGLO (num); - num = SCM_BIGDN (num); - } - while (++i < ny); - num--; - } - if (modes & 2) - zds[j] = qhat; - } - while (--j >= ny); - switch (modes) - { - case 3: /* check that remainder==0 */ - for (j = ny; j && !zds[j - 1]; --j); - if (j) - return SCM_UNDEFINED; - case 2: /* move quotient down in z */ - j = (nx == ny ? nx + 2 : nx + 1) - ny; - for (i = 0; i < j; i++) - zds[i] = zds[i + ny]; - ny = i; - break; - case 1: /* subtract for scm_modulo */ - i = 0; - num = 0; - j = 0; - do - { - num += y[i] - zds[i]; - j = j | zds[i]; - if (num < 0) - { - zds[i] = num + SCM_BIGRAD; - num = -1; - } - else - { - zds[i] = num; - num = 0; - } - } - while (++i < ny); - if (!j) - return SCM_INUM0; - case 0: /* just normalize remainder */ - if (d) - scm_divbigdig (zds, ny, d); - } - doadj: - for (j = ny; j && !zds[j - 1]; --j); - if (j * SCM_BITSPERDIG <= sizeof (SCM) * SCM_CHAR_BIT) - if (SCM_INUMP (z = scm_i_big2inum (z, j))) - return z; - return scm_i_adjbig (z, j); -} -#endif - - - - - -/*** 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}; - - - - -static size_t -idbl2str (double f, char *a) -{ - int efmt, dpt, d, i, wp = scm_dblprec; - size_t ch = 0; - int exp = 0; - - if (f == 0.0) - goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */ - if (f < 0.0) - { - f = -f; - a[ch++] = '-'; - } - else if (f > 0.0); - else - goto funny; - if (IS_INF (f)) - { - if (ch == 0) - a[ch++] = '+'; - funny: - a[ch++] = '#'; - a[ch++] = '.'; - a[ch++] = '#'; - return ch; - } -#ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from - make-uniform-vector, from causing infinite loops. */ - while (f < 1.0) - { - f *= 10.0; - if (exp-- < DBL_MIN_10_EXP) - goto funny; - } - while (f > 10.0) - { - f *= 0.10; - if (exp++ > DBL_MAX_10_EXP) - goto funny; - } #else while (f < 1.0) { @@ -2072,9 +2155,12 @@ iflo2str (SCM flt, char *str) i = idbl2str (SCM_COMPLEX_REAL (flt), str); if (SCM_COMPLEX_IMAG (flt) != 0.0) { - if (0 <= SCM_COMPLEX_IMAG (flt)) + double imag = SCM_COMPLEX_IMAG (flt); + /* Don't output a '+' for negative numbers or for Inf and + NaN. They will provide their own sign. */ + if (0 <= imag && !xisinf (imag) && !xisnan (imag)) str[i++] = '+'; - i += idbl2str (SCM_COMPLEX_IMAG (flt), &str[i]); + i += idbl2str (imag, &str[i]); str[i++] = 'i'; } } @@ -2114,58 +2200,6 @@ scm_iint2str (long num, int rad, char *p) return j; } - -#ifdef SCM_BIGDIG - -static SCM -big2str (SCM b, unsigned int radix) -{ - SCM t = scm_i_copybig (b, 0); /* sign of temp doesn't matter */ - register SCM_BIGDIG *ds = SCM_BDIGITS (t); - size_t i = SCM_NUMDIGS (t); - size_t j = radix == 16 ? (SCM_BITSPERDIG * i) / 4 + 2 - : radix >= 10 ? (SCM_BITSPERDIG * i * 241L) / 800 + 2 - : (SCM_BITSPERDIG * i) + 2; - size_t k = 0; - size_t radct = 0; - SCM_BIGDIG radpow = 1, radmod = 0; - SCM ss = scm_allocate_string (j); - char *s = SCM_STRING_CHARS (ss), c; - while ((long) radpow * radix < SCM_BIGRAD) - { - radpow *= radix; - radct++; - } - while ((i || radmod) && j) - { - if (k == 0) - { - radmod = (SCM_BIGDIG) scm_divbigdig (ds, i, radpow); - k = radct; - if (!ds[i - 1]) - i--; - } - c = radmod % radix; - radmod /= radix; - k--; - s[--j] = c < 10 ? c + '0' : c + 'a' - 10; - } - - if (SCM_BIGSIGN (b)) - s[--j] = '-'; - - if (j > 0) - { - /* The pre-reserved string length was too large. */ - unsigned long int length = SCM_STRING_LENGTH (ss); - ss = scm_substring (ss, SCM_MAKINUM (j), SCM_MAKINUM (length)); - } - - return scm_return_first (ss, t); -} -#endif - - 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" @@ -2175,32 +2209,48 @@ 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); - SCM_ASSERT_RANGE (2, radix, base >= 2); - } + 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)) { - return big2str (n, (unsigned int) base); - } 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)); + } + else SCM_WRONG_TYPE_ARG (1, n); - } } #undef FUNC_NAME -/* These print routines are stubbed here so that scm_repl.c doesn't need - SCM_BIGDIG conditionals */ +/* These print routines used to be stubbed here so that scm_repl.c + wouldn't need SCM_BIGDIG conditionals (pre GMP) */ int scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) @@ -2212,21 +2262,31 @@ scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) 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); 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; +} + int scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { -#ifdef SCM_BIGDIG - exp = big2str (exp, (unsigned int) 10); - scm_lfwrite (SCM_STRING_CHARS (exp), (size_t) SCM_STRING_LENGTH (exp), port); -#else - scm_ipruk ("bignum", exp, port); -#endif + char *str = mpz_get_str (NULL, 10, SCM_I_BIG_MPZ (exp)); + scm_remember_upto_here_1 (exp); + scm_lfwrite (str, (size_t) strlen (str), port); + free (str); return !0; } /*** END nums->strs ***/ @@ -2479,7 +2539,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; @@ -2506,10 +2566,29 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, unsigned int radix, enum t_exactness *p_exactness) { unsigned int idx = *p_idx; + SCM result; if (idx == len) return SCM_BOOL_F; + if (idx+5 <= len && !strncmp (mem+idx, "inf.0", 5)) + { + *p_idx = idx+5; + return scm_inf (); + } + + if (idx+4 < len && !strncmp (mem+idx, "nan.", 4)) + { + enum t_exactness x = EXACT; + + /* 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; + return scm_nan (); + } + if (mem[idx] == '.') { if (radix != 10) @@ -2519,14 +2598,13 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, else if (!isdigit (mem[idx + 1])) return SCM_BOOL_F; else - return mem2decimal_from_point (SCM_MAKINUM (0), mem, len, - p_idx, p_exactness); + result = mem2decimal_from_point (SCM_MAKINUM (0), mem, len, + p_idx, p_exactness); } else { enum t_exactness x = EXACT; SCM uinteger; - SCM result; uinteger = mem2uinteger (mem, len, &idx, radix, &x); if (SCM_FALSEP (uinteger)) @@ -2544,7 +2622,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) { @@ -2558,9 +2637,15 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, *p_idx = idx; if (x == INEXACT) *p_exactness = x; - - return result; } + + /* When returning an inexact zero, make sure it is represented as a + floating point value so that we can change its sign. + */ + if (SCM_EQ_P (result, SCM_MAKINUM(0)) && *p_exactness == INEXACT) + result = scm_make_real (0.0); + + return result; } @@ -2613,7 +2698,7 @@ mem2complex (const char* mem, size_t len, unsigned int idx, } else { - if (sign == -1) + if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal))) ureal = scm_difference (ureal, SCM_UNDEFINED); if (idx == len) @@ -2664,7 +2749,7 @@ mem2complex (const char* mem, size_t len, unsigned int idx, if (idx != len) return SCM_BOOL_F; - if (sign == -1) + if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal))) angle = scm_difference (angle, SCM_UNDEFINED); result = scm_make_polar (ureal, angle); @@ -2684,7 +2769,7 @@ mem2complex (const char* mem, size_t len, unsigned int idx, if (SCM_FALSEP (imag)) imag = SCM_MAKINUM (sign); - else if (sign == -1) + else if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal))) imag = scm_difference (imag, SCM_UNDEFINED); if (idx == len) @@ -2772,7 +2857,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; @@ -2811,10 +2895,10 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, SCM answer; int base; SCM_VALIDATE_STRING (1, string); - SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix,2,10,base); + 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 @@ -2826,8 +2910,8 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, SCM scm_make_real (double x) { - SCM z; - z = scm_alloc_double_cell (scm_tc16_real, 0, 0, 0); + SCM z = scm_double_cell (scm_tc16_real, 0, 0, 0); + SCM_REAL_VALUE (z) = x; return z; } @@ -2836,26 +2920,26 @@ 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_must_malloc (2L * 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) { -#ifdef SCM_BIGDIG - if (0 == scm_bigcomp (x, y)) - return SCM_BOOL_T; -#endif - return SCM_BOOL_F; + 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); } SCM @@ -2871,6 +2955,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); @@ -2882,7 +2979,7 @@ SCM_REGISTER_PROC (s_number_p, "number?", 1, 0, 0, scm_number_p); SCM_DEFINE (scm_number_p, "complex?", 1, 0, 0, (SCM x), "Return @code{#t} if @var{x} is a complex number, @code{#f}\n" - "else. Note that the sets of real, rational and integer\n" + "otherwise. Note that the sets of real, rational and integer\n" "values form subsets of the set of complex numbers, i. e. the\n" "predicate will also be fulfilled if @var{x} is a real,\n" "rational or integer number.") @@ -2893,33 +2990,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" - "else. Note that the set of integer values forms a subset of\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 @@ -2955,7 +3060,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 @@ -2965,69 +3074,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)) { - return SCM_BOOL (0 == scm_bigcomp (x, y)); - } else if (SCM_REALP (y)) { - return SCM_BOOL (scm_i_big2dbl (x) == SCM_REAL_VALUE (y)); - } else if (SCM_COMPLEXP (y)) { - return SCM_BOOL ((scm_i_big2dbl (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_REALP (x)) { - if (SCM_INUMP (y)) { - return SCM_BOOL (SCM_REAL_VALUE (x) == (double) SCM_INUM (y)); - } else if (SCM_BIGP (y)) { - return SCM_BOOL (SCM_REAL_VALUE (x) == scm_i_big2dbl (y)); - } 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)) { - return SCM_BOOL ((SCM_COMPLEX_REAL (x) == scm_i_big2dbl (y)) - && (SCM_COMPLEX_IMAG (x) == 0.0)); - } 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." @@ -3035,41 +3251,125 @@ 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)) { - return SCM_BOOL (!SCM_BIGSIGN (y)); - } else if (SCM_REALP (y)) { - return SCM_BOOL ((double) xx < SCM_REAL_VALUE (y)); - } else { - SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); - } - } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) { - return SCM_BOOL (SCM_BIGSIGN (x)); - } else if (SCM_BIGP (y)) { - return SCM_BOOL (1 == scm_bigcomp (x, y)); - } else if (SCM_REALP (y)) { - return SCM_BOOL (scm_i_big2dbl (x) < SCM_REAL_VALUE (y)); - } 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)) { - return SCM_BOOL (SCM_REAL_VALUE (x) < scm_i_big2dbl (y)); - } 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); + 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 { - SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, 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 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); } @@ -3103,6 +3403,8 @@ scm_leq_p (SCM x, SCM y) SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG1, FUNC_NAME); else if (!SCM_NUMBERP (y)) SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG2, FUNC_NAME); + else if (SCM_NFALSEP (scm_nan_p (x)) || SCM_NFALSEP (scm_nan_p (y))) + return SCM_BOOL_F; else return SCM_BOOL_NOT (scm_less_p (y, x)); } @@ -3121,8 +3423,10 @@ scm_geq_p (SCM x, SCM y) SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG1, FUNC_NAME); else if (!SCM_NUMBERP (y)) SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG2, FUNC_NAME); + else if (SCM_NFALSEP (scm_nan_p (x)) || SCM_NFALSEP (scm_nan_p (y))) + return SCM_BOOL_F; else - return SCM_BOOL_NOT (scm_less_p (x, y)); + return SCM_BOOL_NOT (scm_less_p (x, y)); } #undef FUNC_NAME @@ -3134,18 +3438,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); - } } @@ -3156,15 +3461,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)) { - return SCM_BOOL (!SCM_BIGSIGN (x)); - } 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); - } } @@ -3175,73 +3485,169 @@ 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)) { - return SCM_BOOL (SCM_BIGSIGN (x)); - } 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)) { - return SCM_BIGSIGN (y) ? 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)) { - return SCM_BIGSIGN (x) ? y : x; - } else if (SCM_BIGP (y)) { - return (1 == scm_bigcomp (x, y)) ? y : x; - } else if (SCM_REALP (y)) { - double z = scm_i_big2dbl (x); - 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_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)) { - double z = scm_i_big2dbl (y); - return (SCM_REAL_VALUE (x) < z) ? scm_make_real (z) : x; - } 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)) + { + double z = xx; + return (z > scm_i_fraction2double (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)) + { + double yy = scm_i_fraction2double (y); + int cmp; + cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy); + scm_remember_upto_here_1 (x); + return (cmp > 0) ? x : y; + } + else + SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); + } + else if (SCM_REALP (x)) + { + if (SCM_INUMP (y)) + { + double z = SCM_INUM (y); + /* if x==NaN then "<" is false and we return NaN */ + return (SCM_REAL_VALUE (x) < z) ? scm_make_real (z) : x; + } + else if (SCM_BIGP (y)) + { + SCM t = x; x = y; y = t; + 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)) + { + double z = SCM_INUM (y); + return (scm_i_fraction2double (x) < z) ? y : x; + } + else if (SCM_BIGP (y)) + { + double xx = scm_i_fraction2double (x); + int cmp; + cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx); + scm_remember_upto_here_1 (y); + return (cmp < 0) ? x : y; + } + else if (SCM_REALP (y)) + { + double xx = scm_i_fraction2double (x); + return (xx < SCM_REAL_VALUE (y)) ? y : scm_make_real (xx); + } + else if (SCM_FRACTIONP (y)) + { + double yy = scm_i_fraction2double (y); + double xx = scm_i_fraction2double (x); + return (xx < yy) ? y : x; + } + 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); - } } @@ -3251,55 +3657,140 @@ 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)) { - return SCM_BIGSIGN (y) ? 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)) { - return SCM_BIGSIGN (x) ? x : y; - } else if (SCM_BIGP (y)) { - return (-1 == scm_bigcomp (x, y)) ? y : x; - } else if (SCM_REALP (y)) { - double z = scm_i_big2dbl (x); - 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_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)) { - double z = scm_i_big2dbl (y); - return (SCM_REAL_VALUE (x) <= z) ? x : scm_make_real (z); - } 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)) + { + double z = xx; + return (z < scm_i_fraction2double (y)) ? x : y; + } + 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) ? y : x; + } + else + SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min); + } + else if (SCM_REALP (x)) + { + if (SCM_INUMP (y)) + { + double z = SCM_INUM (y); + /* if x==NaN then "<" is false and we return NaN */ + return (z < SCM_REAL_VALUE (x)) ? scm_make_real (z) : x; + } + else if (SCM_BIGP (y)) + { + SCM t = x; x = y; y = t; + 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 (yy < xx) ? scm_make_real (yy) : x; + } + else + SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_INUMP (y)) + { + double z = SCM_INUM (y); + return (scm_i_fraction2double (x) < z) ? x : y; + } + else if (SCM_BIGP (y)) + { + double xx = scm_i_fraction2double (x); + int cmp; + cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx); + scm_remember_upto_here_1 (y); + return (cmp < 0) ? y : x; + } + else if (SCM_REALP (y)) + { + double xx = scm_i_fraction2double (x); + return (SCM_REAL_VALUE (y) < xx) ? y : scm_make_real (xx); + } + else if (SCM_FRACTIONP (y)) + { + double yy = scm_i_fraction2double (y); + double xx = scm_i_fraction2double (x); + return (xx < yy) ? x : y; + } + else + SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); + } + else SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min); - } } @@ -3310,103 +3801,179 @@ SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum); SCM scm_sum (SCM x, SCM y) { - if (SCM_UNBNDP (y)) { - if (SCM_UNBNDP (x)) { - return SCM_INUM0; - } else if (SCM_NUMBERP (x)) { - return x; - } else { + if (SCM_UNBNDP (y)) + { + if (SCM_NUMBERP (x)) return x; + if (SCM_UNBNDP (x)) return SCM_INUM0; SCM_WTA_DISPATCH_1 (g_sum, x, SCM_ARG1, s_sum); } - } - if (SCM_INUMP (x)) { - long int xx = SCM_INUM (x); - if (SCM_INUMP (y)) { - long int yy = SCM_INUM (y); - long int z = xx + yy; - if (SCM_FIXABLE (z)) { - return SCM_MAKINUM (z); - } else { -#ifdef SCM_BIGDIG - return scm_i_long2big (z); -#else /* SCM_BIGDIG */ - return scm_make_real ((double) z); -#endif /* SCM_BIGDIG */ - } - } else if (SCM_BIGP (y)) { - intbig: + if (SCM_INUMP (x)) + { + if (SCM_INUMP (y)) + { + long xx = SCM_INUM (x); + long yy = SCM_INUM (y); + long int z = xx + yy; + return SCM_FIXABLE (z) ? SCM_MAKINUM (z) : scm_i_long2big (z); + } + else if (SCM_BIGP (y)) + { + SCM_SWAP (x, y); + goto add_big_inum; + } + 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)) + return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y), + scm_product (x, SCM_FRACTION_DENOMINATOR (y))), + SCM_FRACTION_DENOMINATOR (y)); + else + SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); + } else if (SCM_BIGP (x)) { - long int xx = SCM_INUM (x); -#ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong (xx); - return scm_addbig ((SCM_BIGDIG *) & z, SCM_DIGSPERLONG, - (xx < 0) ? SCM_BIGSIGNFLAG : 0, y, 0); -#else /* SCM_DIGSTOOBIG */ - SCM_BIGDIG zdigs [SCM_DIGSPERLONG]; - scm_longdigs (xx, zdigs); - return scm_addbig (zdigs, SCM_DIGSPERLONG, - (xx < 0) ? SCM_BIGSIGNFLAG : 0, y, 0); -#endif /* SCM_DIGSTOOBIG */ - } - } 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), - SCM_COMPLEX_IMAG (y)); - } else { - SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); - } - } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) { - SCM_SWAP (x, y); - goto intbig; - } else if (SCM_BIGP (y)) { - if (SCM_NUMDIGS (x) > SCM_NUMDIGS (y)) { - SCM_SWAP (x, y); + if (SCM_INUMP (y)) + { + long int inum; + int bigsgn; + add_big_inum: + inum = SCM_INUM (y); + if (inum == 0) + return x; + bigsgn = mpz_sgn (SCM_I_BIG_MPZ (x)); + if (inum < 0) + { + SCM result = scm_i_mkbig (); + mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - inum); + scm_remember_upto_here_1 (x); + /* we know the result will have to be a bignum */ + if (bigsgn == -1) + return result; + return scm_i_normbig (result); + } + else + { + SCM result = scm_i_mkbig (); + mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), inum); + scm_remember_upto_here_1 (x); + /* we know the result will have to be a bignum */ + if (bigsgn == 1) + return result; + return scm_i_normbig (result); + } + } + else if (SCM_BIGP (y)) + { + SCM result = scm_i_mkbig (); + int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x)); + int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); + mpz_add (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 == sgn_y) + 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_sum (SCM_FRACTION_NUMERATOR (y), + scm_product (x, SCM_FRACTION_DENOMINATOR (y))), + SCM_FRACTION_DENOMINATOR (y)); + else + SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); } - return scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), - SCM_BIGSIGN (x), y, 0); - } else if (SCM_REALP (y)) { - return scm_make_real (scm_i_big2dbl (x) + SCM_REAL_VALUE (y)); - } else if (SCM_COMPLEXP (y)) { - return scm_make_complex (scm_i_big2dbl (x) + SCM_COMPLEX_REAL (y), - SCM_COMPLEX_IMAG (y)); - } else { - SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); - } - } 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)) { - return scm_make_real (SCM_REAL_VALUE (x) + scm_i_big2dbl (y)); - } 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_sum, x, y, SCM_ARGn, s_sum); - } - } 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)) { - return scm_make_complex (SCM_COMPLEX_REAL (x) + scm_i_big2dbl (y), - SCM_COMPLEX_IMAG (x)); - } 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_sum, x, y, SCM_ARGn, s_sum); + 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 = 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_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_sum, x, y, SCM_ARGn, s_sum); } - } else { + 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 = (mpz_get_d (SCM_I_BIG_MPZ (y)) + + SCM_COMPLEX_REAL (x)); + scm_remember_upto_here_1 (y); + return scm_make_complex (real_part, SCM_COMPLEX_IMAG (x)); + } + 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_sum, x, y, SCM_ARGn, s_sum); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_INUMP (y)) + return scm_make_ratio (scm_sum (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_sum (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_REAL_VALUE (y) + scm_i_fraction2double (x)); + else if (SCM_COMPLEXP (y)) + return scm_make_complex (SCM_COMPLEX_REAL (y) + scm_i_fraction2double (x), + SCM_COMPLEX_IMAG (y)); + else if (SCM_FRACTIONP (y)) + /* a/b + c/d = (ad + bc) / bd */ + return scm_make_ratio (scm_sum (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_sum, x, y, SCM_ARGn, s_sum); + } + else SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum); - } } @@ -3418,129 +3985,231 @@ SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference); SCM scm_difference (SCM x, SCM y) { - if (SCM_UNBNDP (y)) { - if (SCM_UNBNDP (x)) { - SCM_WTA_DISPATCH_0 (g_difference, s_difference); - } else if (SCM_INUMP (x)) { - long xx = -SCM_INUM (x); - if (SCM_FIXABLE (xx)) { - return SCM_MAKINUM (xx); - } else { -#ifdef SCM_BIGDIG - return scm_i_long2big (xx); -#else - return scm_make_real ((double) xx); -#endif - } - } else if (SCM_BIGP (x)) { - SCM z = scm_i_copybig (x, !SCM_BIGSIGN (x)); - unsigned int digs = SCM_NUMDIGS (z); - unsigned int size = digs * SCM_BITSPERDIG / SCM_CHAR_BIT; - return size <= sizeof (SCM) ? scm_i_big2inum (z, digs) : z; - } else if (SCM_REALP (x)) { - return scm_make_real (-SCM_REAL_VALUE (x)); - } else if (SCM_COMPLEXP (x)) { - return scm_make_complex (-SCM_COMPLEX_REAL (x), -SCM_COMPLEX_IMAG (x)); - } else { - SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference); + if (SCM_UNBNDP (y)) + { + if (SCM_UNBNDP (x)) + SCM_WTA_DISPATCH_0 (g_difference, s_difference); + else + if (SCM_INUMP (x)) + { + long xx = -SCM_INUM (x); + if (SCM_FIXABLE (xx)) + return SCM_MAKINUM (xx); + else + return scm_i_long2big (xx); + } + else if (SCM_BIGP (x)) + /* FIXME: do we really need to normalize here? */ + return scm_i_normbig (scm_i_clonebig (x, 0)); + else if (SCM_REALP (x)) + return scm_make_real (-SCM_REAL_VALUE (x)); + else if (SCM_COMPLEXP (x)) + return scm_make_complex (-SCM_COMPLEX_REAL (x), + -SCM_COMPLEX_IMAG (x)); + else if (SCM_FRACTIONP (x)) + return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED), + SCM_FRACTION_DENOMINATOR (x)); + else + SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference); } - } + + if (SCM_INUMP (x)) + { + if (SCM_INUMP (y)) + { + long int xx = SCM_INUM (x); + long int yy = SCM_INUM (y); + long int z = xx - yy; + if (SCM_FIXABLE (z)) + return SCM_MAKINUM (z); + else + return scm_i_long2big (z); + } + else if (SCM_BIGP (y)) + { + /* inum-x - big-y */ + long xx = SCM_INUM (x); - if (SCM_INUMP (x)) { - long int xx = SCM_INUM (x); - if (SCM_INUMP (y)) { - long int yy = SCM_INUM (y); - long int z = xx - yy; - if (SCM_FIXABLE (z)) { - return SCM_MAKINUM (z); - } else { -#ifdef SCM_BIGDIG - return scm_i_long2big (z); -#else - return scm_make_real ((double) z); -#endif - } - } else if (SCM_BIGP (y)) { -#ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong (xx); - return scm_addbig ((SCM_BIGDIG *) & z, SCM_DIGSPERLONG, - (xx < 0) ? SCM_BIGSIGNFLAG : 0, y, SCM_BIGSIGNFLAG); -#else - SCM_BIGDIG zdigs [SCM_DIGSPERLONG]; - scm_longdigs (xx, zdigs); - return scm_addbig (zdigs, SCM_DIGSPERLONG, - (xx < 0) ? SCM_BIGSIGNFLAG : 0, y, SCM_BIGSIGNFLAG); -#endif - } 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), - -SCM_COMPLEX_IMAG (y)); - } else { - SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); - } - } else if (SCM_BIGP (x)) { - if (SCM_INUMP (y)) { - long int yy = SCM_INUM (y); -#ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong (yy); - return scm_addbig ((SCM_BIGDIG *) & z, SCM_DIGSPERLONG, - (yy < 0) ? 0 : SCM_BIGSIGNFLAG, x, 0); -#else - SCM_BIGDIG zdigs [SCM_DIGSPERLONG]; - scm_longdigs (yy, zdigs); - return scm_addbig (zdigs, SCM_DIGSPERLONG, - (yy < 0) ? 0 : SCM_BIGSIGNFLAG, x, 0); -#endif - } else if (SCM_BIGP (y)) { - return (SCM_NUMDIGS (x) < SCM_NUMDIGS (y)) - ? scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), - SCM_BIGSIGN (x), y, SCM_BIGSIGNFLAG) - : scm_addbig (SCM_BDIGITS (y), SCM_NUMDIGS (y), - SCM_BIGSIGN (y) ^ SCM_BIGSIGNFLAG, x, 0); - } else if (SCM_REALP (y)) { - return scm_make_real (scm_i_big2dbl (x) - SCM_REAL_VALUE (y)); - } else if (SCM_COMPLEXP (y)) { - return scm_make_complex (scm_i_big2dbl (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_REALP (x)) { - if (SCM_INUMP (y)) { - return scm_make_real (SCM_REAL_VALUE (x) - SCM_INUM (y)); - } else if (SCM_BIGP (y)) { - return scm_make_real (SCM_REAL_VALUE (x) - scm_i_big2dbl (y)); - } 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)) { - return scm_make_complex (SCM_COMPLEX_REAL (x) - scm_i_big2dbl (y), - SCM_COMPLEX_IMAG (x)); - } 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); + if (xx == 0) + return scm_i_clonebig (y, 0); + else + { + int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); + SCM result = scm_i_mkbig (); + + if (xx >= 0) + 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 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 { + 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 (); + + 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); + } + } + 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_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 (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 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 + SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product); /* "Return the product of all arguments. If called without arguments,\n" * "1 is returned." @@ -3548,446 +4217,839 @@ 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); - - if (xx == 0) { - return x; - } else if (xx == 1) { - return y; - } - - 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) { -#ifdef SCM_BIGDIG - int sgn = (xx < 0) ^ (yy < 0); -#ifndef SCM_DIGSTOOBIG - long i = scm_pseudolong (xx); - long j = scm_pseudolong (yy); - return scm_mulbig ((SCM_BIGDIG *) & i, SCM_DIGSPERLONG, - (SCM_BIGDIG *) & j, SCM_DIGSPERLONG, sgn); -#else /* SCM_DIGSTOOBIG */ - SCM_BIGDIG xdigs [SCM_DIGSPERLONG]; - SCM_BIGDIG ydigs [SCM_DIGSPERLONG]; - scm_longdigs (xx, xdigs); - scm_longdigs (yy, ydigs); - return scm_mulbig (xdigs, SCM_DIGSPERLONG, - ydigs, SCM_DIGSPERLONG, - sgn); -#endif -#else - return scm_make_real (((double) xx) * ((double) yy)); -#endif - } else { - return k; - } - } else if (SCM_BIGP (y)) { -#ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong (xx); - return scm_mulbig ((SCM_BIGDIG *) & z, SCM_DIGSPERLONG, - SCM_BDIGITS (y), SCM_NUMDIGS (y), - SCM_BIGSIGN (y) ? (xx > 0) : (xx < 0)); -#else - SCM_BIGDIG zdigs [SCM_DIGSPERLONG]; - scm_longdigs (xx, zdigs); - return scm_mulbig (zdigs, SCM_DIGSPERLONG, - SCM_BDIGITS (y), SCM_NUMDIGS (y), - SCM_BIGSIGN (y) ? (xx > 0) : (xx < 0)); -#endif - } 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)) { - return scm_mulbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), - SCM_BDIGITS (y), SCM_NUMDIGS (y), - SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y)); - } else if (SCM_REALP (y)) { - return scm_make_real (scm_i_big2dbl (x) * SCM_REAL_VALUE (y)); - } else if (SCM_COMPLEXP (y)) { - double z = scm_i_big2dbl (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)) { - return scm_make_real (scm_i_big2dbl (y) * SCM_REAL_VALUE (x)); - } 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 = scm_i_big2dbl (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 { - SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); + intbig: + xx = SCM_INUM (x); + + 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 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)) { - return scm_i_big2dbl (a); - } 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 +#if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \ + || (defined (HAVE_FINITE) && defined (HAVE_ISNAN))) +#define ALLOW_DIVIDE_BY_ZERO +/* #define ALLOW_DIVIDE_BY_EXACT_ZERO */ +#endif + +/* The code below for complex division is adapted from the GNU + libstdc++, which adapted it from f2c's libF77, and is subject to + this copyright: */ + +/**************************************************************** +Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide); /* Divide the first argument by the product of the remaining 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)) { + 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); +#endif + 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 +#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 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 (xx == 1 || xx == -1) { - return x; - } else if (xx == 0) { - scm_num_overflow (s_divide); - } 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); - if (xx == 0.0) - scm_num_overflow (s_divide); + if (SCM_INUMP (y)) + { + long yy = SCM_INUM (y); + if (yy == 0) + { +#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO + scm_num_overflow (s_divide); +#else + return scm_make_real ((double) xx / (double) yy); +#endif + } + 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)) + { + 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 +#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); + } + } + } + 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) + { +#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO + 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 (); +#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 + { + 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); +#else + 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 + 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 +#endif + 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 - return scm_make_real (1.0 / xx); - } else if (SCM_COMPLEXP (x)) { - double r = SCM_COMPLEX_REAL (x); - double i = SCM_COMPLEX_IMAG (x); - double d = r * r + i * i; - return scm_make_complex (r / d, -i / d); - } else { - SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide); + SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); } - } - - 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_divide); - } 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 { -#ifdef SCM_BIGDIG - return scm_i_long2big (z); -#else - return scm_make_real ((double) xx / (double) yy); + 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 + { + double d = yy; + return scm_make_complex (rx / d, ix / d); + } } - } - } 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); - if (yy == 0.0) - scm_num_overflow (s_divide); - else - 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); - double d = r * r + i * i; - return scm_make_complex ((a * r) / d, (-a * i) / d); - } - } 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) { - scm_num_overflow (s_divide); - } else if (yy == 1) { - return x; - } else { - long z = yy < 0 ? -yy : yy; - if (z < SCM_BIGRAD) { - SCM w = scm_i_copybig (x, SCM_BIGSIGN (x) ? (yy > 0) : (yy < 0)); - return scm_divbigdig (SCM_BDIGITS (w), SCM_NUMDIGS (w), - (SCM_BIGDIG) z) - ? scm_make_real (scm_i_big2dbl (x) / (double) yy) - : scm_i_normbig (w); - } else { - SCM w; -#ifndef SCM_DIGSTOOBIG - z = scm_pseudolong (z); - w = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), - (SCM_BIGDIG *) & z, SCM_DIGSPERLONG, - SCM_BIGSIGN (x) ? (yy > 0) : (yy < 0), 3); -#else - SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs (z, zdigs); - w = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), - zdigs, SCM_DIGSPERLONG, - SCM_BIGSIGN (x) ? (yy > 0) : (yy < 0), 3); + 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 #endif - return (!SCM_UNBNDP (w)) - ? w - : scm_make_real (scm_i_big2dbl (x) / (double) yy); + 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 if (SCM_BIGP (y)) { - SCM w = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), - SCM_BDIGITS (y), SCM_NUMDIGS (y), - SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y), 3); - return (!SCM_UNBNDP (w)) - ? w - : scm_make_real (scm_i_big2dbl (x) / scm_i_big2dbl (y)); - } else if (SCM_REALP (y)) { - double yy = SCM_REAL_VALUE (y); - if (yy == 0.0) - scm_num_overflow (s_divide); - else - 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); - if (yy == 0) { - scm_num_overflow (s_divide); - } else { - return scm_make_real (rx / (double) yy); - } - } else if (SCM_BIGP (y)) { - return scm_make_real (rx / scm_i_big2dbl (y)); - } else if (SCM_REALP (y)) { - double yy = SCM_REAL_VALUE (y); - if (yy == 0.0) - scm_num_overflow (s_divide); - else - 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); - if (yy == 0) { - scm_num_overflow (s_divide); - } else { - double d = yy; - return scm_make_complex (rx / d, ix / d); - } - } else if (SCM_BIGP (y)) { - double d = scm_i_big2dbl (y); - return scm_make_complex (rx / d, ix / d); - } else if (SCM_REALP (y)) { - double yy = SCM_REAL_VALUE (y); - if (yy == 0.0) - scm_num_overflow (s_divide); else - 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); - double d = ry * ry + iy * iy; - return scm_make_complex ((rx * ry + ix * iy) / d, - (ix * ry - rx * iy) / d); - } else { - SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); + SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); } - } else { + 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 + 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 +#endif + 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 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_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); /* 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 + +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_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); +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}." */ @@ -4004,25 +5066,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); - } } @@ -4075,8 +5139,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 @@ -4087,17 +5158,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); - } } @@ -4107,19 +5179,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" @@ -4128,34 +5243,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 { -#ifdef SCM_BIGDIG - return scm_i_long2big (-zz); -#else - scm_num_overflow (s_magnitude); -#endif + 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)) { - if (!SCM_BIGSIGN (z)) { - return z; - } else { - return scm_i_copybig (z, 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_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); - } } @@ -4165,25 +5284,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)) { - if (SCM_BIGSIGN (z)) { - 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); - } } @@ -4197,6 +5334,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 @@ -4209,77 +5348,106 @@ 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); -#ifdef SCM_BIGDIG - } else if (isfinite (u)) { - return scm_i_dbl2big (u); -#endif - } 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 - -#ifdef SCM_BIGDIG -/* d must be integer */ - -SCM -scm_i_dbl2big (double d) +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 { - size_t i = 0; - long c; - SCM_BIGDIG *digits; - SCM ans; - double u = (d < 0) ? -d : d; - while (0 != floor (u)) - { - u /= SCM_BIGRAD; - i++; - } - ans = scm_i_mkbig (i, d < 0); - digits = SCM_BDIGITS (ans); - while (i--) + if (SCM_INUMP (x)) + return x; + else if (SCM_BIGP (x)) + return x; + else if ((SCM_REALP (x)) || SCM_FRACTIONP (x)) { - u *= SCM_BIGRAD; - c = floor (u); - u -= c; - digits[i] = c; + /* 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); } -#ifndef SCM_RECKLESS - if (u != 0) - scm_num_overflow ("dbl2big"); -#endif - return ans; -} - -double -scm_i_big2dbl (SCM b) -{ - double ans = 0.0; - size_t i = SCM_NUMDIGS (b); - SCM_BIGDIG *digits = SCM_BDIGITS (b); - while (i--) - ans = digits[i] + SCM_BIGRAD * ans; - if (SCM_BIGSIGN (b)) - return - ans; - return ans; + else + SCM_WRONG_TYPE_ARG (1, x); } +#undef FUNC_NAME -#endif - -#ifdef HAVE_LONG_LONGS +/* if you need to change this, change test-num2integral.c as well */ +#if SCM_SIZEOF_LONG_LONG != 0 # ifndef LLONG_MAX # define ULLONG_MAX ((unsigned long long) (-1)) # define LLONG_MAX ((long long) (ULLONG_MAX >> 1)) @@ -4293,39 +5461,37 @@ scm_i_big2dbl (SCM b) "libguile/num2integral.i.c": NUM2INTEGRAL - the name of the function for converting from a - Scheme object to the integral type. This function - will be defined when including "num2integral.i.c". + Scheme object to the integral type. This function will be + defined when including "num2integral.i.c". INTEGRAL2NUM - the name of the function for converting from the - integral type to a Scheme object. This function - will be defined. + integral type to a Scheme object. This function will be defined. INTEGRAL2BIG - the name of an internal function that createas a - bignum from the integral type. This function will - be defined. The name should start with "scm_i_". - - ITYPE - the name of the integral type. - - UNSIGNED - Define this when ITYPE is an unsigned type. Do not - define it otherwise. - - UNSIGNED_ITYPE - - the name of the the unsigned variant of the - integral type. If you don't define this, it defaults - to "unsigned ITYPE" for signed types and simply "ITYPE" - for unsigned ones. - - SIZEOF_ITYPE - an expression giving the size of the integral type in - bytes. This expression must be computable by the - preprocessor. If you don't know a value for this, - don't define it. The purpose of this parameter is - mainly to suppress some warnings. The generated - code will work correctly without it. + bignum from the integral type. This function will be defined. + The name should start with "scm_i_". + + ITYPE - the name of the integral type. + + UNSIGNED - Define this to 1 when ITYPE is an unsigned type. Define + it to 0 otherwise. + + UNSIGNED_ITYPE - the name of the the unsigned variant of the + integral type. If you don't define this, it defaults to + "unsigned ITYPE" for signed types and simply "ITYPE" for unsigned + ones. + + SIZEOF_ITYPE - an expression giving the size of the integral type + in bytes. This expression must be computable by the + preprocessor. (SIZEOF_FOO values are calculated by configure.in + for common types). + */ #define NUM2INTEGRAL scm_num2short #define INTEGRAL2NUM scm_short2num #define INTEGRAL2BIG scm_i_short2big +#define UNSIGNED 0 #define ITYPE short #define SIZEOF_ITYPE SIZEOF_SHORT #include "libguile/num2integral.i.c" @@ -4333,14 +5499,15 @@ scm_i_big2dbl (SCM b) #define NUM2INTEGRAL scm_num2ushort #define INTEGRAL2NUM scm_ushort2num #define INTEGRAL2BIG scm_i_ushort2big -#define UNSIGNED +#define UNSIGNED 1 #define ITYPE unsigned short -#define SIZEOF_ITYPE SIZEOF_SHORT +#define SIZEOF_ITYPE SIZEOF_UNSIGNED_SHORT #include "libguile/num2integral.i.c" #define NUM2INTEGRAL scm_num2int #define INTEGRAL2NUM scm_int2num #define INTEGRAL2BIG scm_i_int2big +#define UNSIGNED 0 #define ITYPE int #define SIZEOF_ITYPE SIZEOF_INT #include "libguile/num2integral.i.c" @@ -4348,14 +5515,15 @@ scm_i_big2dbl (SCM b) #define NUM2INTEGRAL scm_num2uint #define INTEGRAL2NUM scm_uint2num #define INTEGRAL2BIG scm_i_uint2big -#define UNSIGNED +#define UNSIGNED 1 #define ITYPE unsigned int -#define SIZEOF_ITYPE SIZEOF_INT +#define SIZEOF_ITYPE SIZEOF_UNSIGNED_INT #include "libguile/num2integral.i.c" #define NUM2INTEGRAL scm_num2long #define INTEGRAL2NUM scm_long2num #define INTEGRAL2BIG scm_i_long2big +#define UNSIGNED 0 #define ITYPE long #define SIZEOF_ITYPE SIZEOF_LONG #include "libguile/num2integral.i.c" @@ -4363,28 +5531,29 @@ scm_i_big2dbl (SCM b) #define NUM2INTEGRAL scm_num2ulong #define INTEGRAL2NUM scm_ulong2num #define INTEGRAL2BIG scm_i_ulong2big -#define UNSIGNED +#define UNSIGNED 1 #define ITYPE unsigned long -#define SIZEOF_ITYPE SIZEOF_LONG +#define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG #include "libguile/num2integral.i.c" #define NUM2INTEGRAL scm_num2ptrdiff #define INTEGRAL2NUM scm_ptrdiff2num #define INTEGRAL2BIG scm_i_ptrdiff2big -#define ITYPE ptrdiff_t +#define UNSIGNED 0 +#define ITYPE scm_t_ptrdiff #define UNSIGNED_ITYPE size_t -#define SIZEOF_ITYPE SIZEOF_PTRDIFF_T +#define SIZEOF_ITYPE SCM_SIZEOF_SCM_T_PTRDIFF #include "libguile/num2integral.i.c" #define NUM2INTEGRAL scm_num2size #define INTEGRAL2NUM scm_size2num #define INTEGRAL2BIG scm_i_size2big -#define UNSIGNED +#define UNSIGNED 1 #define ITYPE size_t #define SIZEOF_ITYPE SIZEOF_SIZE_T #include "libguile/num2integral.i.c" -#ifdef HAVE_LONG_LONGS +#if SCM_SIZEOF_LONG_LONG != 0 #ifndef ULONG_LONG_MAX #define ULONG_LONG_MAX (~0ULL) @@ -4393,6 +5562,7 @@ scm_i_big2dbl (SCM b) #define NUM2INTEGRAL scm_num2long_long #define INTEGRAL2NUM scm_long_long2num #define INTEGRAL2BIG scm_i_long_long2big +#define UNSIGNED 0 #define ITYPE long long #define SIZEOF_ITYPE SIZEOF_LONG_LONG #include "libguile/num2integral.i.c" @@ -4400,12 +5570,12 @@ scm_i_big2dbl (SCM b) #define NUM2INTEGRAL scm_num2ulong_long #define INTEGRAL2NUM scm_ulong_long2num #define INTEGRAL2BIG scm_i_ulong_long2big -#define UNSIGNED +#define UNSIGNED 1 #define ITYPE unsigned long long -#define SIZEOF_ITYPE SIZEOF_LONG_LONG +#define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG_LONG #include "libguile/num2integral.i.c" -#endif /* HAVE_LONG_LONGS */ +#endif /* SCM_SIZEOF_LONG_LONG != 0 */ #define NUM2FLOAT scm_num2float #define FLOAT2NUM scm_float2num @@ -4424,17 +5594,20 @@ scm_i_big2dbl (SCM b) #endif #ifndef PTRDIFF_MIN #define PTRDIFF_MIN \ - ((ptrdiff_t) ((ptrdiff_t) 1 << (sizeof (ptrdiff_t) * 8 - 1))) + ((scm_t_ptrdiff) ((scm_t_ptrdiff) 1 \ + << ((sizeof (scm_t_ptrdiff) * SCM_CHAR_BIT) - 1))) #endif #ifndef PTRDIFF_MAX #define PTRDIFF_MAX (~ PTRDIFF_MIN) #endif -#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 () @@ -4466,7 +5639,7 @@ check_sanity () CHECK (ptrdiff, PTRDIFF_MAX); CHECK (ptrdiff, PTRDIFF_MIN); -#ifdef HAVE_LONG_LONGS +#if SCM_SIZEOF_LONG_LONG != 0 CHECK (long_long, 0LL); CHECK (ulong_long, 0ULL); CHECK (long_long, -1LL); @@ -4527,8 +5700,7 @@ 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); + 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 @@ -4548,14 +5720,16 @@ scm_init_numbers () { /* 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; + while (fsum != 1.0) + { + if (++scm_dblprec > 20) + fsum = 1.0; + else + { + f /= 10.0; + fsum = f + 1.0; + } } - } scm_dblprec = scm_dblprec - 1; } #endif /* DBL_DIG */ @@ -4563,10 +5737,10 @@ scm_init_numbers () #ifdef GUILE_DEBUG check_sanity (); #endif - -#ifndef SCM_MAGIC_SNARFER + + exactly_one_half = scm_permanent_object (scm_divide (SCM_MAKINUM (1), + SCM_MAKINUM (2))); #include "libguile/numbers.x" -#endif } /*