static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[])
{
void *v;
if (!(SCHEME_HASHTP(argv[0]) || SCHEME_BUCKTP(argv[0])))
scheme_wrong_type("hash-table-get", "hash-table", 0, argc, argv);
if (SCHEME_BUCKTP(argv[0])){
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
if (t->mutex) scheme_wait_sema(t->mutex, 0);
v = scheme_lookup_in_table(t, (char *)argv[1]);
if (t->mutex) scheme_post_sema(t->mutex);
} else {
Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
if (t->mutex) scheme_wait_sema(t->mutex, 0);
v = scheme_hash_get(t, argv[1]);
if (t->mutex) scheme_post_sema(t->mutex);
}
if (v)
return (Scheme_Object *)v;
else if (argc == 3)
return _scheme_tail_apply(argv[2], 0, NULL);
else {
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"hash-table-get: no value found for key: %V",
argv[1]);
return scheme_void;
}
}
void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v)
{
while (1) {
if (!SCHEME_NP_CHAPERONEP(o)) {
SCHEME_VEC_ELS(o)[i] = v;
return;
} else {
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *a[3], *red;
o = px->prev;
a[0] = o;
a[1] = scheme_make_integer(i);
a[2] = v;
red = SCHEME_CDR(px->redirects);
v = _scheme_apply(red, 3, a);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(v, a[2]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"vector-set!: chaperone produced a result: %V that is not a chaperone of the original result: %V",
v,
a[2]);
}
}
}
static Scheme_Object *write_top(Scheme_Object *obj)
{
Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)obj;
if (!top->prefix)
scheme_raise_exn(MZEXN_FAIL,
"write: cannot marshal shared compiled code: %V",
obj);
return cons(scheme_make_integer(top->max_let_depth),
cons((Scheme_Object *)top->prefix,
scheme_protect_quote(top->code)));
}
void scheme_bad_vec_index(char *name, Scheme_Object *i, const char *what, Scheme_Object *vec,
intptr_t bottom, intptr_t len)
{
if (len) {
intptr_t n = len - 1;
char *vstr;
intptr_t vlen;
vstr = scheme_make_provided_string(vec, 2, &vlen);
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: index %s out of range [%ld, %ld] for %s: %t",
name,
scheme_make_provided_string(i, 2, NULL),
bottom, n,
what,
vstr, vlen);
} else
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: bad index %s for empty %s",
name,
scheme_make_provided_string(i, 0, NULL),
what);
}
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 Scheme_Object *
bad_index(char *name, Scheme_Object *i, Scheme_Object *vec, int bottom)
{
int n = SCHEME_VEC_SIZE(vec) - 1;
if (SCHEME_VEC_SIZE(vec)) {
char *vstr;
int vlen;
vstr = scheme_make_provided_string(vec, 2, &vlen);
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: index %s out of range [%d, %d] for vector: %t",
name,
scheme_make_provided_string(i, 2, NULL),
bottom, n,
vstr, vlen);
} else
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: bad index %s for empty vector",
name,
scheme_make_provided_string(i, 0, NULL));
return NULL;
}
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_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i)
{
if (!SCHEME_NP_CHAPERONEP(o)) {
return SCHEME_VEC_ELS(o)[i];
} else {
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *a[3], *red, *orig;
#ifdef DO_STACK_CHECK
{
# include "mzstkchk.h"
return chaperone_vector_ref_overflow(o, i);
}
#endif
orig = scheme_chaperone_vector_ref(px->prev, i);
if (SCHEME_VECTORP(px->redirects)) {
/* chaperone was on property accessors */
return orig;
}
a[0] = px->prev;
a[1] = scheme_make_integer(i);
a[2] = orig;
red = SCHEME_CAR(px->redirects);
o = _scheme_apply(red, 3, a);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(o, orig))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"vector-ref: chaperone produced a result: %V that is not a chaperone of the original result: %V",
o,
orig);
return o;
}
}
void scheme_post_sema(Scheme_Object *o)
{
Scheme_Sema *t = (Scheme_Sema *)o;
int v, consumed;
if (t->value < 0) return;
v = t->value + 1;
if (v > t->value) {
t->value = v;
while (t->first) {
Scheme_Channel_Syncer *w;
w = t->first;
t->first = w->next;
if (!w->next)
t->last = NULL;
else
t->first->prev = NULL;
if ((!w->syncing || !w->syncing->result) && !pending_break(w->p)) {
if (w->syncing) {
w->syncing->result = w->syncing_i + 1;
if (w->syncing->disable_break)
w->syncing->disable_break->suspend_break++;
scheme_post_syncing_nacks(w->syncing);
if (!w->syncing->reposts || !w->syncing->reposts[w->syncing_i]) {
t->value -= 1;
consumed = 1;
} else
consumed = 0;
if (w->syncing->accepts && w->syncing->accepts[w->syncing_i])
scheme_accept_sync(w->syncing, w->syncing_i);
} else {
/* In this case, we will remove the syncer from line, but
someone else might grab the post. This is unfair, but it
can help improve throughput when multiple threads synchronize
on a lock. */
consumed = 1;
}
w->picked = 1;
} else
consumed = 0;
w->in_line = 0;
w->prev = NULL;
w->next = NULL;
if (w->picked) {
scheme_weak_resume_thread(w->p);
if (consumed)
break;
}
/* otherwise, loop to find one we can wake up */
}
return;
}
scheme_raise_exn(MZEXN_FAIL,
"semaphore-post: the maximum post count has already been reached");
}
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 *not_implemented(int argc, Scheme_Object **argv)
{
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "not supported");
return NULL;
}
static Scheme_Object *
do_list_ref(char *name, int takecar, int argc, Scheme_Object *argv[])
{
long i, k;
Scheme_Object *lst, *index, *bnindex;
if (SCHEME_BIGNUMP(argv[1])) {
bnindex = argv[1];
k = 0;
} else if (!SCHEME_INTP(argv[1])) {
scheme_wrong_type(name, "non-negative exact integer", 1, argc, argv);
return NULL;
} else {
bnindex = NULL;
k = SCHEME_INT_VAL(argv[1]);
}
lst = argv[0];
index = argv[1];
if ((bnindex && !SCHEME_BIGPOS(bnindex))
|| (!bnindex && (k < 0))) {
scheme_wrong_type(name, "non-negative exact integer", 1, argc, argv);
return NULL;
}
do {
if (bnindex) {
if (SCHEME_INTP(bnindex)) {
k = SCHEME_INT_VAL(bnindex);
bnindex = 0;
} else {
k = LISTREF_BIGNUM_SLICE;
bnindex = scheme_bin_minus(bnindex, scheme_make_integer(LISTREF_BIGNUM_SLICE));
}
}
for (i = 0; i < k; i++) {
if (!SCHEME_PAIRP(lst)) {
char *lstr;
int llen;
lstr = scheme_make_provided_string(argv[0], 2, &llen);
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: index %s too large for list%s: %t", name,
scheme_make_provided_string(index, 2, NULL),
SCHEME_NULLP(lst) ? "" : " (not a proper list)",
lstr, llen);
return NULL;
}
lst = SCHEME_CDR(lst);
if (!(i & OCCASIONAL_CHECK))
SCHEME_USE_FUEL(OCCASIONAL_CHECK);
}
} while(bnindex);
if (takecar) {
if (!SCHEME_PAIRP(lst)) {
char *lstr;
int llen;
lstr = scheme_make_provided_string(argv[0], 2, &llen);
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: index %s too large for list%s: %t", name,
scheme_make_provided_string(index, 2, NULL),
SCHEME_NULLP(lst) ? "" : " (not a proper list)",
lstr, llen);
return NULL;
}
return SCHEME_CAR(lst);
} else
return lst;
}
