void scheme_make_list_immutable(Scheme_Object *l) { for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { if (SCHEME_MUTABLEP(l)) SCHEME_SET_IMMUTABLE(l); } }
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 *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; }