Scheme_Object *scheme_rational_add(const Scheme_Object *a, const Scheme_Object *b) { Scheme_Rational *ra = (Scheme_Rational *)a; Scheme_Rational *rb = (Scheme_Rational *)b; Scheme_Object *ac, *bd, *sum, *cd; int no_normalize = 0; if (SCHEME_INTP(ra->denom) && (SCHEME_INT_VAL(ra->denom) == 1)) { /* Swap, to take advantage of the next optimization */ Scheme_Rational *rx = ra; ra = rb; rb = rx; } if (SCHEME_INTP(rb->denom) && (SCHEME_INT_VAL(rb->denom) == 1)) { /* From Brad Lucier: */ /* (+ p/q n) = (make-rational (+ p (* n q)) q), no normalize */ ac = ra->num; cd = ra->denom; no_normalize = 1; } else { ac = scheme_bin_mult(ra->num, rb->denom); cd = scheme_bin_mult(ra->denom, rb->denom); } bd = scheme_bin_mult(ra->denom, rb->num); sum = scheme_bin_plus(ac, bd); if (no_normalize) return make_rational(sum, cd, 0); else return scheme_make_rational(sum, cd); }
int scheme_rational_eq(const Scheme_Object *a, const Scheme_Object *b) { Scheme_Rational *ra = (Scheme_Rational *)a; Scheme_Rational *rb = (Scheme_Rational *)b; if (SCHEME_INTP(ra->num) && SCHEME_INTP(rb->num)) { if (ra->num != rb->num) return 0; } else if (SCHEME_BIGNUMP(ra->num) && SCHEME_BIGNUMP(rb->num)) { if (!scheme_bignum_eq(ra->num, rb->num)) return 0; } else return 0; if (SCHEME_INTP(ra->denom) && SCHEME_INTP(rb->denom)) { if (ra->denom != rb->denom) return 0; } else if (SCHEME_BIGNUMP(ra->denom) && SCHEME_BIGNUMP(rb->denom)) { if (!scheme_bignum_eq(ra->denom, rb->denom)) return 0; } else return 0; return 1; }
static Scheme_Object *fx_abs(int argc, Scheme_Object *argv[]) { Scheme_Object *o; if (!SCHEME_INTP(argv[0])) scheme_wrong_contract("fxabs", "fixnum?", 0, argc, argv); o = scheme_abs(argc, argv); if (!SCHEME_INTP(o)) scheme_non_fixnum_result("fxabs", o); return o; }
/** * 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_rational_normalize(const Scheme_Object *o) { Scheme_Rational *r = (Scheme_Rational *)o; Scheme_Object *gcd, *tmpn; int negate = 0; if (r->num == scheme_exact_zero) return scheme_make_integer(0); if (SCHEME_INTP(r->denom)) { if (SCHEME_INT_VAL(r->denom) < 0) { tmpn = scheme_make_integer_value(-SCHEME_INT_VAL(r->denom)); r->denom = tmpn; negate = 1; } } else if (!SCHEME_BIGPOS(r->denom)) { tmpn = scheme_bignum_negate(r->denom); r->denom = tmpn; negate = 1; } if (negate) { if (SCHEME_INTP(r->num)) { tmpn = scheme_make_integer_value(-SCHEME_INT_VAL(r->num)); r->num = tmpn; } else { tmpn = scheme_bignum_negate(r->num); r->num = tmpn; } } if (r->denom == one) return r->num; gcd = scheme_bin_gcd(r->num, r->denom); if (gcd == one) return (Scheme_Object *)o; tmpn = scheme_bin_quotient(r->num, gcd); r->num = tmpn; tmpn = scheme_bin_quotient(r->denom, gcd); r->denom = tmpn; if (r->denom == one) return r->num; return (Scheme_Object *)r; }
static Scheme_Object *negate_simple(Scheme_Object *v) { if (SCHEME_INTP(v)) return scheme_make_integer_value(-SCHEME_INT_VAL(v)); else return scheme_bignum_negate(v); }
Scheme_Object * scheme_sub1 (int argc, Scheme_Object *argv[]) { Scheme_Type t; Scheme_Object *o = argv[0]; if (SCHEME_INTP(o)) { intptr_t v; v = SCHEME_INT_VAL(o); if (v > -(0x3FFFFFFF)) return scheme_make_integer(SCHEME_INT_VAL(o) - 1); else { Small_Bignum b; return scheme_bignum_sub1(scheme_make_small_bignum(v, &b)); } } t = _SCHEME_TYPE(o); #ifdef MZ_USE_SINGLE_FLOATS if (t == scheme_float_type) return scheme_make_float(SCHEME_FLT_VAL(o) - 1.0f); #endif if (t == scheme_double_type) return scheme_make_double(SCHEME_DBL_VAL(o) - 1.0); if (t == scheme_bignum_type) return scheme_bignum_sub1(o); if (t == scheme_rational_type) return scheme_rational_sub1(o); if (t == scheme_complex_type) return scheme_complex_sub1(o); NEED_NUMBER(sub1); ESCAPED_BEFORE_HERE; }
Scheme_Object *scheme_places_deep_copy(Scheme_Object *so) { #if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) Scheme_Object *new_so = so; if (SCHEME_INTP(so)) { return so; } switch (so->type) { case scheme_pair_type: case scheme_vector_type: case scheme_struct_type_type: case scheme_structure_type: { Scheme_Hash_Table *ht; ht = scheme_make_hash_table(SCHEME_hash_ptr); new_so = scheme_places_deep_copy_worker(so, ht); } break; default: new_so = scheme_places_deep_copy_worker(so, NULL); break; } return new_so; #else return so; #endif }
Scheme_Object * scheme_abs(int argc, Scheme_Object *argv[]) { Scheme_Type t; Scheme_Object *o; o = argv[0]; if (SCHEME_INTP(o)) { intptr_t n = SCHEME_INT_VAL(o); return scheme_make_integer_value(ABS(n)); } t = _SCHEME_TYPE(o); #ifdef MZ_USE_SINGLE_FLOATS if (t == scheme_float_type) return scheme_make_float(fabs(SCHEME_FLT_VAL(o))); #endif if (t == scheme_double_type) return scheme_make_double(fabs(SCHEME_DBL_VAL(o))); if (t == scheme_bignum_type) { if (SCHEME_BIGPOS(o)) return o; return scheme_bignum_negate(o); } if (t == scheme_rational_type) { if (scheme_is_rational_positive(o)) return o; else return scheme_rational_negate(o); } NEED_REAL(abs); ESCAPED_BEFORE_HERE; }
static Scheme_Object * integer_to_char (int argc, Scheme_Object *argv[]) { if (SCHEME_INTP(argv[0])) { intptr_t v; v = SCHEME_INT_VAL(argv[0]); if ((v >= 0) && (v <= 0x10FFFF) && ((v < 0xD800) || (v > 0xDFFF))) return _scheme_make_char((int)v); } else if (SCHEME_BIGNUMP(argv[0]) && SCHEME_BIGPOS(argv[0])) { /* On 32-bit machines, there's still a chance... */ intptr_t y; if (scheme_get_int_val(argv[0], &y)) { if (y <= 0x10FFFF) return _scheme_make_char((int)y); } } scheme_wrong_contract("integer->char", "(and/c (integer-in 0 #x10FFFF) (not/c (integer-in #xD800 #xDFFF)))", 0, argc, argv); return NULL; }
Scheme_Object * irgb_new (int argc, Scheme_Object **argv) { if (! SCHEME_INTP (argv[0])) scheme_wrong_type ("irgb-red", "integer", 0, 3, argv); if (! SCHEME_INTP (argv[1])) scheme_wrong_type ("irgb-red", "integer", 1, 3, argv); if (! SCHEME_INTP (argv[2])) scheme_wrong_type ("irgb-red", "integer", 2, 3, argv); int r = byte (SCHEME_INT_VAL (argv[0])); int g = byte (SCHEME_INT_VAL (argv[1])); int b = byte (SCHEME_INT_VAL (argv[2])); return scheme_make_integer ((r << 16) | (g << 8) | b); } // irgb_new
int scheme_is_zero(const Scheme_Object *o) { Scheme_Type t; if (SCHEME_INTP(o)) return o == zeroi; t = _SCHEME_TYPE(o); #ifdef MZ_USE_SINGLE_FLOATS if (t == scheme_float_type) { # ifdef NAN_EQUALS_ANYTHING if (MZ_IS_NAN(SCHEME_FLT_VAL(o))) return 0; # endif return SCHEME_FLT_VAL(o) == 0.0f; } #endif if (t == scheme_double_type) { #ifdef NAN_EQUALS_ANYTHING if (MZ_IS_NAN(SCHEME_DBL_VAL(o))) return 0; #endif return SCHEME_DBL_VAL(o) == 0.0; } if (t == scheme_complex_type) { if (scheme_is_zero(scheme_complex_imaginary_part(o))) return scheme_is_zero(scheme_complex_real_part(o)); return 0; } if ((t >= scheme_bignum_type) && (t <= scheme_complex_type)) return 0; return -1; }
static Scheme_Object * integer_to_char (int argc, Scheme_Object *argv[]) { if (SCHEME_INTP(argv[0])) { long v; v = SCHEME_INT_VAL(argv[0]); if ((v >= 0) && (v <= 0x10FFFF) && ((v < 0xD800) || (v > 0xDFFF))) return _scheme_make_char(v); } else if (SCHEME_BIGNUMP(argv[0]) && SCHEME_BIGPOS(argv[0])) { /* On 32-bit machines, there's still a chance... */ long y; if (scheme_get_int_val(argv[0], &y)) { if (y <= 0x10FFFF) return _scheme_make_char(y); } } scheme_wrong_type("integer->char", "exact integer in [0,#x10FFFF], not in [#xD800,#xDFFF]", 0, argc, argv); return NULL; }
Scheme_Object * irgb_blue (int argc, Scheme_Object **argv) { if (! SCHEME_INTP (argv[0])) scheme_wrong_type ("irgb-blue", "integer", 0, 1, argv); int color = SCHEME_INT_VAL (argv[0]); return scheme_make_integer (color & 255); } // irgb_blue
Scheme_Object * irgb_red (int argc, Scheme_Object **argv) { if (! SCHEME_INTP (argv[0])) scheme_wrong_type ("irgb-red", "integer", 1, 1, argv); int color = SCHEME_INT_VAL (argv[0]); return scheme_make_integer ((color >> 16) & 255); } // irgb_red
int scheme_is_rational_positive(const Scheme_Object *o) { Scheme_Rational *r = (Scheme_Rational *)o; if (SCHEME_INTP(r->num)) return (SCHEME_INT_VAL(r->num) > 0); else return SCHEME_BIGPOS(r->num); }
Scheme_Object *scheme_rational_divide(const Scheme_Object *n, const Scheme_Object *d) { Scheme_Rational *rd = (Scheme_Rational *)d, *rn = (Scheme_Rational *)n; Scheme_Rational d_inv; /* Check for [negative] inverse, which is easy */ if ((SCHEME_INTP(rn->num) && ((SCHEME_INT_VAL(rn->num) == 1) || (SCHEME_INT_VAL(rn->num) == -1))) && (SCHEME_INTP(rn->denom) && SCHEME_INT_VAL(rn->denom) == 1)) { int negate = (SCHEME_INT_VAL(rn->num) == -1); if (SCHEME_INTP(rd->num)) { if ((SCHEME_INT_VAL(rd->num) == 1)) { if (negate) return negate_simple(rd->denom); else return rd->denom; } if (SCHEME_INT_VAL(rd->num) == -1) { if (negate) return rd->denom; else return negate_simple(rd->denom); } } if (((SCHEME_INTP(rd->num)) && (SCHEME_INT_VAL(rd->num) < 0)) || (!SCHEME_INTP(rd->num) && !SCHEME_BIGPOS(rd->num))) { Scheme_Object *v; v = negate ? rd->denom : negate_simple(rd->denom); return make_rational(v, negate_simple(rd->num), 0); } else { Scheme_Object *v; v = negate ? negate_simple(rd->denom) : rd->denom; return make_rational(v, rd->num, 0); } } d_inv.so.type = scheme_rational_type; d_inv.denom = rd->num; d_inv.num = rd->denom; return scheme_rational_multiply(n, (Scheme_Object *)&d_inv); }
Scheme_Object *scheme_rational_round(const Scheme_Object *o) { Scheme_Rational *r = (Scheme_Rational *)o; Scheme_Object *q, *qd, *delta, *half; int more = 0, can_eq_half, negative; negative = !scheme_is_rational_positive(o); q = scheme_bin_quotient(r->num, r->denom); /* Get remainder absolute value: */ qd = scheme_bin_mult(q, r->denom); if (negative) delta = scheme_bin_minus(qd, r->num); else delta = scheme_bin_minus(r->num, qd); half = scheme_bin_quotient(r->denom, scheme_make_integer(2)); can_eq_half = SCHEME_FALSEP(scheme_odd_p(1, &r->denom)); if (SCHEME_INTP(half) && SCHEME_INTP(delta)) { if (can_eq_half && (SCHEME_INT_VAL(delta) == SCHEME_INT_VAL(half))) more = SCHEME_TRUEP(scheme_odd_p(1, &q)); else more = (SCHEME_INT_VAL(delta) > SCHEME_INT_VAL(half)); } else if (SCHEME_BIGNUMP(delta) && SCHEME_BIGNUMP(half)) { if (can_eq_half && (scheme_bignum_eq(delta, half))) more = SCHEME_TRUEP(scheme_odd_p(1, &q)); else more = !scheme_bignum_lt(delta, half); } else more = SCHEME_BIGNUMP(delta); if (more) { if (negative) q = scheme_sub1(1, &q); else q = scheme_add1(1, &q); } return q; }
static Scheme_Object *equal_hash_code(int argc, Scheme_Object *argv[]) { long v; if (SCHEME_INTP(argv[0])) return argv[0]; v = scheme_equal_hash_key(argv[0]); return scheme_make_integer(v); }
static void check_always_fixnum(const char *name, Scheme_Object *o) { if (SCHEME_INTP(o)) { intptr_t v = SCHEME_INT_VAL(o); if ((v < -1073741824) || (v > 1073741823)) { scheme_contract_error(name, "cannot fold to result that is not a fixnum on some platforms", "result", 1, o, NULL); } } }
static Scheme_Object *def_place_exit_handler_proc(int argc, Scheme_Object *argv[]) { intptr_t status; if (SCHEME_INTP(argv[0])) { status = SCHEME_INT_VAL(argv[0]); if (status < 1 || status > 255) status = 0; } else status = 0; mz_proc_thread_exit((void *) status); return scheme_void; /* Never get here */ }
static int check_home(Scheme_Object *o) { #ifdef MZ_PRECISE_GC return (SCHEME_INTP(o) || GC_is_tagged(o) || SAME_OBJ(o, scheme_true) || SAME_OBJ(o, scheme_false) || SAME_OBJ(o, scheme_null) || SAME_OBJ(o, scheme_eof) || SAME_OBJ(o, scheme_void)); #else /* GC_set(o) */ return 1; #endif }
static Scheme_Object *eq_hash_code(int argc, Scheme_Object *argv[]) { long v; if (SCHEME_INTP(argv[0])) return argv[0]; #ifdef MZ_PRECISE_GC v = scheme_hash_key(argv[0]); #else v = ((long)argv[0]) >> 2; #endif return scheme_make_integer(v); }
static Scheme_Object * immutablep (int argc, Scheme_Object *argv[]) { Scheme_Object *v = argv[0]; return ((!SCHEME_INTP(v) && SCHEME_IMMUTABLEP(v) && (SCHEME_PAIRP(v) || SCHEME_VECTORP(v) || SCHEME_BYTE_STRINGP(v) || SCHEME_CHAR_STRINGP(v) || SCHEME_BOXP(v))) ? scheme_true : scheme_false); }
static int rational_lt(const Scheme_Object *a, const Scheme_Object *b, int or_eq) { Scheme_Rational *ra = (Scheme_Rational *)a; Scheme_Rational *rb = (Scheme_Rational *)b; Scheme_Object *ma, *mb; ma = scheme_bin_mult(ra->num, rb->denom); mb = scheme_bin_mult(rb->num, ra->denom); if (SCHEME_INTP(ma) && SCHEME_INTP(mb)) { if (or_eq) return (SCHEME_INT_VAL(ma) <= SCHEME_INT_VAL(mb)); else return (SCHEME_INT_VAL(ma) < SCHEME_INT_VAL(mb)); } else if (SCHEME_BIGNUMP(ma) && SCHEME_BIGNUMP(mb)) { if (or_eq) return scheme_bignum_le(ma, mb); else return scheme_bignum_lt(ma, mb); } else if (SCHEME_BIGNUMP(mb)) { return SCHEME_BIGPOS(mb); } else return !SCHEME_BIGPOS(ma); }
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)); }
intptr_t scheme_get_semaphore_init(const char *who, int n, Scheme_Object **p) { intptr_t v; if (n) { if (!SCHEME_INTP(p[0])) { if (!SCHEME_BIGNUMP(p[0]) || !SCHEME_BIGPOS(p[0])) scheme_wrong_contract(who, "exact-nonnegative-integer?", 0, n, p); } if (!scheme_get_int_val(p[0], &v)) { scheme_raise_exn(MZEXN_FAIL, "%s: starting value %s is too large", who, scheme_make_provided_string(p[0], 0, NULL)); } else if (v < 0) scheme_wrong_contract(who, "exact-nonnegative-integer?", 0, n, p); } else v = 0; return v; }
Scheme_Hash_Table *force_hash(Scheme_Object *so) { if (SCHEME_INTP(so)) { return NULL; } switch (so->type) { case scheme_pair_type: case scheme_vector_type: case scheme_struct_type_type: case scheme_structure_type: { Scheme_Hash_Table *ht; ht = scheme_make_hash_table(SCHEME_hash_ptr); force_hash_worker(so, ht); return ht; } break; default: break; } return NULL; }
/** *Translating the scheme_object to gvariant type for the client *This step is used on sending input values onto the DBus */ GVariant * scheme_obj_to_gvariant (Scheme_Object *list) { GVariantBuilder *builder; GVariant *finalr; GVariant *rvalue = NULL; Scheme_Object *firstelement; int length = 0; gint32 i; char* rstring; double rdouble; builder = g_variant_builder_new(G_VARIANT_TYPE_TUPLE); length = scheme_list_length (list); // rvalue = g_new(GVariant *, length); if (length == 0) { // scheme_signal_error("length 0"); return rvalue ; } // if else{ while (length != 0) { // Get the first element of the argument firstelement = scheme_car (list); list = scheme_cdr(list); length = scheme_list_length(list); // checking the scheme_type to see whether it is an integer or not // Eventually see if we can convert this to a switch statement. if (SCHEME_INTP (firstelement)) { // we saved the return value at &i i = SCHEME_INT_VAL(firstelement); rvalue = g_variant_new ("i",i); g_variant_builder_add_value(builder,rvalue); // return rvalue; } // if it's an integer else if (SCHEME_BYTE_STRINGP (firstelement)|| SCHEME_CHAR_STRINGP(firstelement)) { //scheme_signal_error ("We are in Character"); //getting the string out of the scheme_object rstring = SCHEME_BYTE_STR_VAL(list); // we will convert it to g_variant rvalue = g_variant_new ("(&s)", rstring); g_variant_builder_add_value(builder, rvalue); } // if it's a character else if (SCHEME_TYPE (firstelement) == scheme_double_type) { //getting the double out of the scheme_object rdouble = scheme_real_to_double(list); // we will convert it to g_variant rvalue = g_variant_new_double(rdouble); g_variant_builder_add_value(builder, rvalue); } // if it's a double } // while loop finalr = g_variant_builder_end (builder); return finalr; } //else return finalr; } // scheme_obj_to_gvariant
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; }