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);
}
static Scheme_Object *
div_prim (int argc, Scheme_Object *argv[])
{
Scheme_Object *ret;
int i;
ret = argv[0];
if (!SCHEME_NUMBERP(ret)) {
scheme_wrong_contract("/", "number?", 0, argc, argv);
ESCAPED_BEFORE_HERE;
}
if (argc == 1) {
if (ret != zeroi)
return scheme_bin_div(scheme_make_integer(1), ret);
else {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
"/: division by zero");
ESCAPED_BEFORE_HERE;
}
}
for (i = 1; i < argc; i++) {
Scheme_Object *o = argv[i];
if (!SCHEME_NUMBERP(o)) {
scheme_wrong_contract("/", "number?", i, argc, argv);
ESCAPED_BEFORE_HERE;
}
if (o != zeroi)
ret = scheme_bin_div(ret, o);
else {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
"/: division by zero");
ESCAPED_BEFORE_HERE;
}
}
return ret;
}
Scheme_Object *
do_bin_quotient(const char *name, const Scheme_Object *n1, const Scheme_Object *n2, Scheme_Object **bn_rem)
{
Scheme_Object *q;
if (!scheme_is_integer(n1)) {
Scheme_Object *a[2];
a[0] = (Scheme_Object *)n1;
a[1] = (Scheme_Object *)n2;
scheme_wrong_contract(name, "integer?", 0, 2, a);
}
if (!scheme_is_integer(n2)) {
Scheme_Object *a[2];
a[0] = (Scheme_Object *)n1;
a[1] = (Scheme_Object *)n2;
scheme_wrong_contract(name, "integer?", 1, 2, a);
}
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)))
scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
"%s: undefined for 0.0", name);
if (SCHEME_INTP(n1) && SCHEME_INTP(n2)) {
/* Beware that most negative fixnum divided by -1
isn't a fixnum: */
return (scheme_make_integer_value(SCHEME_INT_VAL(n1) / SCHEME_INT_VAL(n2)));
}
if (SCHEME_DBLP(n1) || SCHEME_DBLP(n2)) {
Scheme_Object *r;
double d, d2;
r = scheme_bin_div(n1, n2); /* could be exact 0 ... */
if (SCHEME_DBLP(r)) {
d = SCHEME_DBL_VAL(r);
if (d > 0)
d2 = floor(d);
else
d2 = ceil(d);
if (d2 == d)
return r;
else
return scheme_make_double(d2);
} else
return r;
}
#ifdef MZ_USE_SINGLE_FLOATS
if (SCHEME_FLTP(n1) || SCHEME_FLTP(n2)) {
Scheme_Object *r;
float d, d2;
r = scheme_bin_div(n1, n2); /* could be exact 0 ... */
if (SCHEME_FLTP(r)) {
d = SCHEME_FLT_VAL(r);
if (d > 0)
d2 = floor(d);
else
d2 = ceil(d);
if (d2 == d)
return r;
else
return scheme_make_float(d2);
} else
return r;
}
#endif
#if 0
/* I'm pretty sure this isn't needed, but I'm keeping the code just
in case... 03/19/2000 */
if (SCHEME_RATIONALP(n1))
wrong_contract(name, "integer?", n1);
if (SCHEME_RATIONALP(n2))
wrong_contract(name, "integer?", n2);
#endif
n1 = scheme_to_bignum(n1);
n2 = scheme_to_bignum(n2);
scheme_bignum_divide(n1, n2, &q, bn_rem, 1);
return q;
}
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);
}
