static Scheme_Object *read_case_lambda(Scheme_Object *obj) { Scheme_Object *s, *a; int count, i, all_closed = 1; Scheme_Case_Lambda *cl; if (!SCHEME_PAIRP(obj)) return NULL; s = SCHEME_CDR(obj); for (count = 0; SCHEME_PAIRP(s); s = SCHEME_CDR(s)) { count++; } cl = (Scheme_Case_Lambda *) scheme_malloc_tagged(sizeof(Scheme_Case_Lambda) + (count - 1) * sizeof(Scheme_Object *)); cl->so.type = scheme_case_lambda_sequence_type; cl->count = count; cl->name = SCHEME_CAR(obj); if (SCHEME_NULLP(cl->name)) cl->name = NULL; s = SCHEME_CDR(obj); for (i = 0; i < count; i++, s = SCHEME_CDR(s)) { a = SCHEME_CAR(s); cl->array[i] = a; if (!SCHEME_PROCP(a)) { if (!SAME_TYPE(SCHEME_TYPE(a), scheme_unclosed_procedure_type)) return NULL; all_closed = 0; } } if (all_closed) { /* Empty closure: produce procedure value directly. (We assume that this was generated by a direct write of a case-lambda data record in print.c, and that it's not in a CASE_LAMBDA_EXPD syntax record.) */ return scheme_case_lambda_execute((Scheme_Object *)cl); } return (Scheme_Object *)cl; }
Scheme_Object *scheme_case_lambda_jit(Scheme_Object *expr) { #ifdef MZ_USE_JIT Scheme_Case_Lambda *seqin = (Scheme_Case_Lambda *)expr; if (!seqin->native_code) { Scheme_Case_Lambda *seqout; Scheme_Native_Lambda *ndata; Scheme_Object *val, *name; int i, cnt, size, all_closed = 1; cnt = seqin->count; size = sizeof(Scheme_Case_Lambda) + ((cnt - mzFLEX_DELTA) * sizeof(Scheme_Object *)); seqout = (Scheme_Case_Lambda *)scheme_malloc_tagged(size); memcpy(seqout, seqin, size); name = seqin->name; if (name && SCHEME_BOXP(name)) name = SCHEME_BOX_VAL(name); for (i = 0; i < cnt; i++) { val = seqout->array[i]; if (SCHEME_PROCP(val)) { /* Undo creation of empty closure */ val = (Scheme_Object *)((Scheme_Closure *)val)->code; seqout->array[i] = val; } ((Scheme_Lambda *)val)->name = name; if (((Scheme_Lambda *)val)->closure_size) all_closed = 0; } /* Generating the code may cause empty closures to be formed: */ ndata = scheme_generate_case_lambda(seqout); seqout->native_code = ndata; if (current_linklet_native_lambdas) { for (i = 0; i < cnt; i++) { val = seqout->array[i]; { /* Force jitprep on body, too, to discover all lambdas */ Scheme_Object *body; body = jit_expr(((Scheme_Lambda *)val)->body); ((Scheme_Lambda *)val)->body = body; } val = (Scheme_Object *)((Scheme_Lambda *)val)->u.native_code; current_linklet_native_lambdas = scheme_make_pair(val, current_linklet_native_lambdas); } } if (all_closed) { /* Native closures do not refer back to the original bytecode, so no need to worry about clearing the reference. */ Scheme_Native_Closure *nc; nc = (Scheme_Native_Closure *)scheme_make_native_case_closure(ndata); for (i = 0; i < cnt; i++) { val = seqout->array[i]; if (!SCHEME_PROCP(val)) { val = scheme_make_native_closure(((Scheme_Lambda *)val)->u.native_code); } nc->vals[i] = val; } return (Scheme_Object *)nc; } else { /* The case-lambda data must point to the original closure-data record, because that's where the closure maps are kept. But we don't need the bytecode, anymore. So clone the closure-data record and drop the bytecode in thte clone. */ for (i = 0; i < cnt; i++) { val = seqout->array[i]; if (!SCHEME_PROCP(val)) { Scheme_Lambda *data; data = MALLOC_ONE_TAGGED(Scheme_Lambda); memcpy(data, val, sizeof(Scheme_Lambda)); data->body = NULL; seqout->array[i] = (Scheme_Object *)data; } } } return (Scheme_Object *)seqout; } #endif return expr; }
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; }