Scheme_Object *scheme_complex_normalize(const Scheme_Object *o)
{
Scheme_Complex *c = (Scheme_Complex *)o;
if (c->i == zero)
return c->r;
if (c->r == zero) {
/* No coercions */
return (Scheme_Object *)c;
}
/* Coercions: Exact -> float -> double
If the complex contains a float and an exact, we coerce the exact
to a float, etc. */
#ifdef MZ_USE_SINGLE_FLOATS
if (SCHEME_FLTP(c->i)) {
if (!SCHEME_FLTP(c->r)) {
Scheme_Object *v;
if (SCHEME_DBLP(c->r)) {
v = scheme_make_double(SCHEME_FLT_VAL(c->i));
c->i = v;
} else {
v = scheme_make_float(scheme_get_val_as_float(c->r));
c->r = v;
}
}
} else if (SCHEME_FLTP(c->r)) {
Scheme_Object *v;
/* Imag part can't be a float, or we'd be in the previous case */
if (SCHEME_DBLP(c->i)) {
v = scheme_make_double(SCHEME_FLT_VAL(c->r));
c->r = v;
} else {
v = scheme_make_float(scheme_get_val_as_float(c->i));
c->i = v;
}
} else
#endif
if (SCHEME_DBLP(c->i)) {
if (!SCHEME_DBLP(c->r)) {
Scheme_Object *r;
r = scheme_make_double(scheme_get_val_as_double(c->r));
c->r = r;
}
} else if (SCHEME_DBLP(c->r)) {
Scheme_Object *i;
i = scheme_make_double(scheme_get_val_as_double(c->i));
c->i = i;
}
return (Scheme_Object *)c;
}
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_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));
}
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);
}
/**
* Convert a Scheme object to a GVariant that will serve as one of
* the parameters of a call go g_dbus_proxy_call_.... Returns NULL
* if it is unable to do the conversion.
*/
static GVariant *
scheme_object_to_parameter (Scheme_Object *obj, gchar *type)
{
gchar *str; // A temporary string
switch (type[0])
{
// Arrays
case 'a':
return scheme_object_to_array (obj, type);
// Doubles
case 'd':
if (SCHEME_DBLP (obj))
return g_variant_new ("d", SCHEME_DBL_VAL (obj));
else if (SCHEME_FLTP (obj))
return g_variant_new ("d", (double) SCHEME_FLT_VAL (obj));
else if (SCHEME_INTP (obj))
return g_variant_new ("d", (double) SCHEME_INT_VAL (obj));
else
return NULL;
// 32 bit integers
case 'i':
if (SCHEME_INTP (obj))
return g_variant_new ("i", (int) SCHEME_INT_VAL (obj));
else if (SCHEME_DBLP (obj))
return g_variant_new ("i", (int) SCHEME_DBL_VAL (obj));
else
return NULL;
// Strings
case 's':
str = scheme_object_to_string (obj);
if (str == NULL)
return NULL;
return g_variant_new ("s", str);
// 32 bit unsigned integers
case 'u':
if (SCHEME_INTP (obj))
return g_variant_new ("u", (unsigned int) SCHEME_INT_VAL (obj));
else
return NULL;
// Everything else is currently unsupported
default:
return NULL;
} // switch
} // scheme_object_to_parameter
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;
}
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;
}
/**
* Convert a Scheme object to a GVariant that will serve as one of
* the parameters of a call go g_dbus_proxy_call_.... Returns NULL
* if it is unable to do the conversion.
*/
static GVariant *
scheme_object_to_parameter (Scheme_Object *obj, gchar *type)
{
gchar *str; // A temporary string
// Special case: Array of bytes
if (g_strcmp0 (type, "ay") == 0)
{
if (SCHEME_BYTE_STRINGP (obj))
{
return g_variant_new_fixed_array (G_VARIANT_TYPE_BYTE,
SCHEME_BYTE_STR_VAL (obj),
SCHEME_BYTE_STRLEN_VAL (obj),
sizeof (guchar));
} // if it's a byte string
} // array of bytes
// Handle normal cases
switch (type[0])
{
// Arrays
case 'a':
return scheme_object_to_array (obj, type);
// Doubles
case 'd':
if (SCHEME_DBLP (obj))
return g_variant_new ("d", SCHEME_DBL_VAL (obj));
else if (SCHEME_FLTP (obj))
return g_variant_new ("d", (double) SCHEME_FLT_VAL (obj));
else if (SCHEME_INTP (obj))
return g_variant_new ("d", (double) SCHEME_INT_VAL (obj));
else if (SCHEME_RATIONALP (obj))
return g_variant_new ("d", (double) scheme_rational_to_double (obj));
else
return NULL;
// 32 bit integers
case 'i':
if (SCHEME_INTP (obj))
return g_variant_new ("i", (int) SCHEME_INT_VAL (obj));
else if (SCHEME_DBLP (obj))
return g_variant_new ("i", (int) SCHEME_DBL_VAL (obj));
else if (SCHEME_FLTP (obj))
return g_variant_new ("i", (int) SCHEME_FLT_VAL (obj));
else if (SCHEME_RATIONALP (obj))
return g_variant_new ("i", (int) scheme_rational_to_double (obj));
else
return NULL;
// Strings
case 's':
str = scheme_object_to_string (obj);
if (str == NULL)
return NULL;
return g_variant_new ("s", str);
// 32 bit unsigned integers
case 'u':
if (SCHEME_INTP (obj))
return g_variant_new ("u", (unsigned int) SCHEME_INT_VAL (obj));
else
return NULL;
// Everything else is currently unsupported
default:
return NULL;
} // switch
} // scheme_object_to_parameter
