suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

reduce 3m overhead for many arithmetic primitives

Browse Source 
svn: r5455
This commit is contained in:
Matthew Flatt 2007-01-25 06:22:16 +00:00
parent e7cc73c1cf
commit 13e5b1198a
13 changed files with 446 additions and 322 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/mzscheme/src/bignum.c
View File

@ -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);

114
src/mzscheme/src/bool.c
View File

@ -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)

6
src/mzscheme/src/complex.c
View File

@ -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));

2
src/mzscheme/src/gmp/gmp.h
View File

@ -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)

57
src/mzscheme/src/number.c
View File

@ -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);

117
src/mzscheme/src/numcomp.c
View File

@ -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)

360
src/mzscheme/src/nummacs.h
View File

@ -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) \

6
src/mzscheme/src/numstr.c
View File

@ -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",

2
src/mzscheme/src/portfun.c
View File

@ -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

28
src/mzscheme/src/rational.c
View File

@ -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)

24
src/mzscheme/src/schemef.h
View File

@ -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

4
src/mzscheme/src/schemex.h
View File

@ -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 */
/*========================================================================*/

44
src/mzscheme/src/schpriv.h
View File

@ -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[]);