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