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; }
/** * 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
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_rational_sqrt(const Scheme_Object *o) { Scheme_Rational *r = (Scheme_Rational *)o; Scheme_Object *n, *d; double v; n = scheme_integer_sqrt(r->num); if (!SCHEME_DBLP(n)) { d = scheme_integer_sqrt(r->denom); if (!SCHEME_DBLP(d)) return make_rational(n, d, 0); } v = sqrt(scheme_rational_to_double(o)); #ifdef USE_SINGLE_FLOATS_AS_DEFAULT return scheme_make_float(v); #else return scheme_make_double(v); #endif }
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; }
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); }
/** * 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