static Scheme_Object *
minus (int argc, Scheme_Object *argv[])
{
Scheme_Object *ret, *v;
ret = argv[0];
if (!SCHEME_NUMBERP(ret)) {
scheme_wrong_contract("-", "number?", 0, argc, argv);
ESCAPED_BEFORE_HERE;
}
if (argc == 1) {
if (SCHEME_FLOATP(ret)) {
#ifdef MZ_USE_SINGLE_FLOATS
if (SCHEME_FLTP(ret))
return scheme_make_float(-SCHEME_FLT_VAL(ret));
#endif
return scheme_make_double(-SCHEME_DBL_VAL(ret));
}
return scheme_bin_minus(zeroi, ret);
}
if (argc == 2) {
v = argv[1];
if (!SCHEME_NUMBERP(v)) {
scheme_wrong_contract("-", "number?", 1, argc, argv);
ESCAPED_BEFORE_HERE;
}
return scheme_bin_minus(ret, v);
}
return minus_slow(ret, argc, argv);
}
Scheme_Object *scheme_complex_sqrt(const Scheme_Object *o)
{
Scheme_Complex *c = (Scheme_Complex *)o;
Scheme_Object *r, *i, *ssq, *srssq, *nrsq, *prsq, *nr, *ni;
r = c->r;
i = c->i;
if (scheme_is_zero(i)) {
/* Special case for x+0.0i: */
r = scheme_sqrt(1, &r);
if (!SCHEME_COMPLEXP(r))
return scheme_make_complex(r, i);
else {
c = (Scheme_Complex *)r;
if (SAME_OBJ(c->r, zero)) {
/* need an inexact-zero real part: */
#ifdef MZ_USE_SINGLE_FLOATS
if (SCHEME_FLTP(c->i))
r = scheme_make_float(0.0);
else
#endif
r = scheme_make_double(0.0);
return scheme_make_complex(r, c->i);
} else
return r;
}
}
ssq = scheme_bin_plus(scheme_bin_mult(r, r),
scheme_bin_mult(i, i));
srssq = scheme_sqrt(1, &ssq);
if (SCHEME_FLOATP(srssq)) {
/* We may have lost too much precision, if i << r. The result is
going to be inexact, anyway, so switch to using expt. */
Scheme_Object *a[2];
a[0] = (Scheme_Object *)o;
a[1] = scheme_make_double(0.5);
return scheme_expt(2, a);
}
nrsq = scheme_bin_div(scheme_bin_minus(srssq, r),
scheme_make_integer(2));
nr = scheme_sqrt(1, &nrsq);
if (scheme_is_negative(i))
nr = scheme_bin_minus(zero, nr);
prsq = scheme_bin_div(scheme_bin_plus(srssq, r),
scheme_make_integer(2));
ni = scheme_sqrt(1, &prsq);
return scheme_make_complex(ni, nr);
}
Scheme_Object *scheme_complex_power(const Scheme_Object *base, const Scheme_Object *exponent)
{
Scheme_Complex *cb = (Scheme_Complex *)base;
Scheme_Complex *ce = (Scheme_Complex *)exponent;
double a, b, c, d, bm, ba, nm, na, r1, r2;
int d_is_zero;
if ((ce->i == zero) && !SCHEME_FLOATP(ce->r)) {
if (SCHEME_INTP(ce->r) || SCHEME_BIGNUMP(ce->r))
return scheme_generic_integer_power(base, ce->r);
}
a = scheme_get_val_as_double(cb->r);
b = scheme_get_val_as_double(cb->i);
c = scheme_get_val_as_double(ce->r);
d = scheme_get_val_as_double(ce->i);
d_is_zero = (ce->i == zero);
bm = sqrt(a * a + b * b);
ba = atan2(b, a);
/* New mag & angle */
nm = scheme_double_expt(bm, c) * exp(-(ba * d));
if (d_is_zero) /* precision here can avoid NaNs */
na = ba * c;
else
na = log(bm) * d + ba * c;
r1 = nm * cos(na);
r2 = nm * sin(na);
#ifdef MZ_USE_SINGLE_FLOATS
/* Coerce to double or float? */
#ifdef USE_SINGLE_FLOATS_AS_DEFAULT
if (!SCHEME_DBLP(cb->r) && !SCHEME_DBLP(cb->i)
&& !SCHEME_DBLP(ce->r) && !SCHEME_DBLP(ce->i))
#else
if (SCHEME_FLTP(cb->r) && SCHEME_FLTP(cb->i)
&& SCHEME_FLTP(ce->r) && SCHEME_FLTP(ce->i))
#endif
return scheme_make_complex(scheme_make_float((float)r1),
scheme_make_float((float)r2));
#endif
return scheme_make_complex(scheme_make_double(r1),
scheme_make_double(r2));
}
static Scheme_Object *
rem_mod (int argc, Scheme_Object *argv[], char *name, int first_sign)
{
Scheme_Object *n1, *n2, *r;
int negate;
n1 = argv[0];
n2 = argv[1];
if (!scheme_is_integer(n1))
scheme_wrong_contract(name, "integer?", 0, argc, argv);
if (!scheme_is_integer(n2))
scheme_wrong_contract(name, "integer?", 1, argc, argv);
if (SCHEME_INTP(n2) && !SCHEME_INT_VAL(n2))
scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
"%s: undefined for 0", name);
if (
#ifdef MZ_USE_SINGLE_FLOATS
(SCHEME_FLTP(n2) && (SCHEME_FLT_VAL(n2) == 0.0f)) ||
#endif
(SCHEME_DBLP(n2) && (SCHEME_DBL_VAL(n2) == 0.0))) {
int neg;
neg = scheme_minus_zero_p(SCHEME_FLOAT_VAL(n2));
scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
"%s: undefined for %s0.0",
name,
neg ? "-" : "");
}
if (SCHEME_INTP(n1) && !SCHEME_INT_VAL(n1))
return zeroi;
if (SCHEME_INTP(n1) && SCHEME_INTP(n2)) {
intptr_t a, b, na, nb, v;
int neg1, neg2;
a = SCHEME_INT_VAL(n1);
b = SCHEME_INT_VAL(n2);
na = (a < 0) ? -a : a;
nb = (b < 0) ? -b : b;
v = na % nb;
if (v) {
if (first_sign) {
if (a < 0)
v = -v;
} else {
neg1 = (a < 0);
neg2 = (b < 0);
if (neg1 != neg2)
v = nb - v;
if (neg2)
v = -v;
}
}
return scheme_make_integer(v);
}
if (SCHEME_FLOATP(n1) || SCHEME_FLOATP(n2)) {
double a, b, na, nb, v;
#ifdef MZ_USE_SINGLE_FLOATS
int was_single = !(SCHEME_DBLP(n1) || SCHEME_DBLP(n2));
#endif
if (SCHEME_INTP(n1))
a = SCHEME_INT_VAL(n1);
#ifdef MZ_USE_SINGLE_FLOATS
else if (SCHEME_FLTP(n1))
a = SCHEME_FLT_VAL(n1);
#endif
else if (SCHEME_DBLP(n1))
a = SCHEME_DBL_VAL(n1);
else
a = scheme_bignum_to_double(n1);
if (SCHEME_INTP(n2))
b = SCHEME_INT_VAL(n2);
#ifdef MZ_USE_SINGLE_FLOATS
else if (SCHEME_FLTP(n2))
b = SCHEME_FLT_VAL(n2);
#endif
else if (SCHEME_DBLP(n2))
b = SCHEME_DBL_VAL(n2);
else
b = scheme_bignum_to_double(n2);
if (a == 0.0) {
/* Avoid sign problems. */
#ifdef MZ_USE_SINGLE_FLOATS
if (was_single)
return scheme_zerof;
#endif
return scheme_zerod;
}
na = (a < 0) ? -a : a;
nb = (b < 0) ? -b : b;
if (MZ_IS_POS_INFINITY(nb))
v = na;
else if (MZ_IS_POS_INFINITY(na)) {
#ifdef MZ_USE_SINGLE_FLOATS
if (was_single)
return scheme_zerof;
#endif
return scheme_zerod;
} else {
v = fmod(na, nb);
#ifdef FMOD_CAN_RETURN_NEG_ZERO
if (v == 0.0)
v = 0.0;
#endif
}
if (v) {
if (first_sign) {
/* remainder */
if (a < 0)
v = -v;
} else {
/* modulo */
int neg1, neg2;
neg1 = (a < 0);
neg2 = (b < 0);
if (neg1 != neg2)
v = nb - v;
if (neg2)
v = -v;
}
}
#ifdef MZ_USE_SINGLE_FLOATS
if (was_single)
return scheme_make_float((float)v);
#endif
return scheme_make_double(v);
}
n1 = scheme_to_bignum(n1);
n2 = scheme_to_bignum(n2);
scheme_bignum_divide(n1, n2, NULL, &r, 1);
negate = 0;
if (!SCHEME_INTP(r) || SCHEME_INT_VAL(r)) {
/* Easier if we can assume 'r' is positive: */
if (SCHEME_INTP(r)) {
if (SCHEME_INT_VAL(r) < 0)
r = scheme_make_integer(-SCHEME_INT_VAL(r));
} else if (!SCHEME_BIGPOS(r))
r = scheme_bignum_negate(r);
if (first_sign) {
if (!SCHEME_BIGPOS(n1))
negate = 1;
} else {
int neg1, neg2;
neg1 = !SCHEME_BIGPOS(n1);
neg2 = !SCHEME_BIGPOS(n2);
if (neg1 != neg2) {
if (neg2)
r = scheme_bin_plus(n2, r);
else
r = scheme_bin_minus(n2, r);
} else if (neg2)
negate = 1;
}
if (negate) {
if (SCHEME_INTP(r))
r = scheme_make_integer(-SCHEME_INT_VAL(r));
else
r = scheme_bignum_negate(r);
}
}
return r;
}
int scheme_is_complex_exact(const Scheme_Object *o)
{
Scheme_Complex *c = (Scheme_Complex *)o;
return !SCHEME_FLOATP(c->r) && !SCHEME_FLOATP(c->i);
}
Scheme_Object *scheme_complex_divide(const Scheme_Object *_n, const Scheme_Object *_d)
{
Scheme_Complex *cn = (Scheme_Complex *)_n;
Scheme_Complex *cd = (Scheme_Complex *)_d;
Scheme_Object *den, *r, *i, *a, *b, *c, *d, *cm, *dm, *aa[1];
int swap;
if ((cn->r == zero) && (cn->i == zero))
return zero;
a = cn->r;
b = cn->i;
c = cd->r;
d = cd->i;
/* Check for exact-zero simplifications in d: */
if (c == zero) {
i = scheme_bin_minus(zero, scheme_bin_div(a, d));
r = scheme_bin_div(b, d);
return scheme_make_complex(r, i);
} else if (d == zero) {
r = scheme_bin_div(a, c);
i = scheme_bin_div(b, c);
return scheme_make_complex(r, i);
}
if (!SCHEME_FLOATP(c) && !SCHEME_FLOATP(d)) {
/* The simple way: */
cm = scheme_bin_plus(scheme_bin_mult(c, c),
scheme_bin_mult(d, d));
r = scheme_bin_div(scheme_bin_plus(scheme_bin_mult(c, a),
scheme_bin_mult(d, b)),
cm);
i = scheme_bin_div(scheme_bin_minus(scheme_bin_mult(c, b),
scheme_bin_mult(d, a)),
cm);
return scheme_make_complex(r, i);
}
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),
/* Either 0.0 or +nan.0: */
scheme_bin_mult(d, b));
i = scheme_bin_minus(scheme_bin_div(b, c),
/* Either 0.0 or +nan.0: */
scheme_bin_mult(d, a));
return scheme_make_complex(r, i);
}
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));
i = scheme_bin_minus(scheme_bin_mult(c, b), /* either 0.0 or +nan.0 */
scheme_bin_div(a, d));
return scheme_make_complex(r, i);
}
aa[0] = c;
cm = scheme_abs(1, aa);
aa[0] = d;
dm = scheme_abs(1, aa);
if (scheme_bin_lt(cm, dm)) {
cm = a;
a = b;
b = cm;
cm = c;
c = d;
d = cm;
swap = 1;
} else
swap = 0;
r = scheme_bin_div(c, d);
den = scheme_bin_plus(d, scheme_bin_mult(c, r));
if (swap)
i = scheme_bin_div(scheme_bin_minus(a, scheme_bin_mult(b, r)), den);
else
i = scheme_bin_div(scheme_bin_minus(scheme_bin_mult(b, r), a), den);
r = scheme_bin_div(scheme_bin_plus(b, scheme_bin_mult(a, r)), den);
return scheme_make_complex(r, i);
}
