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;
}
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_type("vector-copy!", "mutable vector", 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_type("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_arg_mismatch("vector-copy!",
"not enough room in target vector: ",
argv[2]);
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;
}
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 *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;
}
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_wrong_chaperoned("vector-ref", "result", orig, o);
return o;
}
}
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 *unsafe_vector_ref (int argc, Scheme_Object *argv[])
{
if (SCHEME_NP_CHAPERONEP(argv[0]))
return scheme_chaperone_vector_ref(argv[0], SCHEME_INT_VAL(argv[1]));
else
return SCHEME_VEC_ELS(argv[0])[SCHEME_INT_VAL(argv[1])];
}
static Scheme_Object *unsafe_vector_len (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec = argv[0];
intptr_t n;
if (SCHEME_NP_CHAPERONEP(vec)) vec = SCHEME_CHAPERONE_VAL(vec);
n = SCHEME_VEC_SIZE(vec);
return scheme_make_integer(n);
}
static Scheme_Object *unsafe_vector_set (int argc, Scheme_Object *argv[])
{
if (SCHEME_NP_CHAPERONEP(argv[0]))
scheme_chaperone_vector_set(argv[0], SCHEME_INT_VAL(argv[1]), argv[2]);
else
SCHEME_VEC_ELS(argv[0])[SCHEME_INT_VAL(argv[1])] = argv[2];
return scheme_void;
}
static Scheme_Object *
bad_index(char *name, const char *which, Scheme_Object *i, Scheme_Object *vec, int bottom)
{
scheme_bad_vec_index(name, i, which, vec, bottom,
(SCHEME_NP_CHAPERONEP(vec)
? SCHEME_VEC_SIZE(SCHEME_CHAPERONE_VAL(vec))
: SCHEME_VEC_SIZE(vec)));
return NULL;
}
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));
}
Scheme_Object *scheme_chaperone_vector_ref2(Scheme_Object *o, int i, Scheme_Object *outermost)
{
if (!SCHEME_NP_CHAPERONEP(o)) {
return SCHEME_VEC_ELS(o)[i];
} else {
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *a[4], *red, *orig;
#ifdef DO_STACK_CHECK
{
# include "mzstkchk.h"
return chaperone_vector_ref_overflow(o, i);
}
#endif
if(SCHEME_FALSEP(px->redirects)) {
/* unsafe chaperones */
return scheme_chaperone_vector_ref2(px->val, i, outermost);
}
orig = scheme_chaperone_vector_ref2(px->prev, i, outermost);
if (SCHEME_REDIRECTS_PROP_ONLY_VECTORP(px->redirects)) {
/* chaperone was on property accessors */
/* or vector chaperone is property only */
return orig;
}
red = SCHEME_CAR(px->redirects);
if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_VEC_CHAPERONE_STAR) {
a[0] = outermost;
a[1] = px->prev;
a[2] = scheme_make_integer(i);
a[3] = orig;
o = _scheme_apply(red, 4, a);
}
else {
a[0] = px->prev;
a[1] = scheme_make_integer(i);
a[2] = orig;
o = _scheme_apply(red, 3, a);
}
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(o, orig))
scheme_wrong_chaperoned("vector-ref", "result", orig, o);
return o;
}
}
void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v)
{
Scheme_Object *outermost = o;
while (1) {
if (!SCHEME_NP_CHAPERONEP(o)) {
SCHEME_VEC_ELS(o)[i] = v;
return;
} else {
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *a[4], *red;
int chap_star = SCHEME_CHAPERONE_FLAGS(px) & SCHEME_VEC_CHAPERONE_STAR ? 1 : 0;
red = px->redirects;
if (SCHEME_FALSEP(red)) {
o = px->val;
continue;
}
o = px->prev;
if (!SCHEME_REDIRECTS_PROP_ONLY_VECTORP(red)) {
/* not a property only chaperone */
red = SCHEME_CDR(px->redirects);
if (chap_star) {
a[0] = outermost;
a[1] = o;
a[2] = scheme_make_integer(i);
a[3] = v;
v = _scheme_apply(red, 4, a);
}
else {
a[0] = o;
a[1] = scheme_make_integer(i);
a[2] = v;
v = _scheme_apply(red, 3, a);
}
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(v, a[2 + chap_star]))
scheme_wrong_chaperoned("vector-set!", "value", a[2 + chap_star], v);
}
}
}
}
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_chaperone_vector_copy(Scheme_Object *vec)
{
int len;
Scheme_Object *a[3], *vec2;
if (SCHEME_NP_CHAPERONEP(vec))
len = SCHEME_VEC_SIZE(SCHEME_CHAPERONE_VAL(vec));
else
len = SCHEME_VEC_SIZE(vec);
vec2 = scheme_make_vector(len, NULL);
a[0] = vec2;
a[1] = scheme_make_integer(0);
a[2] = vec;
(void)vector_copy_bang(3, a);
return vec2;
}
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_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_wrong_chaperoned("vector-set!", "value", a[2], v);
}
}
}
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;
}