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; }