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 *pos_sqrt(int argc, Scheme_Object **argv) { if (SCHEME_DBLP(argv[0]) && (SCHEME_DBL_VAL(argv[0]) < 0.0)) return scheme_nan_object; return scheme_sqrt(argc, argv); }