From 13e5b1198a506e9b3c7c5d1dfafb2d78646a56b1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Jan 2007 06:22:16 +0000 Subject: [PATCH] reduce 3m overhead for many arithmetic primitives svn: r5455 --- src/mzscheme/src/bignum.c | 4 +- src/mzscheme/src/bool.c | 114 ++++-------- src/mzscheme/src/complex.c | 6 +- src/mzscheme/src/gmp/gmp.h | 2 +- src/mzscheme/src/number.c | 57 +++--- src/mzscheme/src/numcomp.c | 117 +++++++----- src/mzscheme/src/nummacs.h | 360 +++++++++++++++++++++++------------- src/mzscheme/src/numstr.c | 6 +- src/mzscheme/src/portfun.c | 2 +- src/mzscheme/src/rational.c | 28 ++- src/mzscheme/src/schemef.h | 24 +-- src/mzscheme/src/schemex.h | 4 +- src/mzscheme/src/schpriv.h | 44 ++--- 13 files changed, 446 insertions(+), 322 deletions(-) diff --git a/src/mzscheme/src/bignum.c b/src/mzscheme/src/bignum.c index 6e95e1f379..1e51972873 100644 --- a/src/mzscheme/src/bignum.c +++ b/src/mzscheme/src/bignum.c @@ -551,7 +551,7 @@ int scheme_bignum_eq(const Scheme_Object *a, const Scheme_Object *b) } /* - if a < b, 0 if a == b, + if a > b */ -static int bignum_abs_cmp(const Scheme_Object *a, const Scheme_Object *b) +XFORM_NONGCING static int bignum_abs_cmp(const Scheme_Object *a, const Scheme_Object *b) { long a_len, b_len; @@ -870,7 +870,7 @@ Scheme_Object *do_big_power(const Scheme_Object *a, const Scheme_Object *b) result = scheme_make_integer(1); v[1] = scheme_make_integer(-1); - while (SCHEME_FALSEP(scheme_zero_p(1, (Scheme_Object **)&b))) { + while (!scheme_is_zero(b)) { if (SCHEME_TRUEP(scheme_odd_p(1, (Scheme_Object **)&b))) result = scheme_bin_mult(a, result); a = scheme_bin_mult(a, a); diff --git a/src/mzscheme/src/bool.c b/src/mzscheme/src/bool.c index 3858858b25..ccf6f76714 100644 --- a/src/mzscheme/src/bool.c +++ b/src/mzscheme/src/bool.c @@ -123,6 +123,42 @@ int scheme_eq (Scheme_Object *obj1, Scheme_Object *obj2) return SAME_OBJ(obj1, obj2); } +XFORM_NONGCING static MZ_INLINE int double_eqv(double a, double b) +{ +# ifndef NAN_EQUALS_ANYTHING + if (a != b) { +# endif + /* Double-check for NANs: */ + if (MZ_IS_NAN(a)) { + if (MZ_IS_NAN(b)) + return 1; +# ifdef NAN_EQUALS_ANYTHING + return 0; +# endif + } +# ifdef NAN_EQUALS_ANYTHING + if (MZ_IS_NAN(b)) + return 0; + else { + if (a == 0.0) { + if (b == 0.0) { + return scheme_minus_zero_p(a) == scheme_minus_zero_p(b); + } + } + return (a == b); + } +# else + return 0; + } + if (a == 0.0) { + if (b == 0.0) { + return scheme_minus_zero_p(a) == scheme_minus_zero_p(b); + } + } + return 1; +# endif +} + int scheme_eqv (Scheme_Object *obj1, Scheme_Object *obj2) { Scheme_Type t1, t2; @@ -135,87 +171,19 @@ int scheme_eqv (Scheme_Object *obj1, Scheme_Object *obj2) if (NOT_SAME_TYPE(t1, t2)) { #ifdef MZ_USE_SINGLE_FLOATS - /* If one is a float and the other is a double, corce to double */ + /* If one is a float and the other is a double, coerce to double */ if ((t1 == scheme_float_type) && (t2 == scheme_double_type)) - return scheme_eqv(scheme_make_double(SCHEME_FLT_VAL(obj1)), obj2); + return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_DBL_VAL(obj2)); else if ((t2 == scheme_float_type) && (t1 == scheme_double_type)) - return scheme_eqv(scheme_make_double(SCHEME_FLT_VAL(obj2)), obj1); + return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_FLT_VAL(obj2)); #endif return 0; #ifdef MZ_USE_SINGLE_FLOATS } else if (t1 == scheme_float_type) { - float a, b; - a = SCHEME_FLT_VAL(obj1); - b = SCHEME_FLT_VAL(obj2); -# ifndef NAN_EQUALS_ANYTHING - if (a != b) { -# endif - /* Double-check for NANs: */ - if (MZ_IS_NAN(a)) { - if (MZ_IS_NAN(b)) - return 1; -# ifdef NAN_EQUALS_ANYTHING - return 0; -# endif - } -# ifdef NAN_EQUALS_ANYTHING - if (MZ_IS_NAN(b)) - return 0; - else { - if (a == 0.0) { - if (b == 0.0) { - return scheme_minus_zero_p(a) == scheme_minus_zero_p(b); - } - } - return (a == b); - } -# else - return 0; - } - if (a == 0.0) { - if (b == 0.0) { - return scheme_minus_zero_p(a) == scheme_minus_zero_p(b); - } - } - return 1; -# endif + return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_FLT_VAL(obj2)); #endif } else if (t1 == scheme_double_type) { - double a, b; - a = SCHEME_DBL_VAL(obj1); - b = SCHEME_DBL_VAL(obj2); -# ifndef NAN_EQUALS_ANYTHING - if (a != b) { -# endif - /* Double-check for NANs: */ - if (MZ_IS_NAN(a)) { - if (MZ_IS_NAN(b)) - return 1; -# ifdef NAN_EQUALS_ANYTHING - return 0; -# endif - } -# ifdef NAN_EQUALS_ANYTHING - if (MZ_IS_NAN(b)) - return 0; - else { - if (a == 0.0) { - if (b == 0.0) { - return scheme_minus_zero_p(a) == scheme_minus_zero_p(b); - } - } - return (a == b); - } -# else - return 0; - } - if (a == 0.0) { - if (b == 0.0) { - return scheme_minus_zero_p(a) == scheme_minus_zero_p(b); - } - } - return 1; -# endif + return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_DBL_VAL(obj2)); } else if (t1 == scheme_bignum_type) return scheme_bignum_eq(obj1, obj2); else if (t1 == scheme_rational_type) diff --git a/src/mzscheme/src/complex.c b/src/mzscheme/src/complex.c index 2ad19d77ad..825b5a3f10 100644 --- a/src/mzscheme/src/complex.c +++ b/src/mzscheme/src/complex.c @@ -250,8 +250,7 @@ Scheme_Object *scheme_complex_divide(const Scheme_Object *_n, const Scheme_Objec return scheme_make_complex(r, i); } - aa[0] = d; - if (SCHEME_TRUEP(scheme_zero_p(1, aa))) { + if (scheme_is_zero(d)) { /* This is like dividing by a real number, except that the inexact 0 imaginary part can interact with +inf.0 and +nan.0 */ r = scheme_bin_plus(scheme_bin_div(a, c), @@ -263,8 +262,7 @@ Scheme_Object *scheme_complex_divide(const Scheme_Object *_n, const Scheme_Objec return scheme_make_complex(r, i); } - aa[0] = c; - if (SCHEME_TRUEP(scheme_zero_p(1, aa))) { + if (scheme_is_zero(c)) { r = scheme_bin_plus(scheme_bin_div(b, d), /* Either 0.0 or +nan.0: */ scheme_bin_mult(c, a)); diff --git a/src/mzscheme/src/gmp/gmp.h b/src/mzscheme/src/gmp/gmp.h index 75a915d45b..5db0b6411c 100644 --- a/src/mzscheme/src/gmp/gmp.h +++ b/src/mzscheme/src/gmp/gmp.h @@ -283,7 +283,7 @@ mp_limb_t mpn_addmul_1c _PROTO ((mp_ptr, mp_srcptr, mp_size_t, mp_limb_t, mp_lim mp_limb_t mpn_addsub_n _PROTO ((mp_ptr, mp_ptr, mp_srcptr, mp_srcptr, mp_size_t)); mp_limb_t mpn_bdivmod _PROTO ((mp_ptr, mp_ptr, mp_size_t, mp_srcptr, mp_size_t, unsigned long int)); -int mpn_cmp _PROTO ((mp_srcptr, mp_srcptr, mp_size_t)); +XFORM_NONGCING int mpn_cmp _PROTO ((mp_srcptr, mp_srcptr, mp_size_t)); #define mpn_divexact_by3(dst, src, size) mpn_divexact_by3c (dst, src, size, 0) diff --git a/src/mzscheme/src/number.c b/src/mzscheme/src/number.c index 14ec0c68c3..59a3cf4a4f 100644 --- a/src/mzscheme/src/number.c +++ b/src/mzscheme/src/number.c @@ -619,7 +619,7 @@ double scheme_real_to_double(Scheme_Object *r) return 0.0; } -static MZ_INLINE int minus_zero_p(double d) +XFORM_NONGCING static MZ_INLINE int minus_zero_p(double d) { return (1 / d) < 0; } @@ -719,7 +719,7 @@ rational_p(int argc, Scheme_Object *argv[]) Scheme_Object *o = argv[0]; return (SCHEME_REALP(o) ? scheme_true : scheme_false); } - + int scheme_is_integer(const Scheme_Object *o) { if (SCHEME_INTP(o) || SCHEME_BIGNUMP(o)) @@ -749,7 +749,7 @@ integer_p (int argc, Scheme_Object *argv[]) return scheme_is_integer(argv[0]) ? scheme_true : scheme_false; } -int scheme_is_exact(Scheme_Object *n) +int scheme_is_exact(const Scheme_Object *n) { if (SCHEME_INTP(n)) { return 1; @@ -769,21 +769,24 @@ int scheme_is_exact(Scheme_Object *n) else if (type == scheme_complex_izi_type) return 0; else { - scheme_wrong_type("exact?", "number", 0, 1, &n); - return 0; + return -1; } } } -static Scheme_Object * +Scheme_Object * exact_p (int argc, Scheme_Object *argv[]) { - return (scheme_is_exact(argv[0]) - ? scheme_true - : scheme_false); + int v; + v = scheme_is_exact(argv[0]); + if (v < 0) { + scheme_wrong_type("exact?", "number", 0, argc, argv); + ESCAPED_BEFORE_HERE; + } + return (v ? scheme_true : scheme_false); } -int scheme_is_inexact(Scheme_Object *n) +int scheme_is_inexact(const Scheme_Object *n) { if (SCHEME_INTP(n)) { return 0; @@ -803,8 +806,7 @@ int scheme_is_inexact(Scheme_Object *n) else if (type == scheme_complex_izi_type) return 1; else { - scheme_wrong_type("inexact?", "number", 0, 1, &n); - return 0; + return -1; } } } @@ -812,9 +814,13 @@ int scheme_is_inexact(Scheme_Object *n) Scheme_Object * scheme_inexact_p (int argc, Scheme_Object *argv[]) { - return (scheme_is_inexact(argv[0]) - ? scheme_true - : scheme_false); + int v; + v = scheme_is_inexact(argv[0]); + if (v < 0) { + scheme_wrong_type("inexact?", "number", 0, argc, argv); + ESCAPED_BEFORE_HERE; + } + return (v ? scheme_true : scheme_false); } @@ -1693,7 +1699,7 @@ Scheme_Object *scheme_sqrt (int argc, Scheme_Object *argv[]) if (!SCHEME_REALP(n)) scheme_wrong_type("sqrt", "number", 0, argc, argv); - if (SCHEME_TRUEP(scheme_negative_p(1, &n))) { + if (scheme_is_negative(n)) { n = scheme_bin_minus(zeroi, n); imaginary = 1; } @@ -1747,7 +1753,7 @@ Scheme_Object *do_int_sqrt (const char *name, int argc, Scheme_Object *argv[], i } else if (SCHEME_INTP(v) || SCHEME_BIGNUMP(v)) { int imaginary = 0; - if (SCHEME_TRUEP(scheme_negative_p(1, &v))) { + if (scheme_is_negative(v)) { v = scheme_bin_minus(zeroi, v); imaginary = 1; } @@ -1937,11 +1943,9 @@ scheme_expt(int argc, Scheme_Object *argv[]) } if (!SCHEME_COMPLEXP(e)) { - neg = SCHEME_TRUEP(scheme_negative_p(1, &e)); + neg = scheme_is_negative(e); } else { - Scheme_Object *a[1]; - a[0] = scheme_complex_real_part(e); - neg = SCHEME_FALSEP(scheme_positive_p(1, a)); + neg = !scheme_is_positive(scheme_complex_real_part(e)); } if (neg) { @@ -1955,7 +1959,7 @@ scheme_expt(int argc, Scheme_Object *argv[]) if (!SCHEME_FLOATP(n)) { /* negative integer power of exact: compute positive power and invert */ if (SCHEME_INTP(e) || SCHEME_BIGNUMP(e)) { - if (SCHEME_FALSEP(scheme_positive_p(1, &e))) { + if (!scheme_is_positive(e)) { e = scheme_bin_minus(zeroi, e); invert = 1; } @@ -1995,7 +1999,7 @@ scheme_expt(int argc, Scheme_Object *argv[]) /* Treat it as even for sign purposes: */ iseven = 1; } - isnonneg = SCHEME_FALSEP(scheme_negative_p(1, &e)); + isnonneg = !scheme_is_negative(e); negz = scheme_minus_zero_p(d); if (isnonneg) { @@ -2146,8 +2150,7 @@ static Scheme_Object *magnitude(int argc, Scheme_Object *argv[]) i = r; r = tmp; } - a[0] = r; - if (SCHEME_TRUEP(scheme_zero_p(1, a))) { + if (scheme_is_zero(r)) { a[0] = i; return scheme_exact_to_inexact(1, a); } @@ -2224,7 +2227,7 @@ static Scheme_Object *angle(int argc, Scheme_Object *argv[]) scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO, "angle: undefined for 0"); ESCAPED_BEFORE_HERE; - } else if (SCHEME_TRUEP(scheme_positive_p(1, argv))) + } else if (scheme_is_positive(o)) return zeroi; else { # ifdef USE_SINGLE_FLOATS_AS_DEFAULT @@ -2388,7 +2391,7 @@ scheme_bitwise_shift(int argc, Scheme_Object *argv[]) if (!SCHEME_INTP(so)) { if (SCHEME_BIGNUMP(so)) { if (!SCHEME_BIGPOS(so)) { - if (SCHEME_TRUEP(scheme_negative_p(1, &v))) + if (scheme_is_negative(v)) return scheme_make_integer(-1); else return scheme_make_integer(0); diff --git a/src/mzscheme/src/numcomp.c b/src/mzscheme/src/numcomp.c index db0390f900..1ad239d434 100644 --- a/src/mzscheme/src/numcomp.c +++ b/src/mzscheme/src/numcomp.c @@ -31,6 +31,9 @@ static Scheme_Object *lt (int argc, Scheme_Object *argv[]); static Scheme_Object *gt (int argc, Scheme_Object *argv[]); static Scheme_Object *lt_eq (int argc, Scheme_Object *argv[]); static Scheme_Object *gt_eq (int argc, Scheme_Object *argv[]); +static Scheme_Object *zero_p (int argc, Scheme_Object *argv[]); +static Scheme_Object *positive_p (int argc, Scheme_Object *argv[]); +static Scheme_Object *negative_p (int argc, Scheme_Object *argv[]); static Scheme_Object *sch_max (int argc, Scheme_Object *argv[]); static Scheme_Object *sch_min (int argc, Scheme_Object *argv[]); @@ -60,15 +63,15 @@ void scheme_init_numcomp(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; scheme_add_global_constant(">=", p, env); - p = scheme_make_folding_prim(scheme_zero_p, "zero?", 1, 1, 1); + p = scheme_make_folding_prim(zero_p, "zero?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant("zero?", p, env); - p = scheme_make_folding_prim(scheme_positive_p, "positive?", 1, 1, 1); + p = scheme_make_folding_prim(positive_p, "positive?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant("positive?", p, env); - p = scheme_make_folding_prim(scheme_negative_p, "negative?", 1, 1, 1); + p = scheme_make_folding_prim(negative_p, "negative?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant("negative?", p, env); @@ -128,38 +131,37 @@ GEN_NARY_COMP(gt_eq, ">=", scheme_bin_gt_eq, SCHEME_REALP, REAL_NUMBER_STR) #define GEN_IDENT_FOR_IZI GEN_IDENT -GEN_BIN_COMP(scheme_bin_eq, "=", EQUAL, EQUAL, scheme_bignum_eq, scheme_rational_eq, scheme_complex_eq, 0, 0, scheme_inexact_p, scheme_inexact_p, GEN_IDENT, GEN_IDENT, "number") -GEN_BIN_COMP(scheme_bin_lt, "<", LESS_THAN, fLESS_THAN, scheme_bignum_lt, scheme_rational_lt, COMP_IZI_LT, 0, 1, scheme_positive_p, scheme_negative_p, GEN_IDENT_FOR_IZI, GEN_OMIT, REAL_NUMBER_STR) -GEN_BIN_COMP(scheme_bin_gt, ">", GREATER_THAN, GREATER_THAN, scheme_bignum_gt, scheme_rational_gt, COMP_IZI_GT, 1, 0, scheme_negative_p, scheme_positive_p, GEN_IDENT_FOR_IZI, GEN_OMIT, REAL_NUMBER_STR) -GEN_BIN_COMP(scheme_bin_lt_eq, "<=", LESS_OR_EQUAL, fLESS_OR_EQUAL, scheme_bignum_le, scheme_rational_le, COMP_IZI_LT_EQ, 0, 1, scheme_positive_p, scheme_negative_p, GEN_IDENT_FOR_IZI, GEN_OMIT, REAL_NUMBER_STR) -GEN_BIN_COMP(scheme_bin_gt_eq, ">=", GREATER_OR_EQUAL, GREATER_OR_EQUAL, scheme_bignum_ge, scheme_rational_ge, COMP_IZI_GT_EQ, 1, 0, scheme_negative_p, scheme_positive_p, GEN_IDENT_FOR_IZI, GEN_OMIT, REAL_NUMBER_STR) +GEN_BIN_COMP(scheme_bin_eq, "=", EQUAL, EQUAL, scheme_bignum_eq, scheme_rational_eq, scheme_complex_eq, 0, 0, scheme_is_inexact, scheme_is_inexact, GEN_IDENT, GEN_IDENT, "number") +GEN_BIN_COMP(scheme_bin_lt, "<", LESS_THAN, fLESS_THAN, scheme_bignum_lt, scheme_rational_lt, COMP_IZI_LT, 0, 1, scheme_is_positive, scheme_is_negative, GEN_IDENT_FOR_IZI, GEN_OMIT, REAL_NUMBER_STR) +GEN_BIN_COMP(scheme_bin_gt, ">", GREATER_THAN, GREATER_THAN, scheme_bignum_gt, scheme_rational_gt, COMP_IZI_GT, 1, 0, scheme_is_negative, scheme_is_positive, GEN_IDENT_FOR_IZI, GEN_OMIT, REAL_NUMBER_STR) +GEN_BIN_COMP(scheme_bin_lt_eq, "<=", LESS_OR_EQUAL, fLESS_OR_EQUAL, scheme_bignum_le, scheme_rational_le, COMP_IZI_LT_EQ, 0, 1, scheme_is_positive, scheme_is_negative, GEN_IDENT_FOR_IZI, GEN_OMIT, REAL_NUMBER_STR) +GEN_BIN_COMP(scheme_bin_gt_eq, ">=", GREATER_OR_EQUAL, GREATER_OR_EQUAL, scheme_bignum_ge, scheme_rational_ge, COMP_IZI_GT_EQ, 1, 0, scheme_is_negative, scheme_is_positive, GEN_IDENT_FOR_IZI, GEN_OMIT, REAL_NUMBER_STR) -Scheme_Object * -scheme_zero_p (int argc, Scheme_Object *argv[]) +int +scheme_is_zero(const Scheme_Object *o) { Scheme_Type t; - Scheme_Object *o = argv[0]; top: if (SCHEME_INTP(o)) - return (o == zeroi) ? scheme_true : scheme_false; + return o == zeroi; t = _SCHEME_TYPE(o); #ifdef MZ_USE_SINGLE_FLOATS if (t == scheme_float_type) { # ifdef NAN_EQUALS_ANYTHING if (MZ_IS_NAN(SCHEME_FLT_VAL(o))) - return scheme_false; + return 0; # endif - return (SCHEME_FLT_VAL(o) == 0.0f) ? scheme_true : scheme_false; + return SCHEME_FLT_VAL(o) == 0.0f; } #endif if (t == scheme_double_type) { #ifdef NAN_EQUALS_ANYTHING if (MZ_IS_NAN(SCHEME_DBL_VAL(o))) - return scheme_false; + return 0; #endif - return (SCHEME_DBL_VAL(o) == 0.0) ? scheme_true : scheme_false; + return SCHEME_DBL_VAL(o) == 0.0; } if (t == scheme_complex_izi_type) { @@ -168,98 +170,125 @@ scheme_zero_p (int argc, Scheme_Object *argv[]) } if ((t >= scheme_bignum_type) && (t <= scheme_complex_type)) - return scheme_false; + return 0; - NEED_NUMBER(zero?); - - ESCAPED_BEFORE_HERE; + return -1; } Scheme_Object * -scheme_positive_p (int argc, Scheme_Object *argv[]) +zero_p (int argc, Scheme_Object *argv[]) +{ + int v; + v = scheme_is_zero(argv[0]); + if (v < 0) { + NEED_REAL(zero?); + ESCAPED_BEFORE_HERE; + } + return (v ? scheme_true : scheme_false); +} + +int +scheme_is_positive(const Scheme_Object *o) { Scheme_Type t; - Scheme_Object *o = argv[0]; top: if (SCHEME_INTP(o)) - return (SCHEME_INT_VAL(o) > 0 ? scheme_true : scheme_false); + return SCHEME_INT_VAL(o) > 0; t = _SCHEME_TYPE(o); #ifdef MZ_USE_SINGLE_FLOATS if (t == scheme_float_type) { float d = SCHEME_FLT_VAL(o); # ifdef NAN_EQUALS_ANYTHING if (MZ_IS_NAN(d)) - return scheme_false; + return 0; # endif - return (d > 0 ? scheme_true : scheme_false); + return d > 0; } #endif if (t == scheme_double_type) { double d = SCHEME_DBL_VAL(o); #ifdef NAN_EQUALS_ANYTHING if (MZ_IS_NAN(d)) - return scheme_false; + return 0; #endif - return (d > 0 ? scheme_true : scheme_false); + return d > 0; } if (t == scheme_bignum_type) - return (SCHEME_BIGPOS(o) ? scheme_true : scheme_false); + return SCHEME_BIGPOS(o); if (t == scheme_rational_type) - return (scheme_is_rational_positive(o) ? scheme_true : scheme_false); + return scheme_is_rational_positive(o); if (t == scheme_complex_izi_type) { o = IZI_REAL_PART(o); goto top; } - - NEED_REAL(positive?); - - ESCAPED_BEFORE_HERE; + return -1; } Scheme_Object * -scheme_negative_p (int argc, Scheme_Object *argv[]) +positive_p (int argc, Scheme_Object *argv[]) +{ + int v; + v = scheme_is_positive(argv[0]); + if (v < 0) { + NEED_REAL(positive?); + ESCAPED_BEFORE_HERE; + } + return (v ? scheme_true : scheme_false); +} + +int +scheme_is_negative(const Scheme_Object *o) { Scheme_Type t; - Scheme_Object *o = argv[0]; top: if (SCHEME_INTP(o)) - return (SCHEME_INT_VAL(o) < 0 ? scheme_true : scheme_false); + return SCHEME_INT_VAL(o) < 0; t = _SCHEME_TYPE(o); #ifdef MZ_USE_SINGLE_FLOATS if (t == scheme_float_type) { float d = SCHEME_FLT_VAL(o); # if defined(NAN_EQUALS_ANYTHING) || defined(NAN_LT_COMPARISON_WRONG) if (MZ_IS_NAN(d)) - return scheme_false; + return 0; # endif - return (d < 0 ? scheme_true : scheme_false); + return d < 0; } #endif if (t == scheme_double_type) { double d = SCHEME_DBL_VAL(o); # if defined(NAN_EQUALS_ANYTHING) || defined(NAN_LT_COMPARISON_WRONG) if (MZ_IS_NAN(d)) - return scheme_false; + return 0; #endif - return (d < 0 ? scheme_true : scheme_false); + return d < 0; } if (t == scheme_bignum_type) - return (!SCHEME_BIGPOS(o) ? scheme_true : scheme_false); + return !SCHEME_BIGPOS(o); if (t == scheme_rational_type) - return (!scheme_is_rational_positive(o) ? scheme_true : scheme_false); + return !scheme_is_rational_positive(o); if (t == scheme_complex_izi_type) { o = IZI_REAL_PART(o); goto top; } - NEED_REAL(negative?); + return -1; +} - ESCAPED_BEFORE_HERE; +Scheme_Object * +negative_p (int argc, Scheme_Object *argv[]) +{ + int v; + v = scheme_is_negative(argv[0]); + if (v < 0) { + NEED_REAL(negative?); + ESCAPED_BEFORE_HERE; + } + return (v ? scheme_true : scheme_false); } #define MAX(n1,n2) scheme_make_integer((n1>n2) ? n1 : n2) diff --git a/src/mzscheme/src/nummacs.h b/src/mzscheme/src/nummacs.h index 130f4d36bd..c87def637b 100644 --- a/src/mzscheme/src/nummacs.h +++ b/src/mzscheme/src/nummacs.h @@ -1,5 +1,5 @@ /* - MzScheme + Mzscheme Copyright (c) 2004-2007 PLT Scheme Inc. Copyright (c) 1995 Matthew Flatt @@ -28,8 +28,6 @@ scheme_wrong_type(#name, REAL_NUMBER_STR, 0, argc, argv) #define NEED_INTEGER(name) \ scheme_wrong_type(#name, "integer", 0, argc, argv) -#define WRONG_TYPE(name, expected, value) \ - scheme_wrong_type(name, expected, -1, 0, (Scheme_Object **)&value) #define rat_from_float(d, sr) force_rat(scheme_rational_from_float(d), sr) #define rat_from_double(d, sr) force_rat(scheme_rational_from_double(d), sr) @@ -92,11 +90,177 @@ static Scheme_Object *name (const Scheme_Object *n1, const Scheme_Object *n2) nanchk, snanchk, \ complexwrap, noniziwrap, exactzerowrapl, exactzerowrapr, numbertype,\ toi_or_toe) \ +rettype name (const Scheme_Object *n1, const Scheme_Object *n2); \ +static rettype name ## __wrong_type(const Scheme_Object *v) \ +{ \ + Scheme_Object *a[1]; \ + a[0] = (Scheme_Object *)v; \ + scheme_wrong_type(scheme_name, numbertype, -1, 0, a); \ + return 0; \ +} \ +static MZ_INLINE rettype name ## __int_big(const Scheme_Object *n1, const Scheme_Object *n2) { \ + Small_Bignum sb; \ + return bn_op((scheme_make_small_bignum(SCHEME_INT_VAL(n1), \ + &sb)), \ + (n2)); \ +} \ +static MZ_INLINE rettype name ## __int_rat(const Scheme_Object *n1, const Scheme_Object *n2) { \ + Small_Rational sr1; \ + return rop((scheme_make_small_rational(SCHEME_INT_VAL(n1), \ + &sr1)), \ + (n2)); \ +} \ +complexwrap( \ +static MZ_INLINE rettype name ## __int_comp(const Scheme_Object *n1, const Scheme_Object *n2) { \ + Small_Complex sc; \ + return cxop((scheme_make_small_complex(n1, &sc)), \ + (n2)); \ +}) \ +FLOATWRAP( \ +static MZ_INLINE rettype name ## __flt_big(const Scheme_Object *n1, const Scheme_Object *n2) { \ + Small_Rational sr2; \ + snanchk(d1); \ + wrap(if (MZ_IS_POS_INFINITY(d1)) return combineinf(swaybigf, n2);) \ + wrap(if (MZ_IS_NEG_INFINITY(d1)) return combineinf(swaysmallf, n2);) \ + return toi_or_toe(fsop(d1, scheme_bignum_to_float(n2)), \ + rop(rat_from_float(d1, &sr2), scheme_integer_to_rational(n2))); \ +}) \ +FLOATWRAP( \ +static MZ_INLINE rettype name ## __flt_rat(const Scheme_Object *n1, const Scheme_Object *n2) { \ + Small_Rational sr3; \ + snanchk(d1); \ + wrap(if (MZ_IS_POS_INFINITY(d1)) return combineinf(swaybigf, n2);) \ + wrap(if (MZ_IS_NEG_INFINITY(d1)) return combineinf(swaysmallf, n2);) \ + wrap(if (d1 == 0.0) return combinezero(sfirstzero, n2, d1);) \ + return toi_or_toe(fsop(d1, scheme_rational_to_float(n2)), \ + rop(rat_from_float(d1, &sr3), (n2))); \ +})\ +FLOATWRAP(complexwrap( \ +static MZ_INLINE rettype name ## __flt_comp(const Scheme_Object *n1, const Scheme_Object *n2) { \ + Small_Complex sc; \ + snanchk(d1); \ + return cxop((scheme_make_small_complex(n1, &sc)), \ + (n2)); \ +})) \ +static MZ_INLINE rettype name ## __dbl_big(double d1, const Scheme_Object *n1, const Scheme_Object *n2) { \ + toi_or_toe(,Small_Rational sr4); \ + nanchk(d1); \ + wrap(if (MZ_IS_POS_INFINITY(d1)) return combineinf(waybigf, n2);) \ + wrap(if (MZ_IS_NEG_INFINITY(d1)) return combineinf(waysmallf, n2);) \ + return toi_or_toe(fop(d1, scheme_bignum_to_double(n2)), \ + rop(rat_from_double(d1, &sr4), scheme_integer_to_rational(n2))); \ +} \ +static MZ_INLINE rettype name ## __dbl_rat(double d1, const Scheme_Object *n1, const Scheme_Object *n2) { \ + toi_or_toe(,Small_Rational sr5); \ + nanchk(d1); \ + wrap(if (MZ_IS_POS_INFINITY(d1)) return combineinf(waybigf, n2);) \ + wrap(if (MZ_IS_NEG_INFINITY(d1)) return combineinf(waysmallf, n2);) \ + wrap(if (d1 == 0.0) return combinezero(firstzero, n2, d1);) \ + return toi_or_toe(fop(d1, scheme_rational_to_double(n2)), \ + rop(rat_from_double(d1, &sr5), (n2))); \ +} \ +complexwrap( \ +static MZ_INLINE rettype name ## __dbl_comp(double d1, const Scheme_Object *n1, const Scheme_Object *n2) { \ + Small_Complex sc; \ + nanchk(d1); \ + return cxop((scheme_make_small_complex(n1, &sc)), \ + (n2)); \ +}) \ +FLOATWRAP( \ +static MZ_INLINE rettype name ## __big_flt(double d1, const Scheme_Object *n1, const Scheme_Object *n2) { \ + Small_Rational sr6; \ + float d2; \ + d2 = SCHEME_FLT_VAL(n2); \ + snanchk(d2); \ + wrap(if (MZ_IS_POS_INFINITY(d2)) return combineinf(swaysmalls, n1);) \ + wrap(if (MZ_IS_NEG_INFINITY(d2)) return combineinf(swaybigs, n1);) \ + return toi_or_toe(fsop(scheme_bignum_to_float(n1), d2), \ + rop(scheme_integer_to_rational(n1), rat_from_float(d2, &sr6))); \ +}) \ +static MZ_INLINE rettype name ## __big_dbl(const Scheme_Object *n1, const Scheme_Object *n2) { \ + double d2; \ + toi_or_toe(,Small_Rational sr7); \ + d2 = SCHEME_DBL_VAL(n2); \ + nanchk(d2); \ + wrap(if (MZ_IS_POS_INFINITY(d2)) return combineinf(waysmalls, n1);) \ + wrap(if (MZ_IS_NEG_INFINITY(d2)) return combineinf(waybigs, n1);) \ + return toi_or_toe(fop(scheme_bignum_to_double(n1), d2), \ + rop(scheme_integer_to_rational(n1), rat_from_double(d2, &sr7))); \ +} \ +static MZ_INLINE rettype name ## __big_rat(const Scheme_Object *n1, const Scheme_Object *n2) { \ + return rop(scheme_integer_to_rational(n1), (n2)); \ +} \ +static MZ_INLINE rettype name ## __big_comp(const Scheme_Object *n1, const Scheme_Object *n2) { \ + Small_Complex sc; \ + return cxop((scheme_make_small_complex(n1, &sc)), (n2)); \ +} \ +static MZ_INLINE rettype name ## __rat_int(const Scheme_Object *n1, const Scheme_Object *n2) { \ + Small_Rational sr8; \ + return rop((n1), \ + (scheme_make_small_rational(SCHEME_INT_VAL(n2), \ + &sr8))); \ +} \ +FLOATWRAP( \ +static MZ_INLINE rettype name ## __rat_flt(const Scheme_Object *n1, const Scheme_Object *n2) { \ + Small_Rational sr9; \ + float d2; \ + d2 = SCHEME_FLT_VAL(n2); \ + snanchk(d2); \ + wrap(if (MZ_IS_POS_INFINITY(d2)) return combineinf(swaysmalls, n1);) \ + wrap(if (MZ_IS_NEG_INFINITY(d2)) return combineinf(swaybigs, n1);) \ + wrap(if (d2 == 0.0) return combinezero(ssecondzero, n1, d2);) \ + return toi_or_toe(fsop(scheme_rational_to_float(n1), d2), \ + rop((n1), rat_from_float(d2, &sr9))); \ +}) \ +static MZ_INLINE rettype name ## __rat_dbl(const Scheme_Object *n1, const Scheme_Object *n2) { \ + double d2; \ + toi_or_toe(,Small_Rational sr10); \ + d2 = SCHEME_DBL_VAL(n2); \ + nanchk(d2); \ + wrap(if (MZ_IS_POS_INFINITY(d2)) return combineinf(waysmalls, n1);) \ + wrap(if (MZ_IS_NEG_INFINITY(d2)) return combineinf(waybigs, n1);) \ + wrap(if (d2 == 0.0) return combinezero(secondzero, n1, d2);) \ + return toi_or_toe(fop(scheme_rational_to_double(n1), d2), \ + rop((n1), rat_from_double(d2, &sr10))); \ +} \ +static MZ_INLINE rettype name ## __rat_big(const Scheme_Object *n1, const Scheme_Object *n2) { \ + return rop((n1), scheme_integer_to_rational(n2)); \ +} \ +complexwrap( \ +static MZ_INLINE rettype name ## __rat_comp(const Scheme_Object *n1, const Scheme_Object *n2) { \ + Small_Complex sc; \ + return cxop((scheme_make_small_complex(n1, &sc)), (n2)); \ +}) \ +complexwrap( \ +static MZ_INLINE rettype name ## __comp_int(const Scheme_Object *n1, const Scheme_Object *n2) { \ + Small_Complex sc; \ + return cxop((n1), (scheme_make_small_complex(n2, &sc))); \ +}) \ +FLOATWRAP(complexwrap( \ +static MZ_INLINE rettype name ## __comp_flt(const Scheme_Object *n1, const Scheme_Object *n2) { \ + Small_Complex sc; \ + snanchk(SCHEME_FLT_VAL(n2)); \ + return cxop((n1), (scheme_make_small_complex(n2, &sc))); \ +})) \ +complexwrap( \ +static MZ_INLINE rettype name ## __comp_dbl(const Scheme_Object *n1, const Scheme_Object *n2) { \ + Small_Complex sc; \ + nanchk(SCHEME_DBL_VAL(n2)); \ + return cxop((n1), (scheme_make_small_complex(n2, &sc))); \ +}) \ +complexwrap( \ +static MZ_INLINE rettype name ## __comp_big(const Scheme_Object *n1, const Scheme_Object *n2) { \ + Small_Complex sc; \ + return cxop((n1), (scheme_make_small_complex(n2, &sc))); \ +}) \ +complexwrap( \ +static MZ_INLINE rettype name ## __comp_rat(const Scheme_Object *n1, const Scheme_Object *n2) { \ + Small_Complex sc; \ + return cxop((n1), (scheme_make_small_complex(n2, &sc))); \ +}) \ rettype \ name (const Scheme_Object *n1, const Scheme_Object *n2) \ { \ - Small_Bignum sb; \ - Small_Rational sr; \ Scheme_Type t1, t2; \ exactzerowrapr( if (n2 == zeroi) ) \ if (SCHEME_INTP(n1)) \ @@ -117,22 +281,18 @@ name (const Scheme_Object *n1, const Scheme_Object *n2) \ nanchk(d); \ return fop(SCHEME_INT_VAL(n1), d); \ } \ - if (t2 == scheme_bignum_type) \ - return bn_op((scheme_make_small_bignum(SCHEME_INT_VAL(n1), \ - &sb)), \ - (n2)); \ - if (t2 == scheme_rational_type) \ - return rop((scheme_make_small_rational(SCHEME_INT_VAL(n1), \ - &sr)), \ - (n2)); \ + if (t2 == scheme_bignum_type) { \ + return name ## __int_big(n1, n2); \ + } \ + if (t2 == scheme_rational_type) { \ + return name ## __int_rat(n1, n2); \ + } \ complexwrap( \ if (noniziwrap((t2 == scheme_complex_type) ||) (t2 == scheme_complex_izi_type)) { \ - Small_Complex sc; \ - return cxop((scheme_make_small_complex(n1, &sc)), \ - (n2)); \ + return name ## __int_comp(n1, n2); \ } \ ) \ - WRONG_TYPE(scheme_name, numbertype, n2); \ + return name ## __wrong_type(n2); \ } \ else { \ t1 = _SCHEME_TYPE(n1); \ @@ -158,29 +318,17 @@ name (const Scheme_Object *n1, const Scheme_Object *n2) \ return fop(d1, d2); \ } \ if (t2 == scheme_bignum_type) { \ - snanchk(d1); \ - wrap(if (MZ_IS_POS_INFINITY(d1)) return combineinf(swaybigf, n2);) \ - wrap(if (MZ_IS_NEG_INFINITY(d1)) return combineinf(swaysmallf, n2);) \ - return toi_or_toe(fsop(d1, scheme_bignum_to_float(n2)), \ - rop(rat_from_float(d1, &sr), scheme_integer_to_rational(n2))); \ + return name ## __flt_big(n1, n2); \ } \ if (t2 == scheme_rational_type) { \ - snanchk(d1); \ - wrap(if (MZ_IS_POS_INFINITY(d1)) return combineinf(swaybigf, n2);) \ - wrap(if (MZ_IS_NEG_INFINITY(d1)) return combineinf(swaysmallf, n2);) \ - wrap(if (d1 == 0.0) return combinezero(sfirstzero, n2, d1);) \ - return toi_or_toe(fsop(d1, scheme_rational_to_float(n2)), \ - rop(rat_from_float(d1, &sr), (n2))); \ + return name ## __flt_rat(n1, n2); \ } \ complexwrap( \ if (noniziwrap((t2 == scheme_complex_type) ||) (t2 == scheme_complex_izi_type)) { \ - Small_Complex sc; \ - snanchk(d1); \ - return cxop((scheme_make_small_complex(n1, &sc)), \ - (n2)); \ + return name ## __flt_comp(n1, n2); \ } \ )\ - WRONG_TYPE(scheme_name, numbertype, n2); \ + return name ## __wrong_type(n2); \ } else \ ) \ if (t1 == scheme_double_type) \ @@ -206,147 +354,96 @@ name (const Scheme_Object *n1, const Scheme_Object *n2) \ return fop(d1, d2); \ } \ if (t2 == scheme_bignum_type) { \ - nanchk(d1); \ - wrap(if (MZ_IS_POS_INFINITY(d1)) return combineinf(waybigf, n2);) \ - wrap(if (MZ_IS_NEG_INFINITY(d1)) return combineinf(waysmallf, n2);) \ - return toi_or_toe(fop(d1, scheme_bignum_to_double(n2)), \ - rop(rat_from_double(d1, &sr), scheme_integer_to_rational(n2))); \ + return name ## __dbl_big(d1, n1, n2); \ } \ if (t2 == scheme_rational_type) { \ - nanchk(d1); \ - wrap(if (MZ_IS_POS_INFINITY(d1)) return combineinf(waybigf, n2);) \ - wrap(if (MZ_IS_NEG_INFINITY(d1)) return combineinf(waysmallf, n2);) \ - wrap(if (d1 == 0.0) return combinezero(firstzero, n2, d1);) \ - return toi_or_toe(fop(d1, scheme_rational_to_double(n2)), \ - rop(rat_from_double(d1, &sr), (n2))); \ + return name ## __dbl_rat(d1, n1, n2); \ } \ complexwrap( \ if (noniziwrap((t2 == scheme_complex_type) ||) (t2 == scheme_complex_izi_type)) { \ - Small_Complex sc; \ - nanchk(d1); \ - return cxop((scheme_make_small_complex(n1, &sc)), \ - (n2)); \ + return name ## __dbl_comp(d1, n1, n2); \ } \ )\ - WRONG_TYPE(scheme_name, numbertype, n2); \ + return name ## __wrong_type(n2); \ } \ else if (t1 == scheme_bignum_type) \ { \ - if (SCHEME_INTP(n2)) \ + if (SCHEME_INTP(n2)) { \ + Small_Bignum sb; \ return bn_op((n1), \ (scheme_make_small_bignum(SCHEME_INT_VAL(n2), &sb))); \ + } \ t2 = _SCHEME_TYPE(n2); \ FLOATWRAP( \ if (t2 == scheme_float_type) { \ - float d2; \ - d2 = SCHEME_FLT_VAL(n2); \ - snanchk(d2); \ - wrap(if (MZ_IS_POS_INFINITY(d2)) return combineinf(swaysmalls, n1);) \ - wrap(if (MZ_IS_NEG_INFINITY(d2)) return combineinf(swaybigs, n1);) \ - return toi_or_toe(fsop(scheme_bignum_to_float(n1), d2), \ - rop(scheme_integer_to_rational(n1), rat_from_float(d2, &sr))); \ + return name ## __big_flt(n1, n2); \ } \ ) \ if (t2 == scheme_double_type) { \ - double d2; \ - d2 = SCHEME_DBL_VAL(n2); \ - nanchk(d2); \ - wrap(if (MZ_IS_POS_INFINITY(d2)) return combineinf(waysmalls, n1);) \ - wrap(if (MZ_IS_NEG_INFINITY(d2)) return combineinf(waybigs, n1);) \ - return toi_or_toe(fop(scheme_bignum_to_double(n1), d2), \ - rop(scheme_integer_to_rational(n1), rat_from_double(d2, &sr))); \ + return name ## __big_dbl(n1, n2); \ } \ if (t2 == scheme_bignum_type) \ return bn_op((n1), (n2)); \ if (t2 == scheme_rational_type) \ - return rop(scheme_integer_to_rational(n1), \ - (n2)); \ + return name ## __big_rat(n1, n2); \ complexwrap( \ if (noniziwrap((t2 == scheme_complex_type) ||) (t2 == scheme_complex_izi_type)) { \ - Small_Complex sc; \ - return cxop((scheme_make_small_complex(n1, &sc)), \ - (n2)); \ + return name ## __big_comp(n1, n2); \ } \ )\ - WRONG_TYPE(scheme_name, numbertype, n2); \ + return name ## __wrong_type(n2); \ } \ else if (t1 == scheme_rational_type) \ { \ - if (SCHEME_INTP(n2)) \ - return rop((n1), \ - (scheme_make_small_rational(SCHEME_INT_VAL(n2), \ - &sr))); \ + if (SCHEME_INTP(n2)) { \ + return name ## __rat_int(n1, n2); \ + } \ t2 = _SCHEME_TYPE(n2); \ FLOATWRAP( \ if (t2 == scheme_float_type) { \ - float d2; \ - d2 = SCHEME_FLT_VAL(n2); \ - snanchk(d2); \ - wrap(if (MZ_IS_POS_INFINITY(d2)) return combineinf(swaysmalls, n1);) \ - wrap(if (MZ_IS_NEG_INFINITY(d2)) return combineinf(swaybigs, n1);) \ - wrap(if (d2 == 0.0) return combinezero(ssecondzero, n1, d2);) \ - return toi_or_toe(fsop(scheme_rational_to_float(n1), d2), \ - rop((n1), rat_from_float(d2, &sr))); \ + return name ## __rat_flt(n1, n2); \ } \ ) \ if (t2 == scheme_double_type) { \ - double d2; \ - d2 = SCHEME_DBL_VAL(n2); \ - nanchk(d2); \ - wrap(if (MZ_IS_POS_INFINITY(d2)) return combineinf(waysmalls, n1);) \ - wrap(if (MZ_IS_NEG_INFINITY(d2)) return combineinf(waybigs, n1);) \ - wrap(if (d2 == 0.0) return combinezero(secondzero, n1, d2);) \ - return toi_or_toe(fop(scheme_rational_to_double(n1), d2), \ - rop((n1), rat_from_double(d2, &sr))); \ + return name ## __rat_dbl(n1, n2); \ } \ if (t2 == scheme_bignum_type) \ - return rop((n1), \ - scheme_integer_to_rational(n2)); \ + return name ## __rat_big(n1, n2); \ if (t2 == scheme_rational_type) \ return rop((n1), (n2)); \ complexwrap( \ if (noniziwrap((t2 == scheme_complex_type) ||) (t2 == scheme_complex_izi_type)) { \ - Small_Complex sc; \ - return cxop((scheme_make_small_complex(n1, &sc)), (n2)); \ + return name ## __rat_comp(n1, n2); \ } \ )\ - WRONG_TYPE(scheme_name, numbertype, n2); \ + return name ## __wrong_type(n2); \ } \ complexwrap( \ else if (noniziwrap((t1 == scheme_complex_type) ||) (t1 == scheme_complex_izi_type)) \ { \ - Small_Complex sc; \ if (SCHEME_INTP(n2)) \ - return cxop((n1), \ - (scheme_make_small_complex(n2, &sc))); \ + return name ## __comp_int(n1, n2); \ t2 = _SCHEME_TYPE(n2); \ FLOATWRAP( \ if (t2 == scheme_float_type) { \ - snanchk(SCHEME_FLT_VAL(n2)); \ - return cxop((n1), \ - (scheme_make_small_complex(n2, &sc))); \ + return name ## __comp_flt(n1, n2); \ } \ ) \ if (t2 == scheme_double_type) { \ - nanchk(SCHEME_DBL_VAL(n2)); \ - return cxop((n1), \ - (scheme_make_small_complex(n2, &sc))); \ + return name ## __comp_dbl(n1, n2); \ } \ if (t2 == scheme_bignum_type) \ - return cxop((n1), \ - (scheme_make_small_complex(n2, &sc))); \ + return name ## __comp_big(n1, n2); \ if (t2 == scheme_rational_type) \ - return cxop((n1), \ - (scheme_make_small_complex(n2, &sc))); \ + return name ## __comp_rat(n1, n2); \ if (noniziwrap((t2 == scheme_complex_type) ||) (t2 == scheme_complex_izi_type)) \ return cxop((n1), (n2)); \ - WRONG_TYPE(scheme_name, numbertype, n2); \ + return name ## __wrong_type(n2); \ } \ ) \ else \ - WRONG_TYPE(scheme_name, numbertype, n1); \ + return name ## __wrong_type(n1); \ } \ - return 0; \ } #ifdef NAN_EQUALS_ANYTHING @@ -360,7 +457,7 @@ name (const Scheme_Object *n1, const Scheme_Object *n2) \ #define GEN_FIRST_ONLY(x, y) x #define GEN_APPLY(x, y) x(y) #define GEN_APPLY3(x, y, z) x(y, z) -#define GEN_SCHEME_BOOL_APPLY(x, y, z) SCHEME_TRUEP(x(1, (Scheme_Object **)&y)) +#define GEN_SCHEME_BOOL_APPLY(x, y, z) x(y) #define GEN_TOI(x, y) x #define GEN_TOE(x, y) y @@ -371,17 +468,17 @@ name (const Scheme_Object *n1, const Scheme_Object *n2) \ #define GEN_RETURN_N2(x) x return (Scheme_Object *)n2; #define GEN_SINGLE_SUBTRACT_N2(x) x if SCHEME_FLOATP(n2) return minus(1, (Scheme_Object **)&n2); -#define GEN_SAME_INF(x) ((SCHEME_TRUEP(scheme_positive_p(1, (Scheme_Object **)&x))) ? scheme_inf_object : scheme_minus_inf_object) -#define GEN_OPP_INF(x) ((SCHEME_FALSEP(scheme_positive_p(1, (Scheme_Object **)&x))) ? scheme_inf_object : scheme_minus_inf_object) -#define GEN_MAKE_PZERO(x) ((SCHEME_FALSEP(scheme_positive_p(1, (Scheme_Object **)&x))) ? scheme_nzerod : scheme_zerod) -#define GEN_MAKE_NZERO(x) ((SCHEME_FALSEP(scheme_positive_p(1, (Scheme_Object **)&x))) ? scheme_zerod : scheme_nzerod) +#define GEN_SAME_INF(x) (scheme_is_positive(x) ? scheme_inf_object : scheme_minus_inf_object) +#define GEN_OPP_INF(x) (!scheme_is_positive(x) ? scheme_inf_object : scheme_minus_inf_object) +#define GEN_MAKE_PZERO(x) (!scheme_is_positive(x) ? scheme_nzerod : scheme_zerod) +#define GEN_MAKE_NZERO(x) (!scheme_is_positive(x) ? scheme_zerod : scheme_nzerod) #define GEN_MAKE_ZERO_Z(x, y) (scheme_minus_zero_p(y) ? GEN_MAKE_NZERO(x) : GEN_MAKE_PZERO(x)) #define GEN_SAME_INF_Z(x, y) (scheme_minus_zero_p(y) ? GEN_OPP_INF(x) : GEN_SAME_INF(x)) -#define GEN_SAME_SINF(x) ((SCHEME_TRUEP(scheme_positive_p(1, (Scheme_Object **)&x))) ? scheme_single_inf_object : scheme_single_minus_inf_object) -#define GEN_OPP_SINF(x) ((SCHEME_FALSEP(scheme_positive_p(1, (Scheme_Object **)&x))) ? scheme_single_inf_object : scheme_single_minus_inf_object) -#define GEN_MAKE_PSZERO(x) ((SCHEME_FALSEP(scheme_positive_p(1, (Scheme_Object **)&x))) ? scheme_nzerof : scheme_zerof) -#define GEN_MAKE_NSZERO(x) ((SCHEME_FALSEP(scheme_positive_p(1, (Scheme_Object **)&x))) ? scheme_zerof : scheme_nzerof) +#define GEN_SAME_SINF(x) (scheme_is_positive(x) ? scheme_single_inf_object : scheme_single_minus_inf_object) +#define GEN_OPP_SINF(x) (!scheme_is_positive(x) ? scheme_single_inf_object : scheme_single_minus_inf_object) +#define GEN_MAKE_PSZERO(x) (!scheme_is_positive(x) ? scheme_nzerof : scheme_zerof) +#define GEN_MAKE_NSZERO(x) (!scheme_is_positive(x) ? scheme_zerof : scheme_nzerof) #define GEN_MAKE_SZERO_Z(x, y) (scheme_minus_zero_p(y) ? GEN_MAKE_NSZERO(x) : GEN_MAKE_PSZERO(x)) #define GEN_SAME_SINF_Z(x, y) (scheme_minus_zero_p(y) ? GEN_OPP_SINF(x) : GEN_SAME_SINF(x)) @@ -430,30 +527,39 @@ name (const Scheme_Object *n1, const Scheme_Object *n2) \ complexwrap, noniziwrap, GEN_OMIT, GEN_OMIT, numbertype, GEN_TOE) #define GEN_BIN_INT_OP(name, scheme_name, op, bigop) \ +static Scheme_Object *name (const Scheme_Object *n1, const Scheme_Object *n2); \ +static Scheme_Object *name ## __wrong_type(const Scheme_Object *v) \ +{ \ + Scheme_Object *a[1]; \ + a[0] = (Scheme_Object *)v; \ + scheme_wrong_type(scheme_name, "exact integer", -1, 0, a); \ + return NULL; \ +} \ static Scheme_Object * \ name (const Scheme_Object *n1, const Scheme_Object *n2) \ { \ - Small_Bignum sb; \ if (SCHEME_INTP(n1)){ \ if (SCHEME_INTP(n2)) { \ long a, b; \ a = SCHEME_INT_VAL(n1); \ b = SCHEME_INT_VAL(n2); \ return scheme_make_integer(a op b); \ - } else if (SCHEME_BIGNUMP(n2)) \ + } else if (SCHEME_BIGNUMP(n2)) { \ + Small_Bignum sb; \ return bigop(scheme_make_small_bignum(SCHEME_INT_VAL(n1), &sb), n2); \ + } \ } else if (SCHEME_BIGNUMP(n1)) { \ - if (SCHEME_INTP(n2)) \ + if (SCHEME_INTP(n2)) { \ + Small_Bignum sb; \ return bigop(n1, scheme_make_small_bignum(SCHEME_INT_VAL(n2), &sb)); \ + } \ if (SCHEME_BIGNUMP(n2)) \ return bigop(n1, n2); \ } else { \ - WRONG_TYPE(scheme_name, "exact integer", n1); \ - return scheme_void; \ + return name ## __wrong_type(n1); \ } \ \ - WRONG_TYPE(scheme_name, "exact integer", n2); \ - return scheme_void; \ + return name ## __wrong_type(n2); \ } #define GEN_NARY_OP(stat, name, scheme_name, bin_name, ident, TYPEP, type) \ diff --git a/src/mzscheme/src/numstr.c b/src/mzscheme/src/numstr.c index 074c7d788a..301f336149 100644 --- a/src/mzscheme/src/numstr.c +++ b/src/mzscheme/src/numstr.c @@ -1198,12 +1198,12 @@ Scheme_Object *scheme_read_number(const mzchar *str, long len, /* Don't calculate a huge exponential if we're returning a float: */ if (result_is_float) { if (scheme_bin_gt(exponent, scheme_make_integer(CHECK_INF_EXP_THRESHOLD))) { - if (SCHEME_TRUEP(scheme_negative_p(1, &mantissa))) + if (scheme_is_negative(mantissa)) return CHECK_SINGLE(scheme_minus_inf_object, single); else return CHECK_SINGLE(scheme_inf_object, single); } else if (scheme_bin_lt(exponent, scheme_make_integer(-CHECK_INF_EXP_THRESHOLD))) { - if (SCHEME_TRUEP(scheme_negative_p(1, &mantissa))) + if (scheme_is_negative(mantissa)) return CHECK_SINGLE(scheme_nzerod, single); else return CHECK_SINGLE(scheme_zerod, single); @@ -1286,7 +1286,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, long len, if (SAME_OBJ(n2, scheme_false)) return scheme_false; - if (SCHEME_EXACT_REALP(n2) && SCHEME_TRUEP(scheme_zero_p(1, &n2))) { + if (SCHEME_EXACT_REALP(n2) && scheme_is_zero(n2)) { if (complain) scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, "read-number: division by zero: %u", diff --git a/src/mzscheme/src/portfun.c b/src/mzscheme/src/portfun.c index d4c57ff849..076aaed73f 100644 --- a/src/mzscheme/src/portfun.c +++ b/src/mzscheme/src/portfun.c @@ -2371,7 +2371,7 @@ static Scheme_Object *sch_pipe(int argc, Scheme_Object **args) if (SCHEME_FALSEP(o)) { bufmax = 0; } else if ((SCHEME_INTP(o) || SCHEME_BIGNUMP(o)) - && SCHEME_TRUEP(scheme_positive_p(1, args))) { + && scheme_is_positive(o)) { if (SCHEME_INTP(o)) bufmax = SCHEME_INT_VAL(o); else diff --git a/src/mzscheme/src/rational.c b/src/mzscheme/src/rational.c index df85065a4d..ef87c6d424 100644 --- a/src/mzscheme/src/rational.c +++ b/src/mzscheme/src/rational.c @@ -194,12 +194,27 @@ int scheme_rational_eq(const Scheme_Object *a, const Scheme_Object *b) return 1; } -int scheme_rational_lt(const Scheme_Object *a, const Scheme_Object *b) +static int rational_lt(const Scheme_Object *a, const Scheme_Object *b, int or_eq) { Scheme_Rational *ra = (Scheme_Rational *)a; Scheme_Rational *rb = (Scheme_Rational *)b; Scheme_Object *ma, *mb; + /* Avoid multiplication in simple cases: */ + if (scheme_bin_lt_eq(ra->num, rb->num) + && scheme_bin_gt_eq(ra->num, rb->num)) { + if (!or_eq) { + if (scheme_rational_eq(a, b)) + return 0; + } + return 1; + } else if (or_eq) { + if (scheme_rational_eq(a, b)) + return 1; + } + + /* Checking only for lt at this point */ + ma = scheme_bin_mult(ra->num, rb->denom); mb = scheme_bin_mult(rb->num, ra->denom); @@ -213,19 +228,24 @@ int scheme_rational_lt(const Scheme_Object *a, const Scheme_Object *b) return !SCHEME_BIGPOS(ma); } +int scheme_rational_lt(const Scheme_Object *a, const Scheme_Object *b) +{ + return rational_lt(a, b, 0); +} + int scheme_rational_gt(const Scheme_Object *a, const Scheme_Object *b) { - return !scheme_rational_lt(a, b) && !scheme_rational_eq(a, b); + return !rational_lt(a, b, 1); } int scheme_rational_le(const Scheme_Object *a, const Scheme_Object *b) { - return !scheme_rational_gt(a, b); + return rational_lt(a, b, 1); } int scheme_rational_ge(const Scheme_Object *a, const Scheme_Object *b) { - return !scheme_rational_lt(a, b); + return !rational_lt(a, b, 0); } Scheme_Object *scheme_rational_negate(const Scheme_Object *o) diff --git a/src/mzscheme/src/schemef.h b/src/mzscheme/src/schemef.h index 0be524bdc8..4a5199c698 100644 --- a/src/mzscheme/src/schemef.h +++ b/src/mzscheme/src/schemef.h @@ -514,12 +514,12 @@ MZ_EXTERN Scheme_Object **scheme_char_constants; MZ_EXTERN Scheme_Object *scheme_make_channel(); MZ_EXTERN Scheme_Object *scheme_make_channel_put_evt(Scheme_Object *ch, Scheme_Object *v); -MZ_EXTERN int scheme_get_int_val(Scheme_Object *o, long *v); -MZ_EXTERN int scheme_get_unsigned_int_val(Scheme_Object *o, unsigned long *v); -MZ_EXTERN int scheme_get_long_long_val(Scheme_Object *o, mzlonglong *v); -MZ_EXTERN int scheme_get_unsigned_long_long_val(Scheme_Object *o, umzlonglong *v); +XFORM_NONGCING MZ_EXTERN int scheme_get_int_val(Scheme_Object *o, long *v); +XFORM_NONGCING MZ_EXTERN int scheme_get_unsigned_int_val(Scheme_Object *o, unsigned long *v); +XFORM_NONGCING MZ_EXTERN int scheme_get_long_long_val(Scheme_Object *o, mzlonglong *v); +XFORM_NONGCING MZ_EXTERN int scheme_get_unsigned_long_long_val(Scheme_Object *o, umzlonglong *v); -MZ_EXTERN double scheme_real_to_double(Scheme_Object *r); +XFORM_NONGCING MZ_EXTERN double scheme_real_to_double(Scheme_Object *r); MZ_EXTERN Scheme_Object *scheme_make_cptr(void *cptr, Scheme_Object *typetag); @@ -587,17 +587,17 @@ MZ_EXTERN char *scheme_bignum_to_string(const Scheme_Object *n, int radix); MZ_EXTERN char *scheme_bignum_to_allocated_string(const Scheme_Object *n, int radix, int alloc); MZ_EXTERN Scheme_Object *scheme_read_bignum(const mzchar *str, int offset, int radix); MZ_EXTERN Scheme_Object *scheme_read_bignum_bytes(const char *str, int offset, int radix); -MZ_EXTERN Scheme_Object *scheme_bignum_normalize(const Scheme_Object *n); +XFORM_NONGCING MZ_EXTERN Scheme_Object *scheme_bignum_normalize(const Scheme_Object *n); /*========================================================================*/ /* rationals */ /*========================================================================*/ MZ_EXTERN Scheme_Object *scheme_make_rational(const Scheme_Object *r, const Scheme_Object *d); -MZ_EXTERN double scheme_rational_to_double(const Scheme_Object *n); +XFORM_NONGCING MZ_EXTERN double scheme_rational_to_double(const Scheme_Object *n); MZ_EXTERN Scheme_Object *scheme_rational_from_double(double d); #ifdef MZ_USE_SINGLE_FLOATS -MZ_EXTERN float scheme_rational_to_float(const Scheme_Object *n); +XFORM_NONGCING MZ_EXTERN float scheme_rational_to_float(const Scheme_Object *n); MZ_EXTERN Scheme_Object *scheme_rational_from_float(float d); #else # define scheme_rational_to_float scheme_rational_to_double @@ -617,8 +617,8 @@ MZ_EXTERN Scheme_Object *scheme_complex_real_part(const Scheme_Object *n); MZ_EXTERN Scheme_Object *scheme_complex_imaginary_part(const Scheme_Object *n); /* Exact/inexact: */ -MZ_EXTERN int scheme_is_exact(Scheme_Object *n); -MZ_EXTERN int scheme_is_inexact(Scheme_Object *n); +XFORM_NONGCING MZ_EXTERN int scheme_is_exact(const Scheme_Object *n); +XFORM_NONGCING MZ_EXTERN int scheme_is_inexact(const Scheme_Object *n); /*========================================================================*/ /* macros, syntax, and compilation */ @@ -952,8 +952,8 @@ XFORM_NONGCING MZ_EXTERN int scheme_is_subinspector(Scheme_Object *i, Scheme_Obj /* utilities */ /*========================================================================*/ -MZ_EXTERN int scheme_eq(Scheme_Object *obj1, Scheme_Object *obj2); -MZ_EXTERN int scheme_eqv(Scheme_Object *obj1, Scheme_Object *obj2); +XFORM_NONGCING MZ_EXTERN int scheme_eq(Scheme_Object *obj1, Scheme_Object *obj2); +XFORM_NONGCING MZ_EXTERN int scheme_eqv(Scheme_Object *obj1, Scheme_Object *obj2); MZ_EXTERN int scheme_equal(Scheme_Object *obj1, Scheme_Object *obj2); #ifdef MZ_PRECISE_GC diff --git a/src/mzscheme/src/schemex.h b/src/mzscheme/src/schemex.h index 63b1a24e7a..df715a3b2c 100644 --- a/src/mzscheme/src/schemex.h +++ b/src/mzscheme/src/schemex.h @@ -510,8 +510,8 @@ Scheme_Object *(*scheme_complex_normalize)(const Scheme_Object *n); Scheme_Object *(*scheme_complex_real_part)(const Scheme_Object *n); Scheme_Object *(*scheme_complex_imaginary_part)(const Scheme_Object *n); /* Exact/inexact: */ -int (*scheme_is_exact)(Scheme_Object *n); -int (*scheme_is_inexact)(Scheme_Object *n); +int (*scheme_is_exact)(const Scheme_Object *n); +int (*scheme_is_inexact)(const Scheme_Object *n); /*========================================================================*/ /* macros, syntax, and compilation */ /*========================================================================*/ diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index ea2fa6f493..2f38261d21 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -1251,19 +1251,19 @@ typedef struct { bigdig v[1]; } Small_Bignum; -Scheme_Object *scheme_make_small_bignum(long v, Small_Bignum *s); +XFORM_NONGCING Scheme_Object *scheme_make_small_bignum(long v, Small_Bignum *s); char *scheme_number_to_string(int radix, Scheme_Object *obj); -int scheme_bignum_get_int_val(const Scheme_Object *o, long *v); -int scheme_bignum_get_unsigned_int_val(const Scheme_Object *o, unsigned long *v); -int scheme_bignum_get_long_long_val(const Scheme_Object *o, mzlonglong *v); -int scheme_bignum_get_unsigned_long_long_val(const Scheme_Object *o, umzlonglong *v); +XFORM_NONGCING int scheme_bignum_get_int_val(const Scheme_Object *o, long *v); +XFORM_NONGCING int scheme_bignum_get_unsigned_int_val(const Scheme_Object *o, unsigned long *v); +XFORM_NONGCING int scheme_bignum_get_long_long_val(const Scheme_Object *o, mzlonglong *v); +XFORM_NONGCING int scheme_bignum_get_unsigned_long_long_val(const Scheme_Object *o, umzlonglong *v); -int scheme_bignum_eq(const Scheme_Object *a, const Scheme_Object *b); -int scheme_bignum_lt(const Scheme_Object *a, const Scheme_Object *b); -int scheme_bignum_gt(const Scheme_Object *a, const Scheme_Object *b); -int scheme_bignum_le(const Scheme_Object *a, const Scheme_Object *b); -int scheme_bignum_ge(const Scheme_Object *a, const Scheme_Object *b); +XFORM_NONGCING int scheme_bignum_eq(const Scheme_Object *a, const Scheme_Object *b); +XFORM_NONGCING int scheme_bignum_lt(const Scheme_Object *a, const Scheme_Object *b); +XFORM_NONGCING int scheme_bignum_gt(const Scheme_Object *a, const Scheme_Object *b); +XFORM_NONGCING int scheme_bignum_le(const Scheme_Object *a, const Scheme_Object *b); +XFORM_NONGCING int scheme_bignum_ge(const Scheme_Object *a, const Scheme_Object *b); Scheme_Object *scheme_bignum_negate(const Scheme_Object *n); Scheme_Object *scheme_bignum_add(const Scheme_Object *a, const Scheme_Object *b); Scheme_Object *scheme_bignum_subtract(const Scheme_Object *a, const Scheme_Object *b); @@ -1284,9 +1284,9 @@ Scheme_Object *scheme_bignum_xor(const Scheme_Object *a, const Scheme_Object *b) Scheme_Object *scheme_bignum_not(const Scheme_Object *a); Scheme_Object *scheme_bignum_shift(const Scheme_Object *a, long shift); -double scheme_bignum_to_double_inf_info(const Scheme_Object *n, int just_use, int *only_need); +XFORM_NONGCING double scheme_bignum_to_double_inf_info(const Scheme_Object *n, int just_use, int *only_need); #ifdef MZ_USE_SINGLE_FLOATS -float scheme_bignum_to_float_inf_info(const Scheme_Object *n, int just_use, int *only_need); +XFORM_NONGCING float scheme_bignum_to_float_inf_info(const Scheme_Object *n, int just_use, int *only_need); #else # define scheme_bignum_to_float_inf_info scheme_bignum_to_double_inf_info #endif @@ -1303,11 +1303,11 @@ typedef struct { typedef Scheme_Rational Small_Rational; -Scheme_Object *scheme_make_small_rational(long n, Small_Rational *space); -Scheme_Object *scheme_make_small_bn_rational(Scheme_Object *n, Small_Rational *space); +XFORM_NONGCING Scheme_Object *scheme_make_small_rational(long n, Small_Rational *space); +XFORM_NONGCING Scheme_Object *scheme_make_small_bn_rational(Scheme_Object *n, Small_Rational *space); Scheme_Object *scheme_integer_to_rational(const Scheme_Object *n); Scheme_Object *scheme_make_fixnum_rational(long n, long d); -int scheme_rational_eq(const Scheme_Object *a, const Scheme_Object *b); +XFORM_NONGCING int scheme_rational_eq(const Scheme_Object *a, const Scheme_Object *b); int scheme_rational_lt(const Scheme_Object *a, const Scheme_Object *b); int scheme_rational_gt(const Scheme_Object *a, const Scheme_Object *b); int scheme_rational_le(const Scheme_Object *a, const Scheme_Object *b); @@ -1322,7 +1322,7 @@ Scheme_Object *scheme_rational_max(const Scheme_Object *a, const Scheme_Object * Scheme_Object *scheme_rational_min(const Scheme_Object *a, const Scheme_Object *b); Scheme_Object *scheme_rational_divide(const Scheme_Object *n, const Scheme_Object *d); Scheme_Object *scheme_rational_power(const Scheme_Object *a, const Scheme_Object *b); -int scheme_is_rational_positive(const Scheme_Object *o); +XFORM_NONGCING int scheme_is_rational_positive(const Scheme_Object *o); Scheme_Object *scheme_rational_floor(const Scheme_Object *a); Scheme_Object *scheme_rational_truncate(const Scheme_Object *a); Scheme_Object *scheme_rational_ceiling(const Scheme_Object *a); @@ -1354,7 +1354,7 @@ Scheme_Object *scheme_complex_multiply(const Scheme_Object *a, const Scheme_Obje Scheme_Object *scheme_complex_divide(const Scheme_Object *n, const Scheme_Object *d); Scheme_Object *scheme_complex_power(const Scheme_Object *a, const Scheme_Object *b); Scheme_Object *scheme_complex_sqrt(const Scheme_Object *a); -int scheme_is_complex_exact(const Scheme_Object *o); +XFORM_NONGCING int scheme_is_complex_exact(const Scheme_Object *o); /****** Inexacts ******/ @@ -1368,7 +1368,7 @@ int scheme_check_float(const char *where, float v, const char *dest); #endif double scheme_get_val_as_double(const Scheme_Object *n); -int scheme_minus_zero_p(double d); +XFORM_NONGCING int scheme_minus_zero_p(double d); #ifdef MZ_USE_SINGLE_FLOATS float scheme_get_val_as_float(const Scheme_Object *n); @@ -1483,10 +1483,10 @@ Scheme_Object *scheme_exact_to_inexact(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_inexact_p(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_TO_DOUBLE(const Scheme_Object *n); Scheme_Object *scheme_to_bignum(const Scheme_Object *o); -int scheme_is_integer(const Scheme_Object *o); -Scheme_Object *scheme_zero_p(int argc, Scheme_Object *argv[]); -Scheme_Object *scheme_negative_p(int argc, Scheme_Object *argv[]); -Scheme_Object *scheme_positive_p(int argc, Scheme_Object *argv[]); +XFORM_NONGCING int scheme_is_integer(const Scheme_Object *o); +XFORM_NONGCING int scheme_is_zero(const Scheme_Object *o); +XFORM_NONGCING int scheme_is_negative(const Scheme_Object *o); +XFORM_NONGCING int scheme_is_positive(const Scheme_Object *o); Scheme_Object *scheme_make_polar(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_bitwise_shift(int argc, Scheme_Object *argv[]);