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_type(name, is_impersonator ? "mutable vector" : "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 *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_type("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_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_type("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_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;
}
}
static Scheme_Object *read_define_for_syntax(Scheme_Object *obj)
{
if (!SCHEME_VECTORP(obj)) return NULL;
obj = scheme_clone_vector(obj, 0, 0);
obj->type = scheme_define_for_syntax_type;
return obj;
}
static Scheme_Object *
vector_to_list (int argc, Scheme_Object *argv[])
{
if (!SCHEME_VECTORP(argv[0]))
scheme_wrong_type("vector->list", "vector", 0, argc, argv);
return scheme_vector_to_list(argv[0]);
}
static Scheme_Object *
vector_length (int argc, Scheme_Object *argv[])
{
if (!SCHEME_VECTORP(argv[0]))
scheme_wrong_type("vector-length", "vector", 0, argc, argv);
return scheme_make_integer(SCHEME_VEC_SIZE(argv[0]));
}
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 *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_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 *vector_to_values (int argc, Scheme_Object *argv[])
{
Scheme_Thread *p;
Scheme_Object *vec, **a;
long len, start, finish, i;
vec = argv[0];
if (!SCHEME_VECTORP(vec))
scheme_wrong_type("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", argv[1], vec, 0);
}
if (!(finish >= start && finish <= len)) {
bad_index("vector->values", argv[2], vec, start);
}
len = finish - start;
if (len == 1)
return SCHEME_VEC_ELS(vec)[start];
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;
}
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 *
immutablep (int argc, Scheme_Object *argv[])
{
Scheme_Object *v = argv[0];
return ((!SCHEME_INTP(v)
&& SCHEME_IMMUTABLEP(v)
&& (SCHEME_PAIRP(v)
|| SCHEME_VECTORP(v)
|| SCHEME_BYTE_STRINGP(v)
|| SCHEME_CHAR_STRINGP(v)
|| SCHEME_BOXP(v)))
? scheme_true
: scheme_false);
}
static Scheme_Object *sfs_let_void(Scheme_Object *o, SFS_Info *info)
{
Scheme_Let_Void *lv = (Scheme_Let_Void *)o;
Scheme_Object *body;
int i, pos, save_mnt;
Scheme_Object *vec;
scheme_sfs_push(info, lv->count, 1);
pos = info->stackpos;
save_mnt = info->max_nontail;
if (!info->pass) {
vec = scheme_make_vector(lv->count + 1, NULL);
scheme_sfs_save(info, vec);
} else {
vec = scheme_sfs_next_saved(info);
if (!SCHEME_VECTORP(vec))
scheme_signal_error("internal error: not a vector");
for (i = 0; i < lv->count; i++) {
info->max_used[pos + i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[i]);
info->max_calls[pos + i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]);
}
info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]);
}
body = scheme_sfs_expr(lv->body, info, -1);
# if MAX_SFS_CLEARING
if (!info->pass)
info->max_nontail = info->ip;
# endif
if (!info->pass) {
int n;
SCHEME_VEC_ELS(vec)[lv->count] = scheme_make_integer(info->max_nontail);
for (i = 0; i < lv->count; i++) {
n = info->max_used[pos + i];
SCHEME_VEC_ELS(vec)[i] = scheme_make_integer(n);
}
} else {
info->max_nontail = save_mnt;
}
lv->body = body;
return o;
}
Scheme_Object *
scheme_checked_vector_ref (int argc, Scheme_Object *argv[])
{
long i, len;
if (!SCHEME_VECTORP(argv[0]))
scheme_wrong_type("vector-ref", "vector", 0, argc, argv);
len = SCHEME_VEC_SIZE(argv[0]);
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(argv[0]))[i];
}
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 *vector_to_immutable (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec, *ovec;
long len, i;
if (!SCHEME_VECTORP(argv[0]))
scheme_wrong_type("vector->immutable-vector", "vector", 0, argc, argv);
if (SCHEME_IMMUTABLEP(argv[0]))
return argv[0];
ovec = argv[0];
len = SCHEME_VEC_SIZE(ovec);
vec = scheme_make_vector(len, NULL);
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_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;
}
}
/**
* Convert a Scheme list or vector to a GVariant that represents an array.
*/
static GVariant *
scheme_object_to_array (Scheme_Object *lv, gchar *type)
{
Scheme_Object *sval; // One element of the list/array
GVariant *gval; // The converted element
GVariantBuilder *builder;
// Special case: The empty list gives the empty array.
if (SCHEME_NULLP (lv))
{
// Note: For individual objects, D-Bus type signatures are acceptable
// as GVariant type strings.
builder = g_variant_builder_new ((GVariantType *) type);
if (builder == NULL)
return NULL;
return g_variant_builder_end (builder);
} // if it's null
// A list, or so we think.
if (SCHEME_PAIRP (lv))
{
builder = g_variant_builder_new ((GVariantType *) type);
if (builder == NULL)
return NULL;
// Follow the cons cells through the list
while (SCHEME_PAIRP (lv))
{
sval = SCHEME_CAR (lv);
gval = scheme_object_to_parameter (sval, type+1);
if (gval == NULL)
{
g_variant_builder_unref (builder);
return NULL;
} // if (gval == NULL)
g_variant_builder_add_value (builder, gval);
lv = SCHEME_CDR (lv);
} // while
// We've reached the end. Was it really a list?
if (! SCHEME_NULLP (lv))
{
g_variant_builder_unref (builder);
return NULL;
} // If the list does not end in null, so it's not a list.
// We've hit the null at the end of the list.
return g_variant_builder_end (builder);
} // if it's a list
// A vector
else if (SCHEME_VECTORP (lv))
{
int len = SCHEME_VEC_SIZE (lv);
int i;
LOG ("scheme_object_to_array: Handling a vector of length %d", len);
builder = g_variant_builder_new (G_VARIANT_TYPE_ARRAY);
if (builder == NULL)
return NULL;
for (i = 0; i < len; i++)
{
sval = SCHEME_VEC_ELS(lv)[i];
gval = scheme_object_to_parameter (sval, type + 1);
if (gval == NULL)
{
g_variant_builder_unref (builder);
return NULL;
} // if we could not convert the object
g_variant_builder_add_value (builder, gval);
} // for each index
return g_variant_builder_end (builder);
} // if it's a vector
// Can only convert lists and vectors.
else
return NULL;
} // scheme_object_to_array
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;
}
static Scheme_Object *write_compiled_closure(Scheme_Object *obj)
{
Scheme_Closure_Data *data;
Scheme_Object *name, *l, *code, *ds, *tl_map;
int svec_size, pos;
Scheme_Marshal_Tables *mt;
data = (Scheme_Closure_Data *)obj;
if (data->name) {
name = data->name;
if (SCHEME_VECTORP(name)) {
/* We can only save marshalable src names, which includes
paths, symbols, and strings: */
Scheme_Object *src;
src = SCHEME_VEC_ELS(name)[1];
if (!SCHEME_PATHP(src)
&& !SCHEME_PATHP(src)
&& !SCHEME_SYMBOLP(src)) {
/* Just keep the name */
name = SCHEME_VEC_ELS(name)[0];
}
}
} else {
name = scheme_null;
}
svec_size = data->closure_size;
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) {
svec_size += ((2 * (data->num_params + data->closure_size)) + BITS_PER_MZSHORT - 1) / BITS_PER_MZSHORT;
}
if (SCHEME_RPAIRP(data->code)) {
/* This can happen if loaded bytecode is printed out and the procedure
body has never been needed before.
It's also possible in non-JIT mode if an empty closure is embedded
as a 3-D value in compiled code. */
scheme_delay_load_closure(data);
}
/* If the body is simple enough, write it directly.
Otherwise, create a delay indirection so that the body
is loaded on demand. */
code = data->code;
switch (SCHEME_TYPE(code)) {
case scheme_toplevel_type:
case scheme_local_type:
case scheme_local_unbox_type:
case scheme_integer_type:
case scheme_true_type:
case scheme_false_type:
case scheme_void_type:
case scheme_quote_syntax_type:
ds = code;
break;
default:
ds = NULL;
break;
}
if (!ds) {
mt = scheme_current_thread->current_mt;
if (!mt->pass) {
int key;
pos = mt->cdata_counter;
if ((!mt->cdata_map || (pos >= 32))
&& !(pos & (pos - 1))) {
/* Need to grow the array */
Scheme_Object **a;
a = MALLOC_N(Scheme_Object *, (pos ? 2 * pos : 32));
memcpy(a, mt->cdata_map, pos * sizeof(Scheme_Object *));
mt->cdata_map = a;
}
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 *
vector_p (int argc, Scheme_Object *argv[])
{
return (SCHEME_VECTORP(argv[0]) ? scheme_true : scheme_false);
}
