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 *
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;
}
static Scheme_Object *
make_vector (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec, *fill;
long len;
len = scheme_extract_index("make-vector", 0, argc, argv, -1, 0);
if (len == -1) {
scheme_raise_out_of_memory("make-vector", "making vector of length %s",
scheme_make_provided_string(argv[0], 1, NULL));
}
if (argc == 2)
fill = argv[1];
else
fill = scheme_make_integer(0);
vec = scheme_make_vector(len, fill);
return vec;
}
Scheme_Object *
scheme_checked_make_vector (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec, *fill;
intptr_t len;
len = scheme_extract_index("make-vector", 0, argc, argv, -1, 0);
if ((len == -1)
/* also watch for overflow: */
|| (REV_VECTOR_BYTES(VECTOR_BYTES(len)) != len)) {
scheme_raise_out_of_memory("make-vector", "making vector of length %s",
scheme_make_provided_string(argv[0], 1, NULL));
}
if (argc == 2)
fill = argv[1];
else
fill = scheme_make_integer(0);
vec = scheme_make_vector(len, fill);
return vec;
}
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;
}
