From 8e46e46d40049409b944add2245d3307bc4e0fe4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 20 Nov 2015 09:27:05 -0700 Subject: [PATCH] add more support for continuation marks in procedure impersonators Allow a more dynamic (than `impersonator-prop:application-mark`) determination of continuation marks and associated values to wrap the call of an impersonated procedure. --- .../scribblings/reference/chaperones.scrbl | 37 +++-- .../tests/racket/chaperone.rktl | 137 ++++++++++++++- racket/collects/racket/private/kw.rkt | 19 ++- racket/src/racket/src/fun.c | 156 ++++++++++++++---- racket/src/racket/src/schpriv.h | 3 + racket/src/racket/src/thread.c | 16 +- 6 files changed, 311 insertions(+), 57 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/chaperones.scrbl b/pkgs/racket-doc/scribblings/reference/chaperones.scrbl index 747835735c..cf5ae09818 100644 --- a/pkgs/racket-doc/scribblings/reference/chaperones.scrbl +++ b/pkgs/racket-doc/scribblings/reference/chaperones.scrbl @@ -191,18 +191,31 @@ required keyword arguments of @racket[wrapper-proc] must be a subset of the required keywords of @racket[proc]. For applications without keywords, the result of @racket[wrapper-proc] -must be either the same number of values as supplied to it or one more -than the number of supplied values, where an extra result is supplied -before the others. The additional result, if any, must be a procedure +must be at least the same number of values as supplied to it. +Additional results can be supplied---before the values that correspond +to the supplied values---in the following pattern: + +@itemlist[ + + @item{An optional procedure, @racket[_result-wrapper-proc], which + will be applied to the results of @racket[proc]; followed by} + + @item{any number of repetitions of @racket['mark _key _val] (i.e., + three values), where the call @racket[_proc] is wrapped to + install a @tech{continuation mark} @racket[_key] and @racket[_val].} + +] + +If @racket[_result-wrapper-proc] is produced, it must be a procedure that accepts as many results as produced by @racket[proc]; it must -return the same number of results. If @racket[wrapper-proc] returns -the same number of values as it is given (i.e., it does not return a -procedure to impersonator @racket[proc]'s result), then @racket[proc] is -called in @tech{tail position} with respect to the call to the impersonator. +return the same number of results. If @racket[_result-wrapper-proc] is +not supplied, then @racket[proc] is called in @tech{tail position} +with respect to the call to the impersonator. For applications that include keyword arguments, @racket[wrapper-proc] -must return an additional value before any other values but after the -result-impersonating procedure (if any). The additional value must be a +must return an additional value before any other values but after +@racket[_result-wrapper-proc] and @racket['mark _key _val] +sequences (if any). The additional value must be a list of replacements for the keyword arguments that were supplied to the impersonator (i.e., not counting optional arguments that were not supplied). The arguments must be ordered according to the sorted @@ -229,7 +242,11 @@ for @racket[(car prop-val)] in the call's continuation---then the value is also installed as an immediate value for @racket[(car prop-val)] as a mark during the call to @racket[wrapper-proc] (which allows tail-calls of impersonators with respect to wrapping impersonators to be detected within -@racket[wrapper-proc]).} +@racket[wrapper-proc]). + +@history[#:changed "6.3.0.5" @elem{Added support for @racket['mark + _key _val] results from + @racket[wrapper-proc].}]} @defproc[(impersonate-procedure* [proc procedure?] [wrapper-proc (or/c procedure? #f)] diff --git a/pkgs/racket-test-core/tests/racket/chaperone.rktl b/pkgs/racket-test-core/tests/racket/chaperone.rktl index 482e62d849..ddee10417e 100644 --- a/pkgs/racket-test-core/tests/racket/chaperone.rktl +++ b/pkgs/racket-test-core/tests/racket/chaperone.rktl @@ -348,6 +348,28 @@ (test (vector 1110 1111) values in) (check-proc-prop f mk))) +;; Single argument, no post filter, set continuation mark: +(as-chaperone-or-impersonator + ([chaperone-procedure impersonate-procedure + chaperone-procedure** + impersonate-procedure**]) + (let* ([f (lambda (x) (list x (continuation-mark-set-first #f 'the-mark)))] + [in #f] + [mk (lambda (f) + (chaperone-procedure + f + (lambda (x) + (set! in x) + (values 'mark 'the-mark 8 x))))] + [f2 (mk f)]) + (with-continuation-mark 'the-mark + 7 + (test '(110 7) f 110)) + (test #f values in) + (test '(111 8) f2 111) + (test 111 values in) + (check-proc-prop f mk))) + ;; Single argument, post filter on single value: (as-chaperone-or-impersonator ([chaperone-procedure impersonate-procedure @@ -400,6 +422,42 @@ (test (vector 'b '(a c)) values out) (check-proc-prop f mk))) +;; Multiple arguments, post filter on multiple values +;; and set multiple continuation marks: +(as-chaperone-or-impersonator + ([chaperone-procedure impersonate-procedure + chaperone-procedure** + impersonate-procedure**]) + (let* ([f (lambda (x y z) (values y (list x z + (continuation-mark-set-first #f 'the-mark) + (continuation-mark-set-first #f 'the-other-mark))))] + [in #f] + [out #f] + [mk (lambda (f) + (chaperone-procedure + f + (lambda (x y z) + (set! in (vector x y z)) + (values (lambda (y z) + (set! out (vector y z)) + (values y z)) + 'mark 'the-mark 88 + 'mark 'the-other-mark 86 + x y z))))] + [f2 (mk f)]) + (with-continuation-mark 'the-mark + 77 + (with-continuation-mark 'the-other-mark + 79 + (begin + (test-values '(b (a c 77 79)) (lambda () (f 'a 'b 'c))) + (test #f values in) + (test #f values out) + (test-values '(b (a c 88 86)) (lambda () (f2 'a 'b 'c))) + (test (vector 'a 'b 'c) values in) + (test (vector 'b '(a c 88 86)) values out) + (check-proc-prop f mk)))))) + ;; Optional keyword arguments: (as-chaperone-or-impersonator ([chaperone-procedure impersonate-procedure @@ -432,6 +490,43 @@ (test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2))) (check-proc-prop f mk))) +;; Optional keyword arguments with mark: +(as-chaperone-or-impersonator + ([chaperone-procedure impersonate-procedure + chaperone-procedure**/kw + impersonate-procedure**/kw]) + (let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b (continuation-mark-set-first #f 'the-mark)))] + [in #f] + [mk (lambda (f) + (chaperone-procedure + f + (lambda (x #:a [a 'nope] #:b [b 'nope]) + (if (and (eq? a 'nope) (eq? b 'nope)) + (values 'mark 'the-mark 8 + x) + (values + 'mark 'the-mark 8 + (append + (if (eq? a 'nope) null (list a)) + (if (eq? b 'nope) null (list b))) + x)))))] + [f2 (mk f)]) + (with-continuation-mark 'the-mark + 7 + (begin + (test '(1 a b 7) f 1) + (test '(1 a b 8) f2 1) + (test '(1 2 b 7) f 1 #:a 2) + (test '(1 2 b 8) f2 1 #:a 2) + (test '(1 a 3 7) f 1 #:b 3) + (test '(1 a 3 8) f2 1 #:b 3) + (test '(1 2 3 7) f 1 #:a 2 #:b 3) + (test '(1 2 3 8) f2 1 #:a 2 #:b 3) + (test 1 procedure-arity f2) + (test 'f object-name f2) + (test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2))) + (check-proc-prop f mk))))) + ;; Optional keyword arguments with result chaperone: (as-chaperone-or-impersonator ([chaperone-procedure impersonate-procedure @@ -502,7 +597,7 @@ (test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2))) (check-proc-prop f mk))) -;; Required keyword arguments: +;; Required keyword arguments with result chaperone: (as-chaperone-or-impersonator ([chaperone-procedure impersonate-procedure chaperone-procedure**/kw @@ -538,6 +633,46 @@ (test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2))) (check-proc-prop f mk))) +;; Required keyword arguments with result chaperone and marks: +(as-chaperone-or-impersonator + ([chaperone-procedure impersonate-procedure + chaperone-procedure**/kw + impersonate-procedure**/kw]) + (let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b (continuation-mark-set-first #f 'the-mark)))] + [in #f] + [out #f] + [mk (lambda (f) + (chaperone-procedure + f + (lambda (x #:a [a 'nope] #:b [b 'nope]) + (set! in (list x a b)) + (if (and (eq? a 'nope) (eq? b 'nope)) + x + (values + (lambda (z) (set! out z) z) + 'mark 'the-mark 9 + (append + (if (eq? a 'nope) null (list a)) + (if (eq? b 'nope) null (list b))) + x)))))] + [f2 (mk f)]) + (with-continuation-mark 'the-mark + 7 + (begin + (err/rt-test (f 1)) + (err/rt-test (f2 1)) + (err/rt-test (f 1 #:a 2)) + (err/rt-test (f2 1 #:a 2)) + (test '(1 a 3 7) f 1 #:b 3) + (test '(1 a 3 9) f2 1 #:b 3) + (test '((1 nope 3) (1 a 3 9)) list in out) + (test '(1 2 3 7) f 1 #:a 2 #:b 3) + (test '(1 2 3 9) f2 1 #:a 2 #:b 3) + (test 1 procedure-arity f2) + (test 'f object-name f2) + (test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2))) + (check-proc-prop f mk))))) + (err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y))) 1)) (err/rt-test ((impersonate-procedure (lambda (x) x) (lambda (y) (values y y))) 1)) (err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y y))) 1)) diff --git a/racket/collects/racket/private/kw.rkt b/racket/collects/racket/private/kw.rkt index 98a85577f3..14eef699e8 100644 --- a/racket/collects/racket/private/kw.rkt +++ b/racket/collects/racket/private/kw.rkt @@ -1611,16 +1611,15 @@ (lambda results (let* ([len (length results)] [alen (length rest)]) - (unless (<= (+ alen 1) len (+ alen 2)) + (when (< len (+ alen 1)) (raise-arguments-error '|keyword procedure chaperone| "wrong number of results from wrapper procedure" "expected minimum number of results" (+ alen 1) - "expected maximum number of results" (+ alen 2) "received number of results" len "wrapper procedure" wrap-proc)) - (let ([extra? (= len (+ alen 2))]) - (let ([new-args ((if extra? cadr car) results)]) + (let ([num-extra (- len (+ alen 1))]) + (let ([new-args (list-ref results num-extra)]) (unless (and (list? new-args) (= (length new-args) (length args))) (raise-arguments-error @@ -1629,7 +1628,7 @@ "expected a list of keyword-argument values as first result~a from wrapper procedure" (if (= len alen) "" - " (after the result-wrapper procedure)")) + " (after the result-wrapper procedure or mark specifications)")) "first result" new-args "wrapper procedure" wrap-proc)) (for-each @@ -1646,9 +1645,13 @@ kws new-args args)) - (if extra? - (apply values (car results) kws (cdr results)) - (apply values kws results))))))] + (case num-extra + [(0) (apply values kws results)] + [(1) (apply values (car results) kws (cdr results))] + [else (apply values (let loop ([results results] [c num-extra]) + (if (zero? c) + (cons kws results) + (cons (car results) (loop (cdr results) (sub1 c))))))])))))] ;; The following case exists only to make sure that the arity of ;; any procedure passed to `make-keyword-args' is covered ;; by this procedure's arity. diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index 540d03fb97..4e88cca8ac 100644 --- a/racket/src/racket/src/fun.c +++ b/racket/src/racket/src/fun.c @@ -104,6 +104,7 @@ ROSYM static Scheme_Object *is_method_symbol; ROSYM static Scheme_Object *cont_key; /* uninterned */ ROSYM static Scheme_Object *barrier_prompt_key; /* uninterned */ ROSYM static Scheme_Object *prompt_cc_guard_key; /* uninterned */ +ROSYM static Scheme_Object *mark_symbol; READ_ONLY static Scheme_Prompt *original_default_prompt; /* for escapes, represents the implicit initial prompt */ READ_ONLY static Scheme_Object *call_with_prompt_proc; READ_ONLY static Scheme_Object *abort_continuation_proc; @@ -676,6 +677,9 @@ scheme_init_fun (Scheme_Env *env) barrier_prompt_key = scheme_make_symbol("bar"); /* uninterned */ prompt_cc_guard_key = scheme_make_symbol("cc"); /* uninterned */ + REGISTER_SO(mark_symbol); + mark_symbol = scheme_intern_symbol("mark"); + REGISTER_SO(scheme_default_prompt_tag); { Scheme_Object *a[1]; @@ -3591,6 +3595,104 @@ Scheme_Object *_scheme_apply_native(Scheme_Object *obj, int num_rands, Scheme_Ob return _apply_native(obj, num_rands, rands); } +Scheme_Object *extract_impersonator_results(int c, int argc, Scheme_Object **argv2, + const char *what, Scheme_Object *o, + Scheme_Chaperone *px, + Scheme_Cont_Frame_Data *cframe, int *_need_pop) +{ + int extra = c - argc; + int i, fail_reason = 0; + Scheme_Object *post; + char nth[32]; + Scheme_Config *config = NULL; + + if (!extra) + return NULL; + + post = NULL; + for (i = 0; i < extra; ) { + if (!i && SCHEME_PROCP(argv2[0])) { + post = argv2[i]; + i++; + } else if (SAME_OBJ(argv2[i], mark_symbol)) { + if (i + 3 > extra) { + fail_reason = 2; + break; + } + if (post && !*_need_pop) { + scheme_push_continuation_frame(cframe); + *_need_pop = 1; + } + scheme_set_cont_mark(argv2[i+1], argv2[i+2]); + i += 3; + } else { + fail_reason = 1; + break; + } + } + + if (!fail_reason) { + if (config) { + if (post && !*_need_pop) { + scheme_push_continuation_frame(cframe); + *_need_pop = 1; + } + scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); + } + return post; + } + + /* Failure at argument i */ + + switch (i % 10) { + case 1: + sprintf(nth, "%dst", i); + break; + case 2: + sprintf(nth, "%dnd", i); + break; + case 3: + sprintf(nth, "%drd", i); + break; + default: + sprintf(nth, "%dth", i); + } + + if (fail_reason == 1) { + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "procedure %s: wrapper's %s result is not valid;\n" + " %s extra result (before original argument count) should be\n" + " 'mark%s'parameter%s\n" + " original: %V\n" + " wrapper: %V\n" + " received: %V", + what, + nth, + nth, + (i ? " or " : ", "), + (i ? "" : ", or a wrapper for the original procedure's result"), + o, + SCHEME_VEC_ELS(px->redirects)[0], + argv2[i]); + } else if (fail_reason == 2) { + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "procedure %s: wrapper's %s result needs addition extra results;\n" + " %s extra result (before original argument count) needs an\n" + " additional %s after %V\n" + " original: %V\n" + " wrapper: %V", + what, + nth, + nth, + ((i + 1 < extra) ? "result" : "two results"), + argv2[i], + o, + SCHEME_VEC_ELS(px->redirects)[0]); + } + + return NULL; +} + /* must be at least 3: */ #define MAX_QUICK_CHAP_ARGV 5 @@ -3736,13 +3838,16 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object MZ_CONT_MARK_POS += 2; scheme_pop_continuation_frame(&cframe); } - - if ((c == argc) || (c == (argc + 1))) { - if (c > argc) { - post = argv2[0]; - memmove(argv2, argv2 + 1, sizeof(Scheme_Object*)*argc); - } else - post = NULL; + + if (c >= argc) { + int need_pop = 0; + post = extract_impersonator_results(c, argc, argv2, + what, o, px, + &cframe, &need_pop); + need_pop_mark = need_pop; + + if (c > argc) + memmove(argv2, argv2 + (c - argc), sizeof(Scheme_Object*)*argc); if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) { for (i = 0; i < argc; i++) { if (!SAME_OBJ(argv2[i], argv[i]) @@ -3764,12 +3869,12 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object " procedure's arguments\n" " original: %V\n" " wrapper: %V\n" - " expected: %d or %d\n" + " expected: %d or more\n" " received: %d", what, o, SCHEME_VEC_ELS(px->redirects)[0], - argc, argc + 1, + argc, c); return NULL; } @@ -3784,7 +3889,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object } else argv = NULL; - if (c == argc) { + if (!post) { /* No filter for the result, so tail call: */ if (app_mark) scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark)); @@ -3794,7 +3899,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object } if (auto_val) { if (SCHEME_CHAPERONEP(px->prev)) - return do_apply_chaperone(px->prev, c, argv2, auto_val, 0); + return do_apply_chaperone(px->prev, argc, argv2, auto_val, 0); else return argv2[0]; } else { @@ -3807,40 +3912,29 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object /* cannot return a tail call */ MZ_CONT_MARK_POS -= 2; if (checks & 0x1) { - v = _scheme_apply(orig_obj, c, argv2); + v = _scheme_apply(orig_obj, argc, argv2); } else if (SAME_TYPE(SCHEME_TYPE(orig_obj), scheme_native_closure_type)) { - v = _apply_native(orig_obj, c, argv2); + v = _apply_native(orig_obj, argc, argv2); } else { - v = _scheme_apply_multi(orig_obj, c, argv2); + v = _scheme_apply_multi(orig_obj, argc, argv2); } MZ_CONT_MARK_POS += 2; return v; } else - return scheme_tail_apply(orig_obj, c, argv2); + return scheme_tail_apply(orig_obj, argc, argv2); } } else { - /* First element is a filter for the result(s) */ - if (!SCHEME_PROCP(post)) - scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "procedure %s: wrapper's first result is not a procedure;\n" - " extra result compared to original argument count should be\n" - " a wrapper for the original procedure's result\n" - " original: %V\n" - " wrapper: %V\n" - " received: %V", - what, - o, - SCHEME_VEC_ELS(px->redirects)[0], - post); - if (app_mark) { - scheme_push_continuation_frame(&cframe); + if (!need_pop_mark) + scheme_push_continuation_frame(&cframe); scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark)); - MZ_CONT_MARK_POS -= 2; need_pop_mark = 1; }else need_pop_mark = 0; + if (need_pop_mark) + MZ_CONT_MARK_POS -= 2; + if (SCHEME_CHAPERONEP(px->prev)) { /* commuincate `self_proc` to the next layer: */ scheme_current_thread->self_for_proc_chaperone = self_proc; diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 867a918645..3f7c44a964 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -831,6 +831,9 @@ extern Scheme_Object *scheme_parameterization_key; extern Scheme_Object *scheme_exn_handler_key; extern Scheme_Object *scheme_break_enabled_key; +Scheme_Object *scheme_extend_parameterization(int argc, Scheme_Object *args[]); +XFORM_NONGCING int scheme_is_parameter(Scheme_Object *o); + extern void scheme_flatten_config(Scheme_Config *c); extern Scheme_Object *scheme_apply_thread_thunk(Scheme_Object *rator); diff --git a/racket/src/racket/src/thread.c b/racket/src/racket/src/thread.c index 3fedeaea0c..80c0c8b4c6 100644 --- a/racket/src/racket/src/thread.c +++ b/racket/src/racket/src/thread.c @@ -391,7 +391,6 @@ static Scheme_Object *parameter_p(int argc, Scheme_Object *args[]); static Scheme_Object *parameter_procedure_eq(int argc, Scheme_Object *args[]); static Scheme_Object *make_parameter(int argc, Scheme_Object *args[]); static Scheme_Object *make_derived_parameter(int argc, Scheme_Object *args[]); -static Scheme_Object *extend_parameterization(int argc, Scheme_Object *args[]); static Scheme_Object *parameterization_p(int argc, Scheme_Object *args[]); static Scheme_Object *reparameterize(int argc, Scheme_Object **argv); @@ -708,7 +707,7 @@ void scheme_init_paramz(Scheme_Env *env) scheme_add_global_constant("parameterization-key" , scheme_parameterization_key, newenv); scheme_add_global_constant("break-enabled-key" , scheme_break_enabled_key , newenv); - GLOBAL_PRIM_W_ARITY("extend-parameterization" , extend_parameterization , 1, -1, newenv); + GLOBAL_PRIM_W_ARITY("extend-parameterization" , scheme_extend_parameterization , 1, -1, newenv); GLOBAL_PRIM_W_ARITY("check-for-break" , check_break_now , 0, 0, newenv); GLOBAL_PRIM_W_ARITY("reparameterize" , reparameterize , 1, 1, newenv); GLOBAL_PRIM_W_ARITY("make-custodian-from-main", make_custodian_from_main, 0, 0, newenv); @@ -7633,7 +7632,7 @@ static Scheme_Object *parameterization_p(int argc, Scheme_Object **argv) && ((((Scheme_Primitive_Proc *)v)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK) \ == SCHEME_PRIM_TYPE_PARAMETER)) -static Scheme_Object *extend_parameterization(int argc, Scheme_Object *argv[]) +Scheme_Object *scheme_extend_parameterization(int argc, Scheme_Object *argv[]) { Scheme_Object *key, *a[2], *param; Scheme_Config *c; @@ -7719,13 +7718,16 @@ static Scheme_Object *reparameterize(int argc, Scheme_Object **argv) return (Scheme_Object *)naya; } -static Scheme_Object *parameter_p(int argc, Scheme_Object **argv) +int scheme_is_parameter(Scheme_Object *v) { - Scheme_Object *v = argv[0]; - if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); - return (SCHEME_PARAMETERP(v) + return SCHEME_PARAMETERP(v); +} + +static Scheme_Object *parameter_p(int argc, Scheme_Object **argv) +{ + return (scheme_is_parameter(argv[0]) ? scheme_true : scheme_false); }