From a1dda78005b13c4b9dfa97b636f21e62dd3b0f38 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 29 Jan 2011 02:36:02 -0500 Subject: [PATCH] Implement efficient R6RS `div', `mod', et al * libguile/numbers.c (scm_div, scm_mod, scm_div_and_mod, scm_div0, scm_mod0, scm_div0_and_mod0): New extensible procedures `div', `mod', `div-and-mod', `div0', `mod0', `div0-and-mod0'. (scm_i_inexact_div, scm_i_inexact_mod, scm_i_inexact_div_and_mod, scm_i_inexact_div0, scm_i_inexact_mod0, scm_i_inexact_div0_and_mod0, scm_i_slow_exact_div, scm_i_slow_exact_mod, scm_i_slow_exact_div_and_mod, scm_i_slow_exact_div, scm_i_slow_exact_mod, scm_i_slow_exact_div_and_mod, scm_i_bigint_div0, scm_i_bigint_mod0, scm_i_bigint_div0_and_mod0): New internal static procedures, not intended to be used except by scm_div, scm_mod, scm_div_and_mod, scm_div0, scm_mod0, and scm_div0_and_mod0. * libguile/numbers.h: Add function prototypes. * module/rnrs/base.scm: Remove incorrect stub implementations of `div', `mod', `div-and-mod', `div0', `mod0', and `div0-and-mod0'. * module/rnrs/arithmetic/fixnums.scm (fxdiv, fxmod, fxdiv-and-mod, fxdiv0, fxmod0, fxdiv0-and-mod0): Remove redundant checks for division by zero and unnecessary complexity. (fx+/carry): Remove unneeded calls to `inexact->exact'. * module/rnrs/arithmetic/flonums.scm (fldiv, flmod, fldiv-and-mod, fldiv0, flmod0, fldiv0-and-mod0): Remove redundant checks for division by zero and unnecessary complexity. Remove unneeded calls to `inexact->exact' and `exact->inexact' * test-suite/tests/numbers.test: (test-eqv?): New internal predicate for comparing numerical outputs with expected values. Add extensive test code for `div', `mod', `div-and-mod', `div0', `mod0', and `div0-and-mod0'. * test-suite/tests/r6rs-arithmetic-fixnums.test: Fix some broken test cases, and remove `unresolved' test markers for `fxdiv', `fxmod', `fxdiv-and-mod', `fxdiv0', `fxmod0', and `fxdiv0-and-mod0'. * test-suite/tests/r6rs-arithmetic-flonums.test: Remove `unresolved' test markers for `fldiv', `flmod', `fldiv-and-mod', `fldiv0', `flmod0', and `fldiv0-and-mod0'. * doc/ref/api-data.texi (Arithmetic): Document `div', `mod', `div-and-mod', `div0', `mod0', and `div0-and-mod0'. (Operations on Integer Values): Add cross-references to `div', `mod', et al, from `quotient', `remainder', and `modulo'. * doc/ref/r6rs.texi (rnrs base): Remove stub descriptions for `div', `mod', `div-and-mod', `div0', `mod0', and `div0-and-mod0'. Instead, cross reference to their descriptions in the core arithmetic section. * NEWS: Add NEWS entry. --- NEWS | 16 + doc/ref/api-data.texi | 67 ++ doc/ref/r6rs.texi | 19 +- libguile/numbers.c | 1172 ++++++++++++++++++++++++- libguile/numbers.h | 6 + module/rnrs/arithmetic/fixnums.scm | 23 +- module/rnrs/arithmetic/flonums.scm | 31 +- module/rnrs/base.scm | 17 - test-suite/tests/numbers.test | 166 ++++- test-suite/tests/r6rs-arithmetic-fixnums.test | 23 +- test-suite/tests/r6rs-arithmetic-flonums.test | 9 +- 11 files changed, 1457 insertions(+), 92 deletions(-) diff --git a/NEWS b/NEWS index f45795e..085f2b9 100644 --- a/NEWS +++ b/NEWS @@ -12,6 +12,22 @@ Changes in 1.9.15 (since the 1.9.14 prerelease): ** Changes and bugfixes in numerics code +**** New procedures: `div', `mod', `div-and-mod' et al + +Added efficient R6RS division operations to Guile core. These +procedures each accept two real numbers X and Y, where Y must be +non-zero. `div' returns an integer Q and `mod' returns a real R such +that X = R + Q * Y and 0 <= R < abs(Y). `div-and-mod' returns both Q +and R, and is more efficient than calling `div' and `mod' separately. +`div0', `mod0', and `div0-and-mod0' are similar except that +-abs(Y/2) <= R < abs(Y/2). + +**** `div0', `mod0', and `div0-and-mod0' now implemented correctly + +These functions are now implemented correctly (though admittedly +inefficiently). R6RS states that (div0-and-mod0 123 -10) should +return -12 and 3, but previously it returned -12 and -7. + *** `eqv?' and `equal?' now compare numbers equivalently scm_equal_p `equal?' now behaves equivalently to scm_eqv_p `eqv?' for diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 4256e18..41702a9 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -897,6 +897,9 @@ sign as @var{n}. In all cases quotient and remainder satisfy (remainder 13 4) @result{} 1 (remainder -13 4) @result{} -1 @end lisp + +See also @code{div}, @code{mod} and related operations in +@ref{Arithmetic}. @end deffn @c begin (texi-doc-string "guile" "modulo") @@ -911,6 +914,9 @@ sign as @var{d}. (modulo 13 -4) @result{} -3 (modulo -13 -4) @result{} -1 @end lisp + +See also @code{div}, @code{mod} and related operations in +@ref{Arithmetic}. @end deffn @c begin (texi-doc-string "guile" "gcd") @@ -1130,6 +1136,12 @@ Returns the magnitude or angle of @var{z} as a @code{double}. @rnindex ceiling @rnindex truncate @rnindex round +@rnindex div +@rnindex mod +@rnindex div-and-mod +@rnindex div0 +@rnindex mod0 +@rnindex div0-and-mod0 The C arithmetic functions below always takes two arguments, while the Scheme functions can take an arbitrary number. When you need to @@ -1229,6 +1241,61 @@ respectively, but these functions take and return @code{double} values. @end deftypefn +@deffn {Scheme Procedure} div x y +@deffnx {Scheme Procedure} mod x y +@deffnx {Scheme Procedure} div-and-mod x y +@deffnx {C Function} scm_div (x y) +@deffnx {C Function} scm_mod (x y) +@deffnx {C Function} scm_div_and_mod (x y) +These procedures implement number-theoretic division. + +Each accepts two real numbers @var{x} and @var{y}, where @var{y} is +non-zero. @code{div} returns an integer @var{q} and @code{mod} returns +a real @var{r} such that @math{@var{x} = @var{r} + @var{q}*@var{y}} and +@math{0 <= @var{r} < abs(@var{y})}. @code{div-and-mod} returns both +values, and is more efficient than calling @code{div} and @code{mod} +separately. + +@lisp +(div 123 10) @result{} 12 +(mod 123 10) @result{} 3 +(div-and-mod 123 10) @result{} 12 and 3 +(div-and-mod 123 -10) @result{} -12 and 3 +(div-and-mod -123 10) @result{} -13 and 7 +(div-and-mod -123 -10) @result{} 13 and 7 +(div-and-mod -123.2 -63.5) @result{} 2.0 and 3.8 +(div-and-mod 125/7 -10/7) @result{} -12 and 5/7 +@end lisp +@end deffn + +@deffn {Scheme Procedure} div0 x y +@deffnx {Scheme Procedure} mod0 x y +@deffnx {Scheme Procedure} div0-and-mod0 x y +@deffnx {C Function} scm_div0 (x y) +@deffnx {C Function} scm_mod0 (x y) +@deffnx {C Function} scm_div0_and_mod0 (x y) +These procedures are similar to @code{div}, @code{mod}, and +@code{div-and-mod}, except that @code{mod0} returns values that lie +within a half-open interval centered on zero. + +Precisely, @code{div0} returns an integer @var{q} and @code{mod0} +returns a real @var{r} such that @math{@var{x} = @var{r} + +@var{q}*@var{y}} and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}. +@code{div0-and-mod0} returns both values, and is more efficient than +calling @code{div0} and @code{mod0} separately. + +@lisp +(div0 123 10) @result{} 12 +(mod0 123 10) @result{} 3 +(div0-and-mod0 123 10) @result{} 12 and 3 +(div0-and-mod0 123 -10) @result{} -12 and 3 +(div0-and-mod0 -123 10) @result{} -12 and -3 +(div0-and-mod0 -123 -10) @result{} 12 and -3 +(div0-and-mod0 -123.2 -63.5) @result{} 2.0 and 3.8 +(div0-and-mod0 125/7 -10/7) @result{} -13 and -5/7 +@end lisp +@end deffn + @node Scientific @subsubsection Scientific Functions diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi index 5fee65f..6439478 100644 --- a/doc/ref/r6rs.texi +++ b/doc/ref/r6rs.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 2010 +@c Copyright (C) 2010, 2011 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -461,24 +461,13 @@ grouped below by the existing manual sections to which they correspond. @deffnx {Scheme Procedure} floor x @deffnx {Scheme Procedure} ceiling x @deffnx {Scheme Procedure} round x -@xref{Arithmetic}, for documentation. -@end deffn - -@deffn {Scheme Procedure} div x1 x2 +@deffnx {Scheme Procedure} div x1 x2 @deffnx {Scheme Procedure} mod x1 x2 @deffnx {Scheme Procedure} div-and-mod x1 x2 -These procedures implement number-theoretic division. - -@code{div-and-mod} returns two values, the respective results of -@code{(div x1 x2)} and @code{(mod x1 x2)}. -@end deffn - -@deffn {Scheme Procedure} div0 x1 x2 +@deffnx {Scheme Procedure} div0 x1 x2 @deffnx {Scheme Procedure} mod0 x1 x2 @deffnx {Scheme Procedure} div0-and-mod0 x1 x2 -These procedures are similar to @code{div}, @code{mod}, and -@code{div-and-mod}, except that @code{mod0} returns values that lie -within a half-open interval centered on zero. +@xref{Arithmetic}, for documentation. @end deffn @deffn {Scheme Procedure} exact-integer-sqrt k diff --git a/libguile/numbers.c b/libguile/numbers.c index 0fae4cb..5ade135 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -105,6 +105,7 @@ typedef scm_t_signed_bits scm_t_inum; static SCM flo0; +static SCM exactly_one_half; #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0) @@ -1054,6 +1055,1175 @@ scm_modulo (SCM x, SCM y) SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG1, s_modulo); } +static SCM scm_i_inexact_div (double x, double y); +static SCM scm_i_slow_exact_div (SCM x, SCM y); + +SCM_GPROC (s_div, "div", 2, 0, 0, scm_div, g_div); +/* "Return q = @var{x} div @var{y}, where x = r + q*y,\n" + * "q is an integer and 0 <= r < abs(y)." + * "@lisp\n" + * "(div 123 10) @result{} 12\n" + * "(div 123 -10) @result{} -12\n" + * "(div -123 10) @result{} -13\n" + * "(div -123 -10) @result{} 13\n" + * "@end lisp" + */ +SCM +scm_div (SCM x, SCM y) +{ + if (SCM_LIKELY (SCM_I_INUMP (x))) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_div); + else + { + scm_t_inum xx = SCM_I_INUM (x); + scm_t_inum qq = xx / yy; + if (xx < 0 && xx < qq * yy) + { + if (yy > 0) + qq--; + else + qq++; + } + return SCM_I_MAKINUM (qq); + } + } + else if (SCM_BIGP (y)) + { + if (SCM_I_INUM (x) >= 0) + return SCM_INUM0; + else + return SCM_I_MAKINUM (- mpz_sgn (SCM_I_BIG_MPZ (y))); + } + else if (SCM_REALP (y)) + return scm_i_inexact_div (SCM_I_INUM (x), SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_div (x, y); + else + SCM_WTA_DISPATCH_2 (g_div, x, y, SCM_ARG2, s_div); + } + else if (SCM_BIGP (x)) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_div); + else + { + SCM q = scm_i_mkbig (); + if (yy > 0) + mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy); + else + { + mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy); + mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q)); + } + scm_remember_upto_here_1 (x); + return scm_i_normbig (q); + } + } + else if (SCM_BIGP (y)) + { + SCM q = scm_i_mkbig (); + if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0) + mpz_fdiv_q (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (x), + SCM_I_BIG_MPZ (y)); + else + mpz_cdiv_q (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (x), + SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + return scm_i_normbig (q); + } + else if (SCM_REALP (y)) + return scm_i_inexact_div (scm_i_big2dbl (x), SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_div (x, y); + else + SCM_WTA_DISPATCH_2 (g_div, x, y, SCM_ARG2, s_div); + } + else if (SCM_REALP (x)) + { + if (!(SCM_REALP (y) || SCM_I_INUMP (y) || + SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_div, x, y, SCM_ARG2, s_div); + else + return scm_i_inexact_div (SCM_REAL_VALUE (x), scm_to_double (y)); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_REALP (y)) + return scm_i_inexact_div (scm_i_fraction2double (x), + SCM_REAL_VALUE (y)); + else + return scm_i_slow_exact_div (x, y); + } + else + SCM_WTA_DISPATCH_2 (g_div, x, y, SCM_ARG1, s_div); +} + +static SCM +scm_i_inexact_div (double x, double y) +{ + if (SCM_LIKELY (y > 0)) + return scm_from_double (floor(x / y)); + else if (SCM_LIKELY (y < 0)) + return scm_from_double (ceil(x / y)); + else if (y == 0) + scm_num_overflow (s_div); /* or should we return a NaN? */ + else + return scm_nan (); +} + +/* Compute exact div the slow way. + We use this only if both arguments are exact, + and at least one of them is a fraction */ +static SCM +scm_i_slow_exact_div (SCM x, SCM y) +{ + if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x))) + SCM_WTA_DISPATCH_2 (g_div, x, y, SCM_ARG1, s_div); + else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_div, x, y, SCM_ARG2, s_div); + else if (scm_is_true (scm_positive_p (y))) + return scm_floor (scm_divide (x, y)); + else if (scm_is_true (scm_negative_p (y))) + return scm_ceiling (scm_divide (x, y)); + else + scm_num_overflow (s_div); +} + +static SCM scm_i_inexact_mod (double x, double y); +static SCM scm_i_slow_exact_mod (SCM x, SCM y); + +SCM_GPROC (s_mod, "mod", 2, 0, 0, scm_mod, g_mod); +/* "Return r = @var{x} mod @var{y}, where x = r + q*y,\n" + * "q is an integer and 0 <= r < abs(y)." + * "@lisp\n" + * "(mod 123 10) @result{} 3\n" + * "(mod 123 -10) @result{} 3\n" + * "(mod -123 10) @result{} 7\n" + * "(mod -123 -10) @result{} 7\n" + * "@end lisp" + */ +SCM +scm_mod (SCM x, SCM y) +{ + if (SCM_LIKELY (SCM_I_INUMP (x))) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_mod); + else + { + scm_t_inum rr = SCM_I_INUM (x) % yy; + if (rr >= 0) + return SCM_I_MAKINUM (rr); + else if (yy > 0) + return SCM_I_MAKINUM (rr + yy); + else + return SCM_I_MAKINUM (rr - yy); + } + } + else if (SCM_BIGP (y)) + { + scm_t_inum xx = SCM_I_INUM (x); + if ((xx == SCM_MOST_NEGATIVE_FIXNUM) && + (0 == mpz_cmp_ui (SCM_I_BIG_MPZ (y), + - SCM_MOST_NEGATIVE_FIXNUM))) + { + /* Special case: x == fixnum-min && y == abs (fixnum-min) */ + scm_remember_upto_here_1 (y); + return SCM_INUM0; + } + else if (xx >= 0) + return x; + else if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0) + { + SCM r = scm_i_mkbig (); + mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx); + scm_remember_upto_here_1 (y); + return scm_i_normbig (r); + } + else + { + SCM r = scm_i_mkbig (); + mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx); + scm_remember_upto_here_1 (y); + mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r)); + return scm_i_normbig (r); + } + } + else if (SCM_REALP (y)) + return scm_i_inexact_mod (SCM_I_INUM (x), SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_mod (x, y); + else + SCM_WTA_DISPATCH_2 (g_mod, x, y, SCM_ARG2, s_mod); + } + else if (SCM_BIGP (x)) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_mod); + else + { + scm_t_inum rr; + if (yy < 0) + yy = - yy; + rr = mpz_fdiv_ui (SCM_I_BIG_MPZ (x), yy); + scm_remember_upto_here_1 (x); + return SCM_I_MAKINUM (rr); + } + } + else if (SCM_BIGP (y)) + { + SCM r = scm_i_mkbig (); + mpz_mod (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + return scm_i_normbig (r); + } + else if (SCM_REALP (y)) + return scm_i_inexact_mod (scm_i_big2dbl (x), SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_mod (x, y); + else + SCM_WTA_DISPATCH_2 (g_mod, x, y, SCM_ARG2, s_mod); + } + else if (SCM_REALP (x)) + { + if (!(SCM_REALP (y) || SCM_I_INUMP (y) || + SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_mod, x, y, SCM_ARG2, s_mod); + else + return scm_i_inexact_mod (SCM_REAL_VALUE (x), scm_to_double (y)); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_REALP (y)) + return scm_i_inexact_mod (scm_i_fraction2double (x), + SCM_REAL_VALUE (y)); + else + return scm_i_slow_exact_mod (x, y); + } + else + SCM_WTA_DISPATCH_2 (g_mod, x, y, SCM_ARG1, s_mod); +} + +static SCM +scm_i_inexact_mod (double x, double y) +{ + double q; + + /* Although it would be more efficient to use fmod here, we can't + because it would in some cases produce results inconsistent with + scm_i_inexact_div, such that x != r + q * y (not even close). In + particular, when x is very close to a multiple of y, then r might + be either 0.0 or abs(y)-epsilon, but those two cases must + correspond with different choices of q. If r = 0.0 then q must be + x/y, and if r = abs(y) then q must be (x-r)/y. If div chooses one + way and mod chooses the other, it would be bad. This problem + actually happened with (div 130.0 10/7) and (mod 130.0 10/7) on one + platform. */ + if (SCM_LIKELY (y > 0)) + q = floor(x / y); + else if (SCM_LIKELY (y < 0)) + q = ceil(x / y); + else if (y == 0) + scm_num_overflow (s_mod); /* or should we return a NaN? */ + else + return scm_nan (); + return scm_from_double (x - q * y); +} + +/* Compute exact mod the slow way: x-y*(x div y) + We use this only if both arguments are exact, + and at least one of them is a fraction */ +static SCM +scm_i_slow_exact_mod (SCM x, SCM y) +{ + if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x))) + SCM_WTA_DISPATCH_2 (g_mod, x, y, SCM_ARG1, s_mod); + else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_mod, x, y, SCM_ARG2, s_mod); + else if (scm_is_true (scm_positive_p (y))) + return scm_difference + (x, scm_product (y, scm_floor (scm_divide (x, y)))); + else if (scm_is_true (scm_negative_p (y))) + return scm_difference + (x, scm_product (y, scm_ceiling (scm_divide (x, y)))); + else + scm_num_overflow (s_mod); +} + + +static SCM scm_i_inexact_div_and_mod (double x, double y); +static SCM scm_i_slow_exact_div_and_mod (SCM x, SCM y); + +SCM_GPROC (s_div_and_mod, "div-and-mod", 2, 0, 0, + scm_div_and_mod, g_div_and_mod); +/* "Return q and r, where x = r + q*y," + * "q is an integer, and 0 <= r < abs(y)." + * "@lisp\n" + * "(div-and-mod 123 10) @result{} 12 and 3\n" + * "(div-and-mod 123 -10) @result{} -12 and 3\n" + * "(div-and-mod -123 10) @result{} -13 and 7\n" + * "(div-and-mod -123 -10) @result{} 13 and 7\n" + * "@end lisp" + */ +SCM +scm_div_and_mod (SCM x, SCM y) +{ + if (SCM_LIKELY (SCM_I_INUMP (x))) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_div_and_mod); + else + { + scm_t_inum xx = SCM_I_INUM (x); + scm_t_inum qq = xx / yy; + scm_t_inum rr = xx - qq * yy; + if (rr < 0) + { + if (yy > 0) + { rr += yy; qq--; } + else + { rr -= yy; qq++; } + } + return scm_values (scm_list_2 (SCM_I_MAKINUM (qq), + SCM_I_MAKINUM (rr))); + } + } + else if (SCM_BIGP (y)) + { + scm_t_inum xx = SCM_I_INUM (x); + if (xx >= 0) + return scm_values (scm_list_2 (SCM_INUM0, x)); + else if ((xx == SCM_MOST_NEGATIVE_FIXNUM) && + (0 == mpz_cmp_ui (SCM_I_BIG_MPZ (y), + - SCM_MOST_NEGATIVE_FIXNUM))) + { + /* Special case: x == fixnum-min && y == abs (fixnum-min) */ + scm_remember_upto_here_1 (y); + return scm_values + (scm_list_2 (SCM_I_MAKINUM (-1), SCM_INUM0)); + } + else if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0) + { + SCM r = scm_i_mkbig (); + mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx); + scm_remember_upto_here_1 (y); + return scm_values + (scm_list_2 (SCM_I_MAKINUM (-1), scm_i_normbig (r))); + } + else + { + SCM r = scm_i_mkbig (); + mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx); + scm_remember_upto_here_1 (y); + mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r)); + return scm_values (scm_list_2 (SCM_INUM1, scm_i_normbig (r))); + } + } + else if (SCM_REALP (y)) + return scm_i_inexact_div_and_mod (SCM_I_INUM (x), SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_div_and_mod (x, y); + else + SCM_WTA_DISPATCH_2 (g_div_and_mod, x, y, SCM_ARG2, s_div_and_mod); + } + else if (SCM_BIGP (x)) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_div_and_mod); + else + { + SCM q = scm_i_mkbig (); + SCM r = scm_i_mkbig (); + if (yy > 0) + mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), yy); + else + { + mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), -yy); + mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q)); + } + scm_remember_upto_here_1 (x); + return scm_values (scm_list_2 (scm_i_normbig (q), + scm_i_normbig (r))); + } + } + else if (SCM_BIGP (y)) + { + SCM q = scm_i_mkbig (); + SCM r = scm_i_mkbig (); + if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0) + mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + else + mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + return scm_values (scm_list_2 (scm_i_normbig (q), + scm_i_normbig (r))); + } + else if (SCM_REALP (y)) + return scm_i_inexact_div_and_mod (scm_i_big2dbl (x), + SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_div_and_mod (x, y); + else + SCM_WTA_DISPATCH_2 (g_div_and_mod, x, y, SCM_ARG2, s_div_and_mod); + } + else if (SCM_REALP (x)) + { + if (!(SCM_REALP (y) || SCM_I_INUMP (y) || + SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_div_and_mod, x, y, SCM_ARG2, s_div_and_mod); + else + return scm_i_inexact_div_and_mod (SCM_REAL_VALUE (x), + scm_to_double (y)); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_REALP (y)) + return scm_i_inexact_div_and_mod (scm_i_fraction2double (x), + SCM_REAL_VALUE (y)); + else + return scm_i_slow_exact_div_and_mod (x, y); + } + else + SCM_WTA_DISPATCH_2 (g_div_and_mod, x, y, SCM_ARG1, s_div_and_mod); +} + +static SCM +scm_i_inexact_div_and_mod (double x, double y) +{ + double q, r; + + if (SCM_LIKELY (y > 0)) + q = floor(x / y); + else if (SCM_LIKELY (y < 0)) + q = ceil(x / y); + else if (y == 0) + scm_num_overflow (s_div_and_mod); /* or should we return a NaN? */ + else + q = guile_NaN; + r = x - q * y; + return scm_values (scm_list_2 (scm_from_double (q), + scm_from_double (r))); +} + +/* Compute exact div and mod the slow way. + We use this only if both arguments are exact, + and at least one of them is a fraction */ +static SCM +scm_i_slow_exact_div_and_mod (SCM x, SCM y) +{ + SCM q, r; + + if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x))) + SCM_WTA_DISPATCH_2 (g_div_and_mod, x, y, SCM_ARG1, s_div_and_mod); + else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_div_and_mod, x, y, SCM_ARG2, s_div_and_mod); + else if (scm_is_true (scm_positive_p (y))) + q = scm_floor (scm_divide (x, y)); + else if (scm_is_true (scm_negative_p (y))) + q = scm_ceiling (scm_divide (x, y)); + else + scm_num_overflow (s_div_and_mod); + r = scm_difference (x, scm_product (q, y)); + return scm_values (scm_list_2 (q, r)); +} + +static SCM scm_i_inexact_div0 (double x, double y); +static SCM scm_i_bigint_div0 (SCM x, SCM y); +static SCM scm_i_slow_exact_div0 (SCM x, SCM y); + +SCM_GPROC (s_div0, "div0", 2, 0, 0, scm_div0, g_div0); +/* "Return q = @var{x} div0 @var{y}, where x = r + q*y,\n" + * "q is an integer and -abs(y/2) <= r < abs(y/2)." + * "@lisp\n" + * "(div0 123 10) @result{} 12\n" + * "(div0 123 -10) @result{} -12\n" + * "(div0 -123 10) @result{} -12\n" + * "(div0 -123 -10) @result{} 12\n" + * "@end lisp" + */ +SCM +scm_div0 (SCM x, SCM y) +{ + if (SCM_LIKELY (SCM_I_INUMP (x))) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_div0); + else + { + scm_t_inum xx = SCM_I_INUM (x); + scm_t_inum qq = xx / yy; + scm_t_inum rr = xx - qq * yy; + if (SCM_LIKELY (xx > 0)) + { + if (SCM_LIKELY (yy > 0)) + { + if (rr >= (yy + 1) / 2) + qq++; + } + else + { + if (rr >= (1 - yy) / 2) + qq--; + } + } + else + { + if (SCM_LIKELY (yy > 0)) + { + if (rr < -yy / 2) + qq--; + } + else + { + if (rr < yy / 2) + qq++; + } + } + return SCM_I_MAKINUM (qq); + } + } + else if (SCM_BIGP (y)) + { + /* Pass a denormalized bignum version of x (even though it + can fit in a fixnum) to scm_i_bigint_div0 */ + return scm_i_bigint_div0 + (scm_i_long2big (SCM_I_INUM (x)), y); + } + else if (SCM_REALP (y)) + return scm_i_inexact_div0 (SCM_I_INUM (x), SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_div0 (x, y); + else + SCM_WTA_DISPATCH_2 (g_div0, x, y, SCM_ARG2, s_div0); + } + else if (SCM_BIGP (x)) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_div0); + else + { + SCM q = scm_i_mkbig (); + scm_t_inum rr; + /* Arrange for rr to initially be non-positive, + because that simplifies the test to see + if it is within the needed bounds. */ + if (yy > 0) + { + rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (x), yy); + scm_remember_upto_here_1 (x); + if (rr < -yy / 2) + mpz_sub_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (q), 1); + } + else + { + rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (x), -yy); + scm_remember_upto_here_1 (x); + mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q)); + if (rr < yy / 2) + mpz_add_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (q), 1); + } + return scm_i_normbig (q); + } + } + else if (SCM_BIGP (y)) + return scm_i_bigint_div0 (x, y); + else if (SCM_REALP (y)) + return scm_i_inexact_div0 (scm_i_big2dbl (x), SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_div0 (x, y); + else + SCM_WTA_DISPATCH_2 (g_div0, x, y, SCM_ARG2, s_div0); + } + else if (SCM_REALP (x)) + { + if (!(SCM_REALP (y) || SCM_I_INUMP (y) || + SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_div0, x, y, SCM_ARG2, s_div0); + else + return scm_i_inexact_div0 (SCM_REAL_VALUE (x), scm_to_double (y)); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_REALP (y)) + return scm_i_inexact_div0 (scm_i_fraction2double (x), + SCM_REAL_VALUE (y)); + else + return scm_i_slow_exact_div0 (x, y); + } + else + SCM_WTA_DISPATCH_2 (g_div0, x, y, SCM_ARG1, s_div0); +} + +static SCM +scm_i_inexact_div0 (double x, double y) +{ + if (SCM_LIKELY (y > 0)) + return scm_from_double (floor(x / y + 0.5)); + else if (SCM_LIKELY (y < 0)) + return scm_from_double (ceil(x / y - 0.5)); + else if (y == 0) + scm_num_overflow (s_div0); /* or should we return a NaN? */ + else + return scm_nan (); +} + +/* Assumes that both x and y are bigints, though + x might be able to fit into a fixnum. */ +static SCM +scm_i_bigint_div0 (SCM x, SCM y) +{ + SCM q, r, min_r; + + /* Note that x might be small enough to fit into a + fixnum, so we must not let it escape into the wild */ + q = scm_i_mkbig (); + r = scm_i_mkbig (); + + /* min_r will eventually become -abs(y)/2 */ + min_r = scm_i_mkbig (); + mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r), + SCM_I_BIG_MPZ (y), 1); + + /* Arrange for rr to initially be non-positive, + because that simplifies the test to see + if it is within the needed bounds. */ + if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0) + { + mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + mpz_neg (SCM_I_BIG_MPZ (min_r), SCM_I_BIG_MPZ (min_r)); + if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0) + mpz_sub_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (q), 1); + } + else + { + mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0) + mpz_add_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (q), 1); + } + scm_remember_upto_here_2 (r, min_r); + return scm_i_normbig (q); +} + +/* Compute exact div0 the slow way. + We use this only if both arguments are exact, + and at least one of them is a fraction */ +static SCM +scm_i_slow_exact_div0 (SCM x, SCM y) +{ + if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x))) + SCM_WTA_DISPATCH_2 (g_div0, x, y, SCM_ARG1, s_div0); + else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_div0, x, y, SCM_ARG2, s_div0); + else if (scm_is_true (scm_positive_p (y))) + return scm_floor (scm_sum (scm_divide (x, y), exactly_one_half)); + else if (scm_is_true (scm_negative_p (y))) + return scm_ceiling (scm_difference (scm_divide (x, y), exactly_one_half)); + else + scm_num_overflow (s_div0); +} + +static SCM scm_i_inexact_mod0 (double x, double y); +static SCM scm_i_bigint_mod0 (SCM x, SCM y); +static SCM scm_i_slow_exact_mod0 (SCM x, SCM y); + +SCM_GPROC (s_mod0, "mod0", 2, 0, 0, scm_mod0, g_mod0); +/* "Return r = @var{x} mod0 @var{y}, where x = r + q*y,\n" + * "q is an integer and -abs(y/2) <= r < abs(y/2)." + * "@lisp\n" + * "(mod0 123 10) @result{} 3\n" + * "(mod0 123 -10) @result{} 3\n" + * "(mod0 -123 10) @result{} -3\n" + * "(mod0 -123 -10) @result{} -3\n" + * "@end lisp" + */ +SCM +scm_mod0 (SCM x, SCM y) +{ + if (SCM_LIKELY (SCM_I_INUMP (x))) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_mod0); + else + { + scm_t_inum xx = SCM_I_INUM (x); + scm_t_inum rr = xx % yy; + if (SCM_LIKELY (xx > 0)) + { + if (SCM_LIKELY (yy > 0)) + { + if (rr >= (yy + 1) / 2) + rr -= yy; + } + else + { + if (rr >= (1 - yy) / 2) + rr += yy; + } + } + else + { + if (SCM_LIKELY (yy > 0)) + { + if (rr < -yy / 2) + rr += yy; + } + else + { + if (rr < yy / 2) + rr -= yy; + } + } + return SCM_I_MAKINUM (rr); + } + } + else if (SCM_BIGP (y)) + { + /* Pass a denormalized bignum version of x (even though it + can fit in a fixnum) to scm_i_bigint_mod0 */ + return scm_i_bigint_mod0 + (scm_i_long2big (SCM_I_INUM (x)), y); + } + else if (SCM_REALP (y)) + return scm_i_inexact_mod0 (SCM_I_INUM (x), SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_mod0 (x, y); + else + SCM_WTA_DISPATCH_2 (g_mod0, x, y, SCM_ARG2, s_mod0); + } + else if (SCM_BIGP (x)) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_mod0); + else + { + scm_t_inum rr; + /* Arrange for rr to initially be non-positive, + because that simplifies the test to see + if it is within the needed bounds. */ + if (yy > 0) + { + rr = - mpz_cdiv_ui (SCM_I_BIG_MPZ (x), yy); + scm_remember_upto_here_1 (x); + if (rr < -yy / 2) + rr += yy; + } + else + { + rr = - mpz_cdiv_ui (SCM_I_BIG_MPZ (x), -yy); + scm_remember_upto_here_1 (x); + if (rr < yy / 2) + rr -= yy; + } + return SCM_I_MAKINUM (rr); + } + } + else if (SCM_BIGP (y)) + return scm_i_bigint_mod0 (x, y); + else if (SCM_REALP (y)) + return scm_i_inexact_mod0 (scm_i_big2dbl (x), SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_mod0 (x, y); + else + SCM_WTA_DISPATCH_2 (g_mod0, x, y, SCM_ARG2, s_mod0); + } + else if (SCM_REALP (x)) + { + if (!(SCM_REALP (y) || SCM_I_INUMP (y) || + SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_mod0, x, y, SCM_ARG2, s_mod0); + else + return scm_i_inexact_mod0 (SCM_REAL_VALUE (x), scm_to_double (y)); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_REALP (y)) + return scm_i_inexact_mod0 (scm_i_fraction2double (x), + SCM_REAL_VALUE (y)); + else + return scm_i_slow_exact_mod0 (x, y); + } + else + SCM_WTA_DISPATCH_2 (g_mod0, x, y, SCM_ARG1, s_mod0); +} + +static SCM +scm_i_inexact_mod0 (double x, double y) +{ + double q; + + /* Although it would be more efficient to use fmod here, we can't + because it would in some cases produce results inconsistent with + scm_i_inexact_div0, such that x != r + q * y (not even close). In + particular, when x-y/2 is very close to a multiple of y, then r + might be either -abs(y/2) or abs(y/2)-epsilon, but those two cases + must correspond with different choices of q. If div0 chooses one + way and mod0 chooses the other, it would be bad. */ + if (SCM_LIKELY (y > 0)) + q = floor(x / y + 0.5); + else if (SCM_LIKELY (y < 0)) + q = ceil(x / y - 0.5); + else if (y == 0) + scm_num_overflow (s_mod0); /* or should we return a NaN? */ + else + return scm_nan (); + return scm_from_double (x - q * y); +} + +/* Assumes that both x and y are bigints, though + x might be able to fit into a fixnum. */ +static SCM +scm_i_bigint_mod0 (SCM x, SCM y) +{ + SCM r, min_r; + + /* Note that x might be small enough to fit into a + fixnum, so we must not let it escape into the wild */ + r = scm_i_mkbig (); + + /* min_r will eventually become -abs(y)/2 */ + min_r = scm_i_mkbig (); + mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r), + SCM_I_BIG_MPZ (y), 1); + + /* Arrange for rr to initially be non-positive, + because that simplifies the test to see + if it is within the needed bounds. */ + if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0) + { + mpz_cdiv_r (SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + mpz_neg (SCM_I_BIG_MPZ (min_r), SCM_I_BIG_MPZ (min_r)); + if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0) + mpz_add (SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (y)); + } + else + { + mpz_fdiv_r (SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0) + mpz_sub (SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (y)); + } + scm_remember_upto_here_2 (x, y); + return scm_i_normbig (r); +} + +/* Compute exact mod0 the slow way: x-y*(x div0 y) + We use this only if both arguments are exact, + and at least one of them is a fraction */ +static SCM +scm_i_slow_exact_mod0 (SCM x, SCM y) +{ + if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x))) + SCM_WTA_DISPATCH_2 (g_mod0, x, y, SCM_ARG1, s_mod0); + else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_mod0, x, y, SCM_ARG2, s_mod0); + else if (scm_is_true (scm_positive_p (y))) + return scm_difference + (x, scm_product (y, scm_floor (scm_sum (scm_divide (x, y), + exactly_one_half)))); + else if (scm_is_true (scm_negative_p (y))) + return scm_difference + (x, scm_product (y, scm_ceiling (scm_difference (scm_divide (x, y), + exactly_one_half)))); + else + scm_num_overflow (s_mod0); +} + + +static SCM scm_i_inexact_div0_and_mod0 (double x, double y); +static SCM scm_i_bigint_div0_and_mod0 (SCM x, SCM y); +static SCM scm_i_slow_exact_div0_and_mod0 (SCM x, SCM y); + +SCM_GPROC (s_div0_and_mod0, "div0-and-mod0", 2, 0, 0, + scm_div0_and_mod0, g_div0_and_mod0); +/* "Return q and r, where x = r + q*y," + * "q is an integer and -abs(y/2) <= r < abs(y/2)." + * "@lisp\n" + * "(div0-and-mod0 123 10) @result{} 12 and 3\n" + * "(div0-and-mod0 123 -10) @result{} -12 and 3\n" + * "(div0-and-mod0 -123 10) @result{} -12 and -3\n" + * "(div0-and-mod0 -123 -10) @result{} 12 and -3\n" + * "@end lisp" + */ +SCM +scm_div0_and_mod0 (SCM x, SCM y) +{ + if (SCM_LIKELY (SCM_I_INUMP (x))) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_div0_and_mod0); + else + { + scm_t_inum xx = SCM_I_INUM (x); + scm_t_inum qq = xx / yy; + scm_t_inum rr = xx - qq * yy; + if (SCM_LIKELY (xx > 0)) + { + if (SCM_LIKELY (yy > 0)) + { + if (rr >= (yy + 1) / 2) + { qq++; rr -= yy; } + } + else + { + if (rr >= (1 - yy) / 2) + { qq--; rr += yy; } + } + } + else + { + if (SCM_LIKELY (yy > 0)) + { + if (rr < -yy / 2) + { qq--; rr += yy; } + } + else + { + if (rr < yy / 2) + { qq++; rr -= yy; } + } + } + return scm_values (scm_list_2 (SCM_I_MAKINUM (qq), + SCM_I_MAKINUM (rr))); + } + } + else if (SCM_BIGP (y)) + { + /* Pass a denormalized bignum version of x (even though it + can fit in a fixnum) to scm_i_bigint_div0_and_mod0 */ + return scm_i_bigint_div0_and_mod0 + (scm_i_long2big (SCM_I_INUM (x)), y); + } + else if (SCM_REALP (y)) + return scm_i_inexact_div0_and_mod0 (SCM_I_INUM (x), + SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_div0_and_mod0 (x, y); + else + SCM_WTA_DISPATCH_2 (g_div0_and_mod0, x, y, SCM_ARG2, s_div0_and_mod0); + } + else if (SCM_BIGP (x)) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_div0_and_mod0); + else + { + SCM q = scm_i_mkbig (); + scm_t_inum rr; + /* Arrange for rr to initially be non-positive, + because that simplifies the test to see + if it is within the needed bounds. */ + if (yy > 0) + { + rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (x), yy); + scm_remember_upto_here_1 (x); + if (rr < -yy / 2) + { + mpz_sub_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (q), 1); + rr += yy; + } + } + else + { + rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (x), -yy); + scm_remember_upto_here_1 (x); + mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q)); + if (rr < yy / 2) + { + mpz_add_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (q), 1); + rr -= yy; + } + } + return scm_values (scm_list_2 (scm_i_normbig (q), + SCM_I_MAKINUM (rr))); + } + } + else if (SCM_BIGP (y)) + return scm_i_bigint_div0_and_mod0 (x, y); + else if (SCM_REALP (y)) + return scm_i_inexact_div0_and_mod0 (scm_i_big2dbl (x), + SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_div0_and_mod0 (x, y); + else + SCM_WTA_DISPATCH_2 (g_div0_and_mod0, x, y, SCM_ARG2, s_div0_and_mod0); + } + else if (SCM_REALP (x)) + { + if (!(SCM_REALP (y) || SCM_I_INUMP (y) || + SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_div0_and_mod0, x, y, SCM_ARG2, s_div0_and_mod0); + else + return scm_i_inexact_div0_and_mod0 (SCM_REAL_VALUE (x), + scm_to_double (y)); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_REALP (y)) + return scm_i_inexact_div0_and_mod0 (scm_i_fraction2double (x), + SCM_REAL_VALUE (y)); + else + return scm_i_slow_exact_div0_and_mod0 (x, y); + } + else + SCM_WTA_DISPATCH_2 (g_div0_and_mod0, x, y, SCM_ARG1, s_div0_and_mod0); +} + +static SCM +scm_i_inexact_div0_and_mod0 (double x, double y) +{ + double q, r; + + if (SCM_LIKELY (y > 0)) + q = floor(x / y + 0.5); + else if (SCM_LIKELY (y < 0)) + q = ceil(x / y - 0.5); + else if (y == 0) + scm_num_overflow (s_div0_and_mod0); /* or should we return a NaN? */ + else + q = guile_NaN; + r = x - q * y; + return scm_values (scm_list_2 (scm_from_double (q), + scm_from_double (r))); +} + +/* Assumes that both x and y are bigints, though + x might be able to fit into a fixnum. */ +static SCM +scm_i_bigint_div0_and_mod0 (SCM x, SCM y) +{ + SCM q, r, min_r; + + /* Note that x might be small enough to fit into a + fixnum, so we must not let it escape into the wild */ + q = scm_i_mkbig (); + r = scm_i_mkbig (); + + /* min_r will eventually become -abs(y/2) */ + min_r = scm_i_mkbig (); + mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r), + SCM_I_BIG_MPZ (y), 1); + + /* Arrange for rr to initially be non-positive, + because that simplifies the test to see + if it is within the needed bounds. */ + if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0) + { + mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + mpz_neg (SCM_I_BIG_MPZ (min_r), SCM_I_BIG_MPZ (min_r)); + if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0) + { + mpz_sub_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (q), 1); + mpz_add (SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (y)); + } + } + else + { + mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0) + { + mpz_add_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (q), 1); + mpz_sub (SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (y)); + } + } + scm_remember_upto_here_2 (x, y); + return scm_values (scm_list_2 (scm_i_normbig (q), + scm_i_normbig (r))); +} + +/* Compute exact div0 and mod0 the slow way. + We use this only if both arguments are exact, + and at least one of them is a fraction */ +static SCM +scm_i_slow_exact_div0_and_mod0 (SCM x, SCM y) +{ + SCM q, r; + + if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x))) + SCM_WTA_DISPATCH_2 (g_div0_and_mod0, x, y, SCM_ARG1, s_div0_and_mod0); + else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_div0_and_mod0, x, y, SCM_ARG2, s_div0_and_mod0); + else if (scm_is_true (scm_positive_p (y))) + q = scm_floor (scm_sum (scm_divide (x, y), exactly_one_half)); + else if (scm_is_true (scm_negative_p (y))) + q = scm_ceiling (scm_difference (scm_divide (x, y), exactly_one_half)); + else + scm_num_overflow (s_div0_and_mod0); + r = scm_difference (x, scm_product (q, y)); + return scm_values (scm_list_2 (q, r)); +} + + SCM_PRIMITIVE_GENERIC (scm_i_gcd, "gcd", 0, 2, 1, (SCM x, SCM y, SCM rest), "Return the greatest common divisor of all parameter values.\n" @@ -5356,8 +6526,6 @@ SCM_DEFINE (scm_truncate_number, "truncate", 1, 0, 0, } #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. " diff --git a/libguile/numbers.h b/libguile/numbers.h index 740dc80..4cc6095 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -177,6 +177,12 @@ SCM_API SCM scm_abs (SCM x); SCM_API SCM scm_quotient (SCM x, SCM y); SCM_API SCM scm_remainder (SCM x, SCM y); SCM_API SCM scm_modulo (SCM x, SCM y); +SCM_API SCM scm_div (SCM x, SCM y); +SCM_API SCM scm_mod (SCM x, SCM y); +SCM_API SCM scm_div_and_mod (SCM x, SCM y); +SCM_API SCM scm_div0 (SCM x, SCM y); +SCM_API SCM scm_mod0 (SCM x, SCM y); +SCM_API SCM scm_div0_and_mod0 (SCM x, SCM y); SCM_API SCM scm_gcd (SCM x, SCM y); SCM_API SCM scm_lcm (SCM n1, SCM n2); SCM_API SCM scm_logand (SCM n1, SCM n2); diff --git a/module/rnrs/arithmetic/fixnums.scm b/module/rnrs/arithmetic/fixnums.scm index c1f3571..befbe9d 100644 --- a/module/rnrs/arithmetic/fixnums.scm +++ b/module/rnrs/arithmetic/fixnums.scm @@ -1,6 +1,6 @@ ;;; fixnums.scm --- The R6RS fixnums arithmetic library -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -175,40 +175,33 @@ (define (fxdiv fx1 fx2) (assert-fixnum fx1 fx2) - (if (zero? fx2) (raise (make-assertion-violation))) - (let ((r (div fx1 fx2))) r)) + (div fx1 fx2)) (define (fxmod fx1 fx2) (assert-fixnum fx1 fx2) - (if (zero? fx2) (raise (make-assertion-violation))) - (let ((r (mod fx1 fx2))) r)) + (mod fx1 fx2)) (define (fxdiv-and-mod fx1 fx2) (assert-fixnum fx1 fx2) - (if (zero? fx2) (raise (make-assertion-violation))) (div-and-mod fx1 fx2)) (define (fxdiv0 fx1 fx2) (assert-fixnum fx1 fx2) - (if (zero? fx2) (raise (make-assertion-violation))) - (let ((r (div0 fx1 fx2))) r)) + (div0 fx1 fx2)) (define (fxmod0 fx1 fx2) (assert-fixnum fx1 fx2) - (if (zero? fx2) (raise (make-assertion-violation))) - (let ((r (mod0 fx1 fx2))) r)) + (mod0 fx1 fx2)) (define (fxdiv0-and-mod0 fx1 fx2) (assert-fixnum fx1 fx2) - (if (zero? fx2) (raise (make-assertion-violation))) - (call-with-values (lambda () (div0-and-mod0 fx1 fx2)) - (lambda (q r) (values q r)))) + (div0-and-mod0 fx1 fx2)) (define (fx+/carry fx1 fx2 fx3) (assert-fixnum fx1 fx2 fx3) (let* ((s (+ fx1 fx2 fx3)) - (s0 (mod0 s (inexact->exact (expt 2 (fixnum-width))))) - (s1 (div0 s (inexact->exact (expt 2 (fixnum-width)))))) + (s0 (mod0 s (expt 2 (fixnum-width)))) + (s1 (div0 s (expt 2 (fixnum-width))))) (values s0 s1))) (define (fx-/carry fx1 fx2 fx3) diff --git a/module/rnrs/arithmetic/flonums.scm b/module/rnrs/arithmetic/flonums.scm index 4fadbd0..b65c294 100644 --- a/module/rnrs/arithmetic/flonums.scm +++ b/module/rnrs/arithmetic/flonums.scm @@ -1,6 +1,6 @@ ;;; flonums.scm --- The R6RS flonums arithmetic library -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -127,40 +127,27 @@ (define (fldiv-and-mod fl1 fl2) (assert-iflonum fl1 fl2) - (if (zero? fl2) (raise (make-assertion-violation))) - (let ((fx1 (inexact->exact fl1)) - (fx2 (inexact->exact fl2))) - (call-with-values (lambda () (div-and-mod fx1 fx2)) - (lambda (div mod) (values (exact->inexact div) - (exact->inexact mod)))))) + (div-and-mod fl1 fl2)) (define (fldiv fl1 fl2) (assert-iflonum fl1 fl2) - (if (zero? fl2) (raise (make-assertion-violation))) - (let ((fx1 (inexact->exact fl1)) - (fx2 (inexact->exact fl2))) - (exact->inexact (quotient fx1 fx2)))) + (div fl1 fl2)) (define (flmod fl1 fl2) (assert-iflonum fl1 fl2) - (if (zero? fl2) (raise (make-assertion-violation))) - (let ((fx1 (inexact->exact fl1)) - (fx2 (inexact->exact fl2))) - (exact->inexact (modulo fx1 fx2)))) + (mod fl1 fl2)) (define (fldiv0-and-mod0 fl1 fl2) (assert-iflonum fl1 fl2) - (if (zero? fl2) (raise (make-assertion-violation))) - (let* ((fx1 (inexact->exact fl1)) - (fx2 (inexact->exact fl2))) - (call-with-values (lambda () (div0-and-mod0 fx1 fx2)) - (lambda (q r) (values (real->flonum q) (real->flonum r)))))) + (div0-and-mod0 fl1 fl2)) (define (fldiv0 fl1 fl2) - (call-with-values (lambda () (fldiv0-and-mod0 fl1 fl2)) (lambda (q r) q))) + (assert-iflonum fl1 fl2) + (div0 fl1 fl2)) (define (flmod0 fl1 fl2) - (call-with-values (lambda () (fldiv0-and-mod0 fl1 fl2)) (lambda (q r) r))) + (assert-iflonum fl1 fl2) + (mod0 fl1 fl2)) (define (flnumerator fl) (assert-flonum fl) diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm index 04a7e23..37c574a 100644 --- a/module/rnrs/base.scm +++ b/module/rnrs/base.scm @@ -74,8 +74,6 @@ syntax-rules identifier-syntax) (import (rename (except (guile) error raise) - (quotient div) - (modulo mod) (inf? infinite?) (exact->inexact inexact) (inexact->exact exact)) @@ -119,21 +117,6 @@ (define (vector-map proc . vecs) (list->vector (apply map (cons proc (map vector->list vecs))))) - (define (div-and-mod x y) (let ((q (div x y)) (r (mod x y))) (values q r))) - - (define (div0 x y) - (call-with-values (lambda () (div0-and-mod0 x y)) (lambda (q r) q))) - - (define (mod0 x y) - (call-with-values (lambda () (div0-and-mod0 x y)) (lambda (q r) r))) - - (define (div0-and-mod0 x y) - (call-with-values (lambda () (div-and-mod x y)) - (lambda (q r) - (cond ((< r (abs (/ y 2))) (values q r)) - ((negative? y) (values (- q 1) (+ r y))) - (else (values (+ q 1) (+ r y))))))) - (define raise (@ (rnrs exceptions) raise)) (define condition diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 36e3128..c89b98a 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -17,7 +17,8 @@ (define-module (test-suite test-numbers) #:use-module (test-suite lib) - #:use-module (ice-9 documentation)) + #:use-module (ice-9 documentation) + #:use-module (srfi srfi-11)) ; let-values ;;; ;;; miscellaneous @@ -92,6 +93,35 @@ (negative? obj) (inf? obj))) +;; +;; Tolerance used by test-eqv? for inexact numbers. +;; +(define test-epsilon 1e-10) + +;; +;; Like eqv?, except that inexact finite numbers need only be within +;; test-epsilon (1e-10) to be considered equal. An exception is made +;; for zeroes, however. If X is zero, then it is tested using eqv? +;; without any allowance for imprecision. In particular, 0.0 is +;; considered distinct from -0.0. For non-real complex numbers, +;; each component is tested according to these rules. The intent +;; is that the known-correct value will be the first parameter. +;; +(define (test-eqv? x y) + (cond ((real? x) + (and (real? y) (test-real-eqv? x y))) + ((complex? x) + (and (not (real? y)) + (test-real-eqv? (real-part x) (real-part y)) + (test-real-eqv? (imag-part x) (imag-part y)))) + (else (eqv? x y)))) + +;; Auxiliary predicate used by test-eqv? +(define (test-real-eqv? x y) + (cond ((or (exact? x) (zero? x) (nan? x) (inf? x)) + (eqv? x y)) + (else (and (inexact? y) (> test-epsilon (abs (- x y))))))) + (define const-e 2.7182818284590452354) (define const-e^2 7.3890560989306502274) (define const-1/e 0.3678794411714423215) @@ -3480,3 +3510,137 @@ (pass-if "-100i swings back to 45deg down" (eqv-loosely? +7.071-7.071i (sqrt -100.0i)))) +;;; +;;; div +;;; mod +;;; div-and-mod +;;; div0 +;;; mod0 +;;; div0-and-mod0 +;;; + +(with-test-prefix "Number-theoretic division" + + ;; Tests that (lo <= x < hi), + ;; but allowing for imprecision + ;; if x is inexact. + (define (test-within-range? lo hi x) + (if (exact? x) + (and (<= lo x) (< x hi)) + (let ((lo (- lo test-epsilon)) + (hi (+ hi test-epsilon))) + (<= lo x hi)))) + + (define (safe-div x y) + (cond ((not (and (real? x) (real? y))) (throw 'wrong-type-arg)) + ((zero? y) (throw 'divide-by-zero)) + ((nan? y) (nan)) + ((positive? y) (floor (/ x y))) + ((negative? y) (ceiling (/ x y))) + (else (throw 'unknown-problem)))) + + (define (safe-mod x y) + (- x (* y (safe-div x y)))) + + (define (safe-div-and-mod x y) + (let ((q (safe-div x y)) + (r (safe-mod x y))) + (if (not (and (eq? (exact? q) (exact? r)) + (eq? (exact? q) (and (exact? x) (exact? y))) + (test-real-eqv? r (- x (* q y))) + (or (and (integer? q) + (test-within-range? 0 (abs y) r)) + (not (finite? x)) + (not (finite? y))))) + (throw 'safe-div-and-mod-is-broken (list x y q r)) + (values q r)))) + + (define (safe-div0 x y) + (cond ((not (and (real? x) (real? y))) (throw 'wrong-type-arg)) + ((zero? y) (throw 'divide-by-zero)) + ((nan? y) (nan)) + ((positive? y) (floor (+ 1/2 (/ x y)))) + ((negative? y) (ceiling (+ -1/2 (/ x y)))) + (else (throw 'unknown-problem)))) + + (define (safe-mod0 x y) + (- x (* y (safe-div0 x y)))) + + (define (safe-div0-and-mod0 x y) + (let ((q (safe-div0 x y)) + (r (safe-mod0 x y))) + (if (not (and (eq? (exact? q) (exact? r)) + (eq? (exact? q) (and (exact? x) (exact? y))) + (test-real-eqv? r (- x (* q y))) + (or (and (integer? q) + (test-within-range? (* -1/2 (abs y)) + (* +1/2 (abs y)) + r)) + (not (finite? x)) + (not (finite? y))))) + (throw 'safe-div0-and-mod0-is-broken (list x y q r)) + (values q r)))) + + (define test-numerators + (list 123 125 127 130 3 5 10 123.2 125.0 + -123 -125 -127 -130 -3 -5 -10 -123.2 -125.0 + 127.2 130.0 123/7 125/7 127/7 130/7 + -127.2 -130.0 -123/7 -125/7 -127/7 -130/7 + 0 +0.0 -0.0 +inf.0 -inf.0 +nan.0 + most-negative-fixnum (1+ most-positive-fixnum) (1- most-negative-fixnum) + (* 123 (+ 1 most-positive-fixnum)) (* 125 (+ 1 most-positive-fixnum)) (* 127 (+ 1 most-positive-fixnum)) + (* 130 (+ 1 most-positive-fixnum)) (* 3 (+ 1 most-positive-fixnum)) (* 5 (+ 1 most-positive-fixnum)) + (* 10 (+ 1 most-positive-fixnum)) + (* -123 (+ 1 most-positive-fixnum)) (* -125 (+ 1 most-positive-fixnum)) (* -127 (+ 1 most-positive-fixnum)) + (* -130 (+ 1 most-positive-fixnum)) (* -3 (+ 1 most-positive-fixnum)) (* -5 (+ 1 most-positive-fixnum)) + (* -10 (+ 1 most-positive-fixnum)) + (* 123 (+ 2 most-positive-fixnum)) (* 125 (+ 2 most-positive-fixnum)) (* 127 (+ 2 most-positive-fixnum)) + (* 130 (+ 2 most-positive-fixnum)) (* 3 (+ 2 most-positive-fixnum)) (* 5 (+ 2 most-positive-fixnum)) + (* 10 (+ 2 most-positive-fixnum)) + (* -123 (+ 2 most-positive-fixnum)) (* -125 (+ 2 most-positive-fixnum)) (* -127 (+ 2 most-positive-fixnum)) + (* -130 (+ 2 most-positive-fixnum)) (* -3 (+ 2 most-positive-fixnum)) (* -5 (+ 2 most-positive-fixnum)) + (* -10 (+ 2 most-positive-fixnum)))) + + (define test-denominators + (list 10 5 10/7 127/2 10.0 63.5 + -10 -5 -10/7 -127/2 -10.0 -63.5 + +inf.0 -inf.0 +nan.0 most-negative-fixnum + (+ 1 most-positive-fixnum) (+ -1 most-negative-fixnum) + (+ 2 most-positive-fixnum) (+ -2 most-negative-fixnum))) + + (define (do-tests-1 op-name real-op safe-op) + (for-each (lambda (d) + (for-each (lambda (n) + (run-test (list op-name n d) #t + (lambda () + (test-eqv? (real-op n d) + (safe-op n d))))) + test-numerators)) + test-denominators)) + + (define (do-tests-2 op-name real-op safe-op) + (for-each (lambda (d) + (for-each (lambda (n) + (run-test (list op-name n d) #t + (lambda () + (let-values + (((q r) (safe-op n d)) + ((q1 r1) (real-op n d))) + (and (test-eqv? q q1) + (test-eqv? r r1)))))) + test-numerators)) + test-denominators)) + + (with-test-prefix "div" (do-tests-1 'div div safe-div)) + (with-test-prefix "mod" (do-tests-1 'mod mod safe-mod)) + (with-test-prefix "div-and-mod" + (do-tests-2 'div-and-mod + div-and-mod + safe-div-and-mod)) + + (with-test-prefix "div0" (do-tests-1 'div0 div0 safe-div0)) + (with-test-prefix "mod0" (do-tests-1 'mod0 mod0 safe-mod0)) + (with-test-prefix "div0-and-mod0" + (do-tests-2 'div0-and-mod0 + div0-and-mod0 + safe-div0-and-mod0))) diff --git a/test-suite/tests/r6rs-arithmetic-fixnums.test b/test-suite/tests/r6rs-arithmetic-fixnums.test index fed72eb..d39d544 100644 --- a/test-suite/tests/r6rs-arithmetic-fixnums.test +++ b/test-suite/tests/r6rs-arithmetic-fixnums.test @@ -1,6 +1,6 @@ ;;; arithmetic-fixnums.test --- Test suite for R6RS (rnrs arithmetic bitwise) -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -121,32 +121,25 @@ (pass-if "simple" (call-with-values (lambda () (fxdiv-and-mod 123 10)) (lambda (d m) - (or (and (fx=? d 12) (fx=? m 3)) - (throw 'unresolved)))))) + (and (fx=? d 12) (fx=? m 3)))))) -(with-test-prefix "fxdiv" - (pass-if "simple" (or (fx=? (fxdiv -123 10) -13) (throw 'unresolved)))) - -(with-test-prefix "fxmod" - (pass-if "simple" (or (fx=? (fxmod -123 10) 7) (throw 'unresolved)))) +(with-test-prefix "fxdiv" (pass-if "simple" (fx=? (fxdiv -123 10) -13))) +(with-test-prefix "fxmod" (pass-if "simple" (fx=? (fxmod -123 10) 7))) (with-test-prefix "fxdiv0-and-mod0" (pass-if "simple" (call-with-values (lambda () (fxdiv0-and-mod0 -123 10)) (lambda (d m) - (or (and (fx=? d 12) (fx=? m -3)) - (throw 'unresolved)))))) - -(with-test-prefix "fxdiv0" - (pass-if "simple" (or (fx=? (fxdiv0 -123 10) 12) (throw 'unresolved)))) + (and (fx=? d -12) (fx=? m -3)))))) -(with-test-prefix "fxmod0" - (pass-if "simple" (or (fx=? (fxmod0 -123 10) -3) (throw 'unresolved)))) +(with-test-prefix "fxdiv0" (pass-if "simple" (fx=? (fxdiv0 -123 10) -12))) +(with-test-prefix "fxmod0" (pass-if "simple" (fx=? (fxmod0 -123 10) -3))) ;; Without working div and mod implementations and without any example results ;; from the spec, I have no idea what the results of these functions should ;; be. -juliang +;; UPDATE: div and mod implementations are now working properly -mhw (with-test-prefix "fx+/carry" (pass-if "simple" (throw 'unresolved))) diff --git a/test-suite/tests/r6rs-arithmetic-flonums.test b/test-suite/tests/r6rs-arithmetic-flonums.test index 873447b..af9dbbf 100644 --- a/test-suite/tests/r6rs-arithmetic-flonums.test +++ b/test-suite/tests/r6rs-arithmetic-flonums.test @@ -1,6 +1,6 @@ ;;; arithmetic-flonums.test --- Test suite for R6RS (rnrs arithmetic flonums) -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -195,14 +195,13 @@ (pass-if "simple" (call-with-values (lambda () (fldiv0-and-mod0 -123.0 10.0)) (lambda (div mod) - (or (and (fl=? div -12.0) (fl=? mod -3.0)) - (throw 'unresolved)))))) + (and (fl=? div -12.0) (fl=? mod -3.0)))))) (with-test-prefix "fldiv0" - (pass-if "simple" (or (fl=? (fldiv0 -123.0 10.0) -12.0) (throw 'unresolved)))) + (pass-if "simple" (fl=? (fldiv0 -123.0 10.0) -12.0))) (with-test-prefix "flmod0" - (pass-if "simple" (or (fl=? (flmod0 -123.0 10.0) -3.0) (throw 'unresolved)))) + (pass-if "simple" (fl=? (flmod0 -123.0 10.0) -3.0))) (with-test-prefix "flnumerator" (pass-if "simple" (fl=? (flnumerator 0.5) 1.0)) -- 1.5.6.5