static Scheme_Object *apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj)
{
Scheme_Object *a[1], *v, *oprocs;
a[0] = obj;
v = _scheme_apply(SCHEME_CDR(procs), 1, a);
if (SCHEME_FALSEP(v))
return NULL;
oprocs = scheme_struct_type_property_ref(scheme_impersonator_of_property, v);
if (!oprocs || !SAME_OBJ(SCHEME_CAR(oprocs), SCHEME_CAR(procs)))
scheme_contract_error((for_chaperone ? "impersonator-of?" : "equal?"),
"impersonator-of property procedure returned a value with a different prop:impersonator-of source",
"original value", 1, obj,
"returned value", 1, v,
NULL);
procs = scheme_struct_type_property_ref(scheme_equal_property, obj);
oprocs = scheme_struct_type_property_ref(scheme_equal_property, v);
if (procs || oprocs)
if (!procs || !oprocs || !SAME_OBJ(SCHEME_VEC_ELS(oprocs)[0],
SCHEME_VEC_ELS(procs)[0]))
scheme_contract_error((for_chaperone ? "impersonator-of?" : "equal?"),
"impersonator-of property procedure returned a value with a different prop:equal+hash source",
"original value", 1, obj,
"returned value", 1, v,
NULL);
return v;
}
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 void check_always_fixnum(const char *name, Scheme_Object *o)
{
if (SCHEME_INTP(o)) {
intptr_t v = SCHEME_INT_VAL(o);
if ((v < -1073741824) || (v > 1073741823)) {
scheme_contract_error(name,
"cannot fold to result that is not a fixnum on some platforms",
"result", 1, o,
NULL);
}
}
}
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;
}