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_contract(name, is_impersonator ? "(and/c vector? (not/c immutable?))" : "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 *
equalish_prim (int argc, Scheme_Object *argv[])
{
Equal_Info eql;
scheme_check_proc_arity("equal?/recur", 2, 2, argc, argv);
init_equal_info(&eql);
eql.next_next = argv[2];
return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false);
}
static Scheme_Object *
equalish_prim (int argc, Scheme_Object *argv[])
{
Equal_Info eql;
scheme_check_proc_arity("equal?/recur", 2, 2, argc, argv);
eql.depth = 1;
eql.car_depth = 1;
eql.ht = NULL;
eql.recur = NULL;
eql.next = NULL;
eql.next_next = argv[2];
eql.for_chaperone = 0;
return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false);
}
static Scheme_Object *do_map_hash_table(int argc,
Scheme_Object *argv[],
char *name,
int keep)
{
int i;
Scheme_Object *f;
Scheme_Object *first, *last = NULL, *v, *p[2];
if (!(SCHEME_HASHTP(argv[0]) || SCHEME_BUCKTP(argv[0])))
scheme_wrong_type(name, "hash table", 0, argc, argv);
scheme_check_proc_arity(name, 2, 1, argc, argv);
f = argv[1];
if (keep)
first = scheme_null;
else
first = scheme_void;
if (SCHEME_BUCKTP(argv[0])) {
Scheme_Bucket_Table *hash;
Scheme_Bucket *bucket;
hash = (Scheme_Bucket_Table *)argv[0];
for (i = hash->size; i--; ) {
bucket = hash->buckets[i];
if (bucket && bucket->val && bucket->key) {
if (hash->weak)
p[0] = (Scheme_Object *)HT_EXTRACT_WEAK(bucket->key);
else
p[0] = (Scheme_Object *)bucket->key;
p[1] = (Scheme_Object *)bucket->val;
if (keep) {
v = _scheme_apply(f, 2, p);
v = scheme_make_pair(v, scheme_null);
if (last)
SCHEME_CDR(last) = v;
else
first = v;
last = v;
} else
_scheme_apply_multi(f, 2, p);
}
}
} else {
Scheme_Hash_Table *hash;
hash = (Scheme_Hash_Table *)argv[0];
for (i = hash->size; i--; ) {
if (hash->vals[i]) {
p[0] = hash->keys[i];
p[1] = hash->vals[i];
if (keep) {
v = _scheme_apply(f, 2, p);
v = scheme_make_pair(v, scheme_null);
if (last)
SCHEME_CDR(last) = v;
else
first = v;
last = v;
} else
_scheme_apply_multi(f, 2, p);
}
}
}
return first;
}
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_Hash_Tree *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);
if (SCHEME_PROCP(argv[1])) {
scheme_check_proc_arity(name, 3 + (pass_self ? 1 : 0), 2, argc, argv);
}
else if (!SCHEME_FALSEP(argv[2])) {
scheme_wrong_contract(name, "#f", 2, argc, argv);
}
}
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;
}
