From b8c3112b98ba069084db1edbee2abe79f46fc9d5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Mar 2010 15:56:04 +0000 Subject: [PATCH] fix chaperones on parameters svn: r18654 --- .../scribblings/reference/chaperones.scrbl | 5 ++ .../scribblings/reference/parameters.scrbl | 12 ++- collects/tests/mzscheme/chaperone.ss | 46 ++++++++++ src/mzscheme/src/eval.c | 2 +- src/mzscheme/src/fun.c | 87 +++++++++++++++---- src/mzscheme/src/schpriv.h | 2 +- src/mzscheme/src/struct.c | 47 ++++++---- src/mzscheme/src/stxobj.c | 2 +- src/mzscheme/src/thread.c | 20 ++++- 9 files changed, 182 insertions(+), 41 deletions(-) diff --git a/collects/scribblings/reference/chaperones.scrbl b/collects/scribblings/reference/chaperones.scrbl index 965516c6b8..ac71113d2a 100644 --- a/collects/scribblings/reference/chaperones.scrbl +++ b/collects/scribblings/reference/chaperones.scrbl @@ -102,6 +102,11 @@ that accepts as many results as produced by @scheme[proc]; it must return the same number of results, each of which is the same or a chaperone of the corresponding original result. +If @scheme[wrapper-proc] returns the same number of values as it is +given (i.e., it does not return a procedure to chaperone +@scheme[proc]'s result), then @scheme[proc] is called in @tech{tail +position} with respect to the call to the chaperone. + Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments to @scheme[procedure-chaperone] must be even) add chaperone properties or override chaperone-property values of @scheme[proc].} diff --git a/collects/scribblings/reference/parameters.scrbl b/collects/scribblings/reference/parameters.scrbl index 4c6e416c42..52ccc8c78d 100644 --- a/collects/scribblings/reference/parameters.scrbl +++ b/collects/scribblings/reference/parameters.scrbl @@ -141,18 +141,24 @@ Returns a parameter procedure that sets or retrieves the same value as @item{@scheme[wrap] applied when obtaining the parameter's value.} -]} +] + +See also @scheme[chaperone-procedure], which can also be used to guard +parameter procedures.} + @defproc[(parameter? [v any/c]) boolean?]{ Returns @scheme[#t] if @scheme[v] is a parameter procedure, @scheme[#f] otherwise.} + @defproc[(parameter-procedure=? [a parameter?][b parameter?]) boolean?]{ Returns @scheme[#t] if the parameter procedures @scheme[a] and -@scheme[b] always modify the same parameter with the same guards, -@scheme[#f] otherwise.} +@scheme[b] always modify the same parameter with the same guards +(although possibly with different @tech{chaperones}), @scheme[#f] +otherwise.} @defproc[(current-parameterization) parameterization?]{Returns the diff --git a/collects/tests/mzscheme/chaperone.ss b/collects/tests/mzscheme/chaperone.ss index 564b0ed65f..c2e5c79697 100644 --- a/collects/tests/mzscheme/chaperone.ss +++ b/collects/tests/mzscheme/chaperone.ss @@ -553,4 +553,50 @@ ;; ---------------------------------------- +(let () + (define (check-param current-directory) + (parameterize ([current-directory (current-directory)]) + (let* ([pre-cd? #f] + [post-cd? #f] + [got-cd? #f] + [post-got-cd? #f] + [cd1 (chaperone-procedure current-directory (case-lambda + [() (set! got-cd? #t) (values)] + [(v) (set! pre-cd? #t) v]))] + [cd2 (chaperone-procedure current-directory (case-lambda + [() (set! got-cd? #t) + (lambda (r) + (set! post-got-cd? #t) + r)] + [(v) + (set! pre-cd? #t) + (values v + (lambda (x) + (set! post-cd? #t) + (void)))]))]) + (test #t parameter? cd1) + (test #t parameter? cd2) + (test '(#f #f #f #f) list pre-cd? post-cd? got-cd? post-got-cd?) + (test (current-directory) cd1) + (test '(#f #f #t #f) list pre-cd? post-cd? got-cd? post-got-cd?) + (test (current-directory) cd2) + (test '(#f #f #t #t) list pre-cd? post-cd? got-cd? post-got-cd?) + (cd1 (current-directory)) + (test '(#t #f #t #t) list pre-cd? post-cd? got-cd? post-got-cd?) + (set! pre-cd? #f) + (parameterize ([cd1 (current-directory)]) + (test '(#t #f #t #t) list pre-cd? post-cd? got-cd? post-got-cd?)) + (set! pre-cd? #f) + (cd2 (current-directory)) + (test '(#t #t #t #t) list pre-cd? post-cd? got-cd? post-got-cd?) + (set! pre-cd? #f) + (set! post-cd? #f) + (parameterize ([cd2 (current-directory)]) + (test '(#t #t #t #t) list pre-cd? post-cd? got-cd? post-got-cd?))))) + (check-param current-directory) + (let ([p (make-parameter 88)]) + (check-param p))) + +;; ---------------------------------------- + (report-errs) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index abee1311ea..b5c0282d6a 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -9196,7 +9196,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, /* Chaperone is for function arguments */ VACATE_TAIL_BUFFER_USE_RUNSTACK(); UPDATE_THREAD_RSPTR(); - v = scheme_apply_chaperone(obj, num_rands, rands); + v = scheme_apply_chaperone(obj, num_rands, rands, NULL); } } else if (type == scheme_closed_prim_type) { GC_CAN_IGNORE Scheme_Closed_Primitive_Proc *prim; diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index 5b9a51ffe1..5bfe3cd351 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -31,6 +31,7 @@ #include "schpriv.h" #include "schexpobs.h" +#include "schmach.h" /* The implementations of the time primitives, such as `current-seconds', vary a lot from platform to platform. */ @@ -4007,7 +4008,7 @@ static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[]) if (!is_subarity(orig, naya)) scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "chaperone-procedure: arity of chaperoneing procedure: %V" + "chaperone-procedure: arity of chaperoning procedure: %V" " does not cover arity of original procedure: %V", argv[1], argv[0]); @@ -4024,10 +4025,46 @@ static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[]) return (Scheme_Object *)px; } -Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv) +static Scheme_Object *apply_chaperone_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; + Scheme_Object **argv = (Scheme_Object **)p->ku.k.p2; + Scheme_Object *auto_val = (Scheme_Object *)p->ku.k.p3; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + p->ku.k.p3 = NULL; + + return scheme_apply_chaperone(o, p->ku.k.i1, argv, auto_val); +} + +static Scheme_Object *do_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val) +{ + #ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + Scheme_Object **argv2; + argv2 = MALLOC_N(Scheme_Object*, argc); + memcpy(argv2, argv, sizeof(Scheme_Object *) * argc); + p->ku.k.p1 = (void *)o; + p->ku.k.p2 = (void *)argv2; + p->ku.k.p3 = (void *)auto_val; + p->ku.k.i1 = argc; + return scheme_handle_stack_overflow(apply_chaperone_k); + } + } +#endif + + return scheme_apply_chaperone(o, argc, argv, auto_val); +} + +Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val) { Scheme_Chaperone *px = (Scheme_Chaperone *)o; - Scheme_Object *v, *a[1], *a2[1], **argv2, *post; + Scheme_Object *v, *a[1], *a2[1], **argv2, *post, *result_v; int c, i; v = _scheme_apply_multi(px->redirects, argc, argv); @@ -4069,7 +4106,14 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object if (c == argc) { /* No filter for the result, so tail call: */ - return scheme_tail_apply(px->prev, c, argv2); + if (auto_val) { + if (SCHEME_CHAPERONEP(px->prev)) + return do_apply_chaperone(px->prev, c, argv2, auto_val); + else + return argv2[0]; + } else { + return scheme_tail_apply(px->prev, c, argv2); + } } else { /* Last element is a filter for the result(s) */ post = argv2[argc]; @@ -4078,7 +4122,16 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object "procedure chaperone: %V: expected as last result, produced: %V", px->redirects, post); - v = _scheme_apply_multi(px->prev, argc, argv2); + if (auto_val) { + if (SCHEME_CHAPERONEP(px->prev)) + result_v = do_apply_chaperone(px->prev, argc, argv2, auto_val); + else + result_v = argv2[0]; + v = auto_val; + } else { + v = _scheme_apply_multi(px->prev, argc, argv2); + result_v = NULL; + } if (v == SCHEME_MULTIPLE_VALUES) { GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread; if (SAME_OBJ(p->ku.multiple.array, p->values_buffer)) @@ -4114,16 +4167,16 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object for (i = 0; i < argc; i++) { if (!scheme_chaperone_of(argv2[i], argv[i])) { if (argc == 1) - scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, - "procedure-result chaperone: %V: result: %V is not a chaperone of original result: %V", - post, - argv2[i], argv[i]); - else - scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, - "procedure-result chaperone: %V: %d%s result: %V is not a chaperone of original result: %V", - post, - i, scheme_number_suffix(i), - argv2[i], argv[i]); + scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, + "procedure-result chaperone: %V: result: %V is not a chaperone of original result: %V", + post, + argv2[i], argv[i]); + else + scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, + "procedure-result chaperone: %V: %d%s result: %V is not a chaperone of original result: %V", + post, + i, scheme_number_suffix(i), + argv2[i], argv[i]); } } } else { @@ -4134,7 +4187,9 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object return NULL; } - if (c == 1) + if (result_v) + return result_v; + else if (c == 1) return argv2[0]; else return scheme_values(c, argv2); diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index c02c46f042..dcc6e14287 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -768,7 +768,7 @@ typedef struct Scheme_Chaperone { Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i); void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v); -Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv); +Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val); Scheme_Hash_Tree *scheme_parse_chaperone_props(const char *who, int start_at, int argc, Scheme_Object **argv); diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c index 91a19306c7..940250f835 100644 --- a/src/mzscheme/src/struct.c +++ b/src/mzscheme/src/struct.c @@ -2714,10 +2714,12 @@ int scheme_inspector_sees_part(Scheme_Object *s, Scheme_Object *insp, int pos) static Scheme_Object * struct_setter_p(int argc, Scheme_Object *argv[]) { - return ((STRUCT_mPROCP(argv[0], + Scheme_Object *v = argv[0]; + if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); + return ((STRUCT_mPROCP(v, SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK, SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER) - || STRUCT_mPROCP(argv[0], + || STRUCT_mPROCP(v, SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK, SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER)) ? scheme_true : scheme_false); @@ -2726,8 +2728,10 @@ struct_setter_p(int argc, Scheme_Object *argv[]) static Scheme_Object * struct_getter_p(int argc, Scheme_Object *argv[]) { - return ((STRUCT_PROCP(argv[0], SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER) - || STRUCT_mPROCP(argv[0], + Scheme_Object *v = argv[0]; + if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); + return ((STRUCT_PROCP(v, SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER) + || STRUCT_mPROCP(v, SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK, SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER)) ? scheme_true : scheme_false); @@ -2736,14 +2740,18 @@ struct_getter_p(int argc, Scheme_Object *argv[]) static Scheme_Object * struct_pred_p(int argc, Scheme_Object *argv[]) { - return (STRUCT_PROCP(argv[0], SCHEME_PRIM_IS_STRUCT_PRED) + Scheme_Object *v = argv[0]; + if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); + return (STRUCT_PROCP(v, SCHEME_PRIM_IS_STRUCT_PRED) ? scheme_true : scheme_false); } static Scheme_Object * struct_constr_p(int argc, Scheme_Object *argv[]) { - return (STRUCT_mPROCP(argv[0], + Scheme_Object *v = argv[0]; + if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); + return (STRUCT_mPROCP(v, SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK, SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_CONSTR) ? scheme_true : scheme_false); @@ -2752,20 +2760,24 @@ struct_constr_p(int argc, Scheme_Object *argv[]) static Scheme_Object * struct_prop_getter_p(int argc, Scheme_Object *argv[]) { - return ((STRUCT_mPROCP(argv[0], + Scheme_Object *v = argv[0]; + if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); + return ((STRUCT_mPROCP(v, SCHEME_PRIM_OTHER_TYPE_MASK, SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER) - && SAME_TYPE(SCHEME_TYPE(SCHEME_PRIM_CLOSURE_ELS(argv[0])[0]), scheme_struct_property_type)) + && SAME_TYPE(SCHEME_TYPE(SCHEME_PRIM_CLOSURE_ELS(v)[0]), scheme_struct_property_type)) ? scheme_true : scheme_false); } static Scheme_Object * chaperone_prop_getter_p(int argc, Scheme_Object *argv[]) { - return ((STRUCT_mPROCP(argv[0], + Scheme_Object *v = argv[0]; + if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); + return ((STRUCT_mPROCP(v, SCHEME_PRIM_OTHER_TYPE_MASK, SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER) - && SAME_TYPE(SCHEME_TYPE(SCHEME_PRIM_CLOSURE_ELS(argv[0])[0]), scheme_chaperone_property_type)) + && SAME_TYPE(SCHEME_TYPE(SCHEME_PRIM_CLOSURE_ELS(v)[0]), scheme_chaperone_property_type)) ? scheme_true : scheme_false); } @@ -2779,6 +2791,9 @@ static Scheme_Object *make_struct_field_xxor(const char *who, int getter, char digitbuf[20]; int fieldstrlen; + /* We don't allow chaperones on the getter or setter procedure, because we + can't preserve them in the generated procedure. */ + if (!STRUCT_mPROCP(argv[0], SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK, SCHEME_PRIM_IS_STRUCT_OTHER | (getter @@ -4564,8 +4579,10 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv) props = scheme_parse_chaperone_props("chaperone-box", i, argc, argv); break; } + a[0] = proc; + if (SCHEME_CHAPERONEP(proc)) proc = SCHEME_CHAPERONE_VAL(proc); if (SCHEME_TRUEP(struct_setter_p(1, a))) { kind = "mutator"; offset = stype->num_slots; @@ -4589,7 +4606,7 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv) if (si_chaperone) scheme_raise_exn(MZEXN_FAIL_CONTRACT, "chaperone-struct: struct-info procedure supplied a second time: %V", - proc); + a[0]); pi = NULL; prop = NULL; arity = 2; @@ -4601,7 +4618,7 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv) scheme_raise_exn(MZEXN_FAIL_CONTRACT, "chaperone-struct: %s %V does not apply to given object: %V", kind, - proc, + a[0], argv[0]); if (!red_props) red_props = scheme_make_hash_tree(0); @@ -4610,7 +4627,7 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv) scheme_raise_exn(MZEXN_FAIL_CONTRACT, "chaperone-struct: given %s is for the same property as a previous %s argument: %V", kind, kind, - proc); + a[0]); arity = 2; } else { pi = (Struct_Proc_Info *)((Scheme_Primitive_Closure *)proc)->val[0]; @@ -4620,13 +4637,13 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv) scheme_raise_exn(MZEXN_FAIL_CONTRACT, "chaperone-struct: %s %V does not apply to given object: %V", kind, - proc, + a[0], argv[0]); if (SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + pi->field]) scheme_raise_exn(MZEXN_FAIL_CONTRACT, "chaperone-struct: given %s is for the same field as a previous %s argument: %V", kind, kind, - proc); + a[0]); arity = 2; } diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 796c3fa707..c14bca9f5e 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -8034,7 +8034,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, while (i != -1) { scheme_hash_tree_index(ht1, i, &key, &val); if (!SAME_OBJ((Scheme_Object *)ht1, o)) - val = scheme_chaperone_hash_traversal_get(ht1, key); + val = scheme_chaperone_hash_traversal_get(o, key); val = datum_to_syntax_inner(val, ut, stx_src, stx_wraps, ht); if (!val) return NULL; ht2 = scheme_hash_tree_set(ht2, key, val); diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index b0a952393b..f95c097f00 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -6351,13 +6351,20 @@ static Scheme_Object *extend_parameterization(int argc, Scheme_Object *argv[]) scheme_flatten_config(c); } else if (SCHEME_CONFIGP(c) && (argc & 1)) { for (i = 1; i < argc; i += 2) { - if (!SCHEME_PARAMETERP(argv[i])) { + param = argv[i]; + if (!SCHEME_PARAMETERP(param) + && !(SCHEME_CHAPERONEP(param) && SCHEME_PARAMETERP(SCHEME_CHAPERONE_VAL(param)))) { scheme_wrong_type("parameterize", "parameter", i, argc, argv); return NULL; } - a[0] = argv[i + 1]; + key = argv[i + 1]; + if (SCHEME_CHAPERONEP(param)) { + a[0] = key; + key = scheme_apply_chaperone(param, 1, a, scheme_void); + param = SCHEME_CHAPERONE_VAL(param); + } + a[0] = key; a[1] = scheme_false; - param = argv[i]; while (1) { if (SCHEME_PRIMP(param)) { Scheme_Prim *proc; @@ -6421,6 +6428,8 @@ static Scheme_Object *parameter_p(int argc, Scheme_Object **argv) { Scheme_Object *v = argv[0]; + if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); + return (SCHEME_PARAMETERP(v) ? scheme_true : scheme_false); @@ -6509,7 +6518,7 @@ static Scheme_Object *make_derived_parameter(int argc, Scheme_Object **argv) ParamData *data; if (!SCHEME_PARAMETERP(argv[0])) - scheme_wrong_type("make-derived-parameter", "parameter", 0, argc, argv); + scheme_wrong_type("make-derived-parameter", "unchaperoned parameter", 0, argc, argv); scheme_check_proc_arity("make-derived-parameter", 1, 1, argc, argv); scheme_check_proc_arity("make-derived-parameter", 1, 2, argc, argv); @@ -6537,6 +6546,9 @@ static Scheme_Object *parameter_procedure_eq(int argc, Scheme_Object **argv) a = argv[0]; b = argv[1]; + if (SCHEME_CHAPERONEP(a)) a = SCHEME_CHAPERONE_VAL(a); + if (SCHEME_CHAPERONEP(b)) b = SCHEME_CHAPERONE_VAL(b); + if (!SCHEME_PARAMETERP(a)) scheme_wrong_type("parameter-procedure=?", "parameter-procedure", 0, argc, argv); if (!SCHEME_PARAMETERP(b))