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;
}
