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);
}
static Scheme_Object *vector_copy_bang(int argc, Scheme_Object *argv[])
{
Scheme_Object *s1, *s2;
intptr_t istart, ifinish;
intptr_t ostart, ofinish;
int slow = 0;
s1 = argv[0];
if (SCHEME_NP_CHAPERONEP(s1)) {
slow = 1;
s1 = SCHEME_CHAPERONE_VAL(s1);
}
if (!SCHEME_MUTABLE_VECTORP(s1))
scheme_wrong_contract("vector-copy!", "(and/c vector? (not/c immutable?))", 0, argc, argv);
scheme_do_get_substring_indices("vector-copy!", s1,
argc, argv, 1, 5,
&ostart, &ofinish, SCHEME_VEC_SIZE(s1));
s2 = argv[2];
if (SCHEME_NP_CHAPERONEP(s2)) {
slow = 1;
s2 = SCHEME_CHAPERONE_VAL(s2);
}
if (!SCHEME_VECTORP(s2))
scheme_wrong_contract("vector-copy!", "vector?", 2, argc, argv);
scheme_do_get_substring_indices("vector-copy!", s2,
argc, argv, 3, 4,
&istart, &ifinish, SCHEME_VEC_SIZE(s2));
if ((ofinish - ostart) < (ifinish - istart)) {
scheme_contract_error("vector-copy!",
"not enough room in target vector",
"target vector", 1, argv[2],
"starting index", 1, scheme_make_integer(ostart),
"element count", 1, scheme_make_integer(ofinish - ostart),
NULL);
return NULL;
}
if (slow) {
int i, o;
for (i = istart, o = ostart; i < ifinish; i++, o++) {
scheme_chaperone_vector_set(argv[0], o, scheme_chaperone_vector_ref(argv[2], i));
}
} else {
memmove(SCHEME_VEC_ELS(s1) + ostart,
SCHEME_VEC_ELS(s2) + istart,
(ifinish - istart) * sizeof(Scheme_Object*));
}
return scheme_void;
}
Scheme_Object *
scheme_checked_vector_ref (int argc, Scheme_Object *argv[])
{
intptr_t i, len;
Scheme_Object *vec;
vec = argv[0];
if (SCHEME_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_VECTORP(vec))
scheme_wrong_contract("vector-ref", "vector?", 0, argc, argv);
len = SCHEME_VEC_SIZE(vec);
i = scheme_extract_index("vector-ref", 1, argc, argv, len, 0);
if (i >= len)
return bad_index("vector-ref", "", argv[1], argv[0], 0);
if (!SAME_OBJ(vec, argv[0]))
/* chaperone */
return scheme_chaperone_vector_ref(argv[0], i);
else
return (SCHEME_VEC_ELS(vec))[i];
}
Scheme_Object *
scheme_make_vector (intptr_t size, Scheme_Object *fill)
{
Scheme_Object *vec;
intptr_t i;
if (size < 0) {
vec = scheme_make_integer(size);
scheme_wrong_contract("make-vector", "exact-nonnegative-integer?", -1, 0, &vec);
}
if (size < 1024) {
vec = (Scheme_Object *)scheme_malloc_tagged(VECTOR_BYTES(size));
} else {
size_t sz;
sz = VECTOR_BYTES(size);
if (REV_VECTOR_BYTES(sz) != size)
/* overflow */
scheme_raise_out_of_memory(NULL, NULL);
else
vec = (Scheme_Object *)scheme_malloc_fail_ok(scheme_malloc_tagged, sz);
}
vec->type = scheme_vector_type;
SCHEME_VEC_SIZE(vec) = size;
if (fill) {
for (i = 0; i < size; i++) {
SCHEME_VEC_ELS(vec)[i] = fill;
}
}
return vec;
}
static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec, *ovec, *v;
intptr_t len, i;
vec = argv[0];
if (SCHEME_NP_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_VECTORP(vec))
scheme_wrong_contract("vector->immutable-vector", "vector?", 0, argc, argv);
if (SCHEME_IMMUTABLEP(vec))
return argv[0];
ovec = vec;
len = SCHEME_VEC_SIZE(ovec);
vec = scheme_make_vector(len, NULL);
if (!SAME_OBJ(ovec, argv[0])) {
for (i = 0; i < len; i++) {
v = scheme_chaperone_vector_ref(argv[0], i);
SCHEME_VEC_ELS(vec)[i] = v;
}
} else {
for (i = 0; i < len; i++) {
SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(ovec)[i];
}
}
SCHEME_SET_IMMUTABLE(vec);
return vec;
}
static Scheme_Object *do_chaperone_vector(const char *name, int is_impersonator, int argc, Scheme_Object **argv)
{
Scheme_Chaperone *px;
Scheme_Object *val = argv[0];
Scheme_Object *redirects;
Scheme_Hash_Tree *props;
if (SCHEME_CHAPERONEP(val))
val = SCHEME_CHAPERONE_VAL(val);
if (!SCHEME_VECTORP(val)
|| (is_impersonator && !SCHEME_MUTABLEP(val)))
scheme_wrong_contract(name, is_impersonator ? "(and/c vector? (not/c immutable?))" : "vector?", 0, argc, argv);
scheme_check_proc_arity(name, 3, 1, argc, argv);
scheme_check_proc_arity(name, 3, 2, argc, argv);
props = scheme_parse_chaperone_props(name, 3, argc, argv);
redirects = scheme_make_pair(argv[1], argv[2]);
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->iso.so.type = scheme_chaperone_type;
px->props = props;
px->val = val;
px->prev = argv[0];
px->redirects = redirects;
if (is_impersonator)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
return (Scheme_Object *)px;
}
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;
}
static Scheme_Object *make_sema_repost(int n, Scheme_Object **p)
{
if (!SCHEME_SEMAP(p[0]))
scheme_wrong_contract("semaphore-peek-evt", "semaphore?", 0, n, p);
return scheme_make_sema_repost(p[0]);
}
Scheme_Object *
scheme_checked_vector_set(int argc, Scheme_Object *argv[])
{
Scheme_Object *vec = argv[0];
intptr_t i, len;
if (SCHEME_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_MUTABLE_VECTORP(vec))
scheme_wrong_contract("vector-set!", "(and/c vector? (not/c immutable?))", 0, argc, argv);
len = SCHEME_VEC_SIZE(vec);
i = scheme_extract_index("vector-set!", 1, argc, argv, len, 0);
if (i >= len)
return bad_index("vector-set!", "", argv[1], argv[0], 0);
if (!SAME_OBJ(vec, argv[0]))
scheme_chaperone_vector_set(argv[0], i, argv[2]);
else
SCHEME_VEC_ELS(vec)[i] = argv[2];
return scheme_void;
}
static Scheme_Object *
vector_fill (int argc, Scheme_Object *argv[])
{
int i, sz;
Scheme_Object *v, *vec = argv[0];
if (SCHEME_NP_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_MUTABLE_VECTORP(vec))
scheme_wrong_contract("vector-fill!", "(and/c vector? (not/c immutable?))", 0, argc, argv);
v = argv[1];
sz = SCHEME_VEC_SIZE(vec);
if (SAME_OBJ(vec, argv[0])) {
for (i = 0; i < sz; i++) {
SCHEME_VEC_ELS(argv[0])[i] = v;
}
} else {
for (i = 0; i < sz; i++) {
scheme_chaperone_vector_set(argv[0], i, v);
}
}
return scheme_void;
}
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;
}
static Scheme_Object *hit_sema(int n, Scheme_Object **p)
{
if (!SCHEME_SEMAP(p[0]))
scheme_wrong_contract("semaphore-post", "semaphore?", 0, n, p);
scheme_post_sema(p[0]);
return scheme_void;
}
static Scheme_Object *
vector_star_length (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec = argv[0];
if (!SCHEME_VECTORP(vec))
scheme_wrong_contract("vector*-length", "(and/c vector? (not/c impersonator?))", 0, argc, argv);
return scheme_make_integer(SCHEME_VEC_SIZE(vec));
}
static Scheme_Object *
char_to_integer (int argc, Scheme_Object *argv[])
{
mzchar c;
if (!SCHEME_CHARP(argv[0]))
scheme_wrong_contract("char->integer", "char?", 0, argc, argv);
c = SCHEME_CHAR_VAL(argv[0]);
return scheme_make_integer_value(c);
}
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;
}
static Scheme_Object *char_general_category (int argc, Scheme_Object *argv[])
{
mzchar c;
int cat;
if (!SCHEME_CHARP(argv[0]))
scheme_wrong_contract("char-general-category", "char?", 0, argc, argv);
c = SCHEME_CHAR_VAL(argv[0]);
cat = scheme_general_category(c);
return general_category_symbols[cat];
}
static Scheme_Object *
vector_length (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec = argv[0];
if (SCHEME_NP_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_VECTORP(vec))
scheme_wrong_contract("vector-length", "vector?", 0, argc, argv);
return scheme_make_integer(SCHEME_VEC_SIZE(vec));
}
static Scheme_Object *
div_prim (int argc, Scheme_Object *argv[])
{
Scheme_Object *ret;
int i;
ret = argv[0];
if (!SCHEME_NUMBERP(ret)) {
scheme_wrong_contract("/", "number?", 0, argc, argv);
ESCAPED_BEFORE_HERE;
}
if (argc == 1) {
if (ret != zeroi)
return scheme_bin_div(scheme_make_integer(1), ret);
else {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
"/: division by zero");
ESCAPED_BEFORE_HERE;
}
}
for (i = 1; i < argc; i++) {
Scheme_Object *o = argv[i];
if (!SCHEME_NUMBERP(o)) {
scheme_wrong_contract("/", "number?", i, argc, argv);
ESCAPED_BEFORE_HERE;
}
if (o != zeroi)
ret = scheme_bin_div(ret, o);
else {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
"/: division by zero");
ESCAPED_BEFORE_HERE;
}
}
return ret;
}
static MZ_INLINE Scheme_Object *
minus_slow (Scheme_Object *ret, int argc, Scheme_Object *argv[])
{
int i;
for (i = 1; i < argc; i++) {
Scheme_Object *o = argv[i];
if (!SCHEME_NUMBERP(o)) {
scheme_wrong_contract("-", "number?", i, argc, argv);
ESCAPED_BEFORE_HERE;
}
ret = scheme_bin_minus(ret, o);
}
return ret;
}
Scheme_Object *
scheme_checked_vector_cas(int argc, Scheme_Object *argv[])
{
Scheme_Object *vec = argv[0];
intptr_t i, len;
if (!SCHEME_MUTABLE_VECTORP(vec))
scheme_wrong_contract("vector-cas!", "(and/c vector? (not/c immutable?) (not/c impersonator?))", 0, argc, argv);
len = SCHEME_VEC_SIZE(vec);
i = scheme_extract_index("vector-cas!", 1, argc, argv, len, 0);
if (i >= len)
return bad_index("vector-cas!", "", argv[1], argv[0], 0);
return unsafe_vector_star_cas(argc, argv);
}
Scheme_Object *
scheme_list_to_vector (Scheme_Object *list)
{
intptr_t len, i;
Scheme_Object *vec, *orig = list;
len = scheme_proper_list_length(list);
if (len < 0)
scheme_wrong_contract("list->vector", "list?", -1, 0, &orig);
vec = scheme_make_vector(len, NULL);
for (i = 0; i < len; i++) {
SCHEME_VEC_ELS(vec)[i] = SCHEME_CAR(list);
list = SCHEME_CDR(list);
}
return vec;
}
static Scheme_Object *
vector_to_list (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec = argv[0];
if (SCHEME_NP_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_VECTORP(vec)) {
scheme_wrong_contract("vector->list", "vector?", 0, argc, argv);
return NULL;
}
if (!SAME_OBJ(vec, argv[0]))
return chaperone_vector_to_list(argv[0]);
else
return scheme_vector_to_list(vec);
}
Scheme_Object *
scheme_checked_vector_star_ref (int argc, Scheme_Object *argv[])
{
intptr_t i, len;
Scheme_Object *vec;
vec = argv[0];
if (!SCHEME_VECTORP(vec))
scheme_wrong_contract("vector*-ref", "(and/c vector? (not impersonator?))", 0, argc, argv);
len = SCHEME_VEC_SIZE(vec);
i = scheme_extract_index("vector*-ref", 1, argc, argv, len, 0);
if (i >= len)
return bad_index("vector*-ref", "", argv[1], argv[0], 0);
return (SCHEME_VEC_ELS(vec))[i];
}
static Scheme_Object *char_utf8_length (int argc, Scheme_Object *argv[])
{
mzchar wc;
if (!SCHEME_CHARP(argv[0]))
scheme_wrong_contract("char-utf-8-length", "char?", 0, argc, argv);
wc = SCHEME_CHAR_VAL(argv[0]);
if (wc < 0x80) {
return scheme_make_integer(1);
} else if (wc < 0x800) {
return scheme_make_integer(2);
} else if (wc < 0x10000) {
return scheme_make_integer(3);
} else if (wc < 0x200000) {
return scheme_make_integer(4);
} else if (wc < 0x4000000) {
return scheme_make_integer(5);
} else {
return scheme_make_integer(6);
}
}
static Scheme_Object *do_chaperone_vector(const char *name, int is_impersonator, int pass_self, int unsafe, int argc, Scheme_Object **argv)
{
Scheme_Chaperone *px;
Scheme_Object *val = argv[0];
Scheme_Object *redirects;
Scheme_Object *props;
if (SCHEME_CHAPERONEP(val)) {
val = SCHEME_CHAPERONE_VAL(val);
}
if (!SCHEME_VECTORP(val)
|| (is_impersonator && !SCHEME_MUTABLEP(val)))
scheme_wrong_contract(name, is_impersonator ? "(and/c vector? (not/c immutable?))" : "vector?", 0, argc, argv);
if (unsafe) {
/* We cannot dispatch the operations on an unsafe vector chaperone to a chaperoned vector because of the invariant
that the val field of a vector chaperone must point to a non-chaperoned vector.
To ensure this we error if the second argument passed to `unsafe-chaperone-vector` is not a unchaperoned vector */
if (!SCHEME_VECTORP(argv[1])) {
scheme_wrong_contract(name, "(and/c vector? (not/c impersonator?))", 1, argc, argv);
}
val = argv[1];
}
else {
/* allow false for interposition procedures */
scheme_check_proc_arity2(name, 3 + (pass_self ? 1 : 0), 1, argc, argv, 1);
scheme_check_proc_arity2(name, 3 + (pass_self ? 1 : 0), 2, argc, argv, 1);
/* but only allow `#f` if both are `#f` */
if (SCHEME_FALSEP(argv[1]) != SCHEME_FALSEP(argv[2])) {
scheme_contract_error(name,
"accessor and mutator wrapper must be both `#f` or neither `#f`",
"accessor wrapper", 1, argv[1],
"mutator wrapper", 1, argv[2],
NULL);
}
}
props = scheme_parse_chaperone_props(name, unsafe ? 2 : 3, argc, argv);
/*
Regular vector chaperones store redirect procedures in a pair, (cons getter setter).
Property only vector chaperones have no redirection procedures, and redirects is assigned an empty vector.
Unsafe vector chaperones dispatch operations to another vector stored in a box in redirects.
*/
if (SCHEME_FALSEP(argv[1])) {
redirects = scheme_make_vector(0, NULL);
}
else if (unsafe) {
redirects = scheme_false;
}
else {
redirects = scheme_make_pair(argv[1], argv[2]);
}
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->iso.so.type = scheme_chaperone_type;
px->props = props;
px->val = val;
px->prev = argv[0];
px->redirects = redirects;
if (is_impersonator)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
/* Use flag to tell if the chaperone is a chaperone* */
if (pass_self) {
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_VEC_CHAPERONE_STAR;
}
return (Scheme_Object *)px;
}
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 *vector_to_values (int argc, Scheme_Object *argv[])
{
Scheme_Thread *p;
Scheme_Object *vec, **a, *plain_vec;
intptr_t len, start, finish, i;
vec = argv[0];
if (SCHEME_NP_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_VECTORP(vec))
scheme_wrong_contract("vector->values", "vector?", 0, argc, argv);
len = SCHEME_VEC_SIZE(vec);
if (argc > 1)
start = scheme_extract_index("vector->values", 1, argc, argv, len + 1, 0);
else
start = 0;
if (argc > 2)
finish = scheme_extract_index("vector->values", 2, argc, argv, len + 1, 0);
else
finish = len;
if (!(start <= len)) {
bad_index("vector->values", "starting ", argv[1], argv[0], 0);
}
if (!(finish >= start && finish <= len)) {
bad_index("vector->values", "ending ", argv[2], argv[0], start);
}
len = finish - start;
if (len == 1) {
if (!SAME_OBJ(vec, argv[0]))
return scheme_chaperone_vector_ref(argv[0], start);
else
return SCHEME_VEC_ELS(vec)[start];
}
if (!SAME_OBJ(vec, argv[0])) {
plain_vec = scheme_make_vector(len, NULL);
for (i = 0; i < len; i++) {
vec = scheme_chaperone_vector_ref(argv[0], start + i);
SCHEME_VEC_ELS(plain_vec)[i] = vec;
}
vec = plain_vec;
start = 0;
}
p = scheme_current_thread;
if (p->values_buffer && (p->values_buffer_size >= len))
a = p->values_buffer;
else {
a = MALLOC_N(Scheme_Object *, len);
p->values_buffer = a;
p->values_buffer_size = len;
}
p->ku.multiple.array = a;
p->ku.multiple.count = len;
for (i = 0; i < len; i++) {
a[i] = SCHEME_VEC_ELS(vec)[start + i];
}
return SCHEME_MULTIPLE_VALUES;
}