From 5aa76c27a9e5742c11035bcc054d361d1d22ddce Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Mon, 11 Jun 2012 15:45:39 -0400 Subject: [PATCH] Support multiple values for control proxy functions --- collects/racket/contract/private/misc.rkt | 35 ++++-- collects/tests/racket/contract-test.rktl | 22 ++++ collects/tests/racket/prompt.rktl | 33 +++++- src/racket/src/fun.c | 129 ++++++++++++---------- 4 files changed, 146 insertions(+), 73 deletions(-) diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt index bd8d93a29a..7c33b0b141 100644 --- a/collects/racket/contract/private/misc.rkt +++ b/collects/racket/contract/private/misc.rkt @@ -946,19 +946,31 @@ (define/final-prop none/c (make-none/c 'none/c)) ;; prompt/c -(define/subexpression-pos-prop (prompt/c ctc-arg) - (define ctc (coerce-contract 'prompt/c ctc-arg)) - (cond [(chaperone-contract? ctc) (chaperone-prompt/c ctc)] - [else (impersonator-prompt/c ctc)])) +(define/subexpression-pos-prop (prompt/c . ctc-args) + (define ctcs + (map (λ (ctc-arg) + (coerce-contract 'prompt/c ctc-arg)) + ctc-args)) + (cond [(andmap chaperone-contract? ctcs) (chaperone-prompt/c ctcs)] + [else (impersonator-prompt/c ctcs)])) (define (prompt/c-name ctc) - (build-compound-type-name 'prompt/c (base-prompt/c-ctc ctc))) + (apply build-compound-type-name + (cons 'prompt/c (base-prompt/c-ctcs ctc)))) (define ((prompt/c-proj proxy) ctc) - (define ho-proj (contract-projection (base-prompt/c-ctc ctc))) + (define ho-projs (map contract-projection (base-prompt/c-ctcs ctc))) (λ (blame) - (define proj1 (ho-proj blame)) - (define proj2 (ho-proj (blame-swap blame))) + (define proj1 + (λ vs + (define vs2 (for/list ([proj ho-projs] [v vs]) + ((proj blame) v))) + (apply values vs2))) + (define proj2 + (λ vs + (define vs2 (for/list ([proj ho-projs] [v vs]) + ((proj (blame-swap blame)) v))) + (apply values vs2))) (λ (val) (unless (contract-first-order-passes? ctc val) (raise-blame-error @@ -973,10 +985,11 @@ (define (prompt/c-stronger? this that) (and (base-prompt/c? that) - (contract-stronger? (base-prompt/c-ctc this) - (base-prompt/c-ctc that)))) + (andmap (λ (this that) (contract-stronger? this that)) + (base-prompt/c-ctcs this) + (base-prompt/c-ctcs that)))) -(define-struct base-prompt/c (ctc)) +(define-struct base-prompt/c (ctcs)) (define-struct (chaperone-prompt/c base-prompt/c) () #:property prop:chaperone-contract diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 2b54202c78..a8dca12b04 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -4144,6 +4144,28 @@ (λ (pt) (abort-current-continuation pt (λ (v) (+ v 1)))))) "B") + (test/neg-blame + 'prompt/c-ho-6 + '(let ([pt (contract (prompt/c string? number?) + (make-continuation-prompt-tag) + 'pos + 'neg)]) + (call-with-continuation-prompt + (λ () (abort-current-continuation pt 3 "bad")) + pt + (λ (x y) (values x y))))) + + (test/spec-passed + 'prompt/c-ho-7 + '(let ([pt (contract (prompt/c string? number?) + (make-continuation-prompt-tag) + 'pos + 'neg)]) + (call-with-continuation-prompt + (λ () (abort-current-continuation pt "good" 5)) + pt + (λ (x y) (values x y))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; make-contract diff --git a/collects/tests/racket/prompt.rktl b/collects/tests/racket/prompt.rktl index d1fd8659d3..1fd43d5ef3 100644 --- a/collects/tests/racket/prompt.rktl +++ b/collects/tests/racket/prompt.rktl @@ -167,6 +167,24 @@ (lambda (x) (* x 2)) (lambda (x) (+ x 1)))) +(define imp-tag-2 + (impersonate-prompt-tag + (make-continuation-prompt-tag) + (lambda (x y) (values (* x 2) (* y 2))) + (lambda (x y) (values (+ x 1) (+ y 1))))) + +(define imp-tag-3 + (impersonate-prompt-tag + (make-continuation-prompt-tag) + (lambda (x y) (values (* x 2) (* y 2))) + (lambda (x y) x))) + +(define imp-tag-4 + (impersonate-prompt-tag + (make-continuation-prompt-tag) + (lambda (x y) (values x x x)) + (lambda (x y) (values x y)))) + (define cha-tag (chaperone-prompt-tag (make-continuation-prompt-tag) @@ -179,15 +197,20 @@ (lambda (x) 42) (lambda (x) x))) -(define (do-test tag v) +(define (do-test tag . rst) (call-with-continuation-prompt (lambda () - (abort-current-continuation tag v)) + (apply abort-current-continuation + (cons tag rst))) tag - (lambda (x) x))) + (lambda x x))) -(test 12 do-test imp-tag 5) -(test 5 do-test cha-tag 5) +(test '(12) do-test imp-tag 5) +(test '(12 14) do-test imp-tag-2 5 6) +(err/rt-test (do-test imp-tag-2 5) exn:fail?) +(err/rt-test (do-test imp-tag-3 10 11) exn:fail?) +(err/rt-test (do-test imp-tag-4 10 11) exn:fail?) +(test '(7) do-test cha-tag 7) (err/rt-test (do-test cha-tag "bad") exn:fail?) (err/rt-test (do-test bad-tag 5) exn:fail?) diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index ee6b122df2..ba15177d07 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -5571,8 +5571,11 @@ Scheme_Object *do_chaperone_prompt_tag (const char *name, int is_impersonator, i if (!SCHEME_PROMPT_TAGP(val)) scheme_wrong_contract(name, "prompt-tag?", 0, argc, argv); - scheme_check_proc_arity(name, 1, 1, argc, argv); - scheme_check_proc_arity(name, 1, 1, argc, argv); + + if (!SCHEME_PROCP(argv[1])) + scheme_wrong_contract(name, "procedure?", 1, argc, argv); + if (!SCHEME_PROCP(argv[2])) + scheme_wrong_contract(name, "procedure?", 2, argc, argv); redirects = scheme_make_pair(argv[1], argv[2]); @@ -6005,39 +6008,71 @@ static void prompt_unwind_one_dw(Scheme_Object *prompt_tag) prompt_unwind_dw(prompt_tag); } -static Scheme_Object **chaperone_do_prompt_handler(Scheme_Object *obj, int argc, Scheme_Object *argv[]) +static Scheme_Object **chaperone_do_control(const char *name, int is_prompt, Scheme_Object *obj, + int argc, Scheme_Object **argv) { Scheme_Chaperone *px; - Scheme_Object *a[1]; - Scheme_Object *v; Scheme_Object **vals; - - vals = MALLOC_N(Scheme_Object *, argc); + Scheme_Object *v; + Scheme_Object *proc; + int i, num_args; while (1) { - int i; if (SCHEME_PROMPT_TAGP(obj)) { return vals; } else { px = (Scheme_Chaperone *)obj; - obj = px->prev; - for (i = 0; i < argc; i++) { - a[0] = argv[i]; - v = _scheme_apply(SCHEME_CAR(px->redirects), 1, a); - vals[i] = v; + + if (is_prompt) + proc = SCHEME_CAR(px->redirects); + else + proc = SCHEME_CDR(px->redirects); + + v = _scheme_apply_multi(proc, argc, argv); + + if (v == SCHEME_MULTIPLE_VALUES) { + GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread; + if (SAME_OBJ(p->ku.multiple.array, p->values_buffer)) + p->values_buffer = NULL; + num_args = p->ku.multiple.count; + vals = p->ku.multiple.array; + } else { + num_args = 1; + vals = MALLOC_N(Scheme_Object *, 1); + vals[0] = v; } + /* + * All kinds of proxies should return the same number of results + * as the number of aborted values + */ + if (num_args == 1 && num_args != argc) + scheme_wrong_return_arity(name, argc, 1, vals[0], "application of proxy function"); + else if (num_args != argc) + scheme_wrong_return_arity(name, argc, num_args, vals, "application of proxy function"); + if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) { for (i = 0; i < argc; i++) { if (!scheme_chaperone_of(vals[i], argv[i])) - scheme_wrong_chaperoned("call-with-continuation-prompt", "value", argv[i], vals[i]); + scheme_wrong_chaperoned(name, "value", argv[i], vals[i]); + argv[i] = vals[i]; } } } } } +static Scheme_Object **chaperone_do_prompt_handler(Scheme_Object *obj, int argc, Scheme_Object **argv) +{ + return chaperone_do_control("call-with-continuation-prompt", 1, obj, argc, argv); +} + +static Scheme_Object **chaperone_do_abort(Scheme_Object *obj, int argc, Scheme_Object **argv) +{ + return chaperone_do_control("abort-current-continuation", 0, obj, argc, argv); +} + static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[]) { Scheme_Object *v; @@ -6069,6 +6104,9 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[]) scheme_check_proc_arity("call-with-continuation-prompt", argc, 0, in_argc, in_argv); if (in_argc > 1) { + /* + * Check if the prompt tag is proxied + */ if (!SCHEME_PROMPT_TAGP(in_argv[1])) { if (SCHEME_NP_CHAPERONEP(in_argv[1]) && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(in_argv[1]))) { @@ -6228,6 +6266,10 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[]) } else argv = (Scheme_Object **)p->cjs.val; + /* + * If the prompt tag is proxied, run the intercession function + * and call the handler on its results + */ if (is_chaperoned) { argv = chaperone_do_prompt_handler(in_argv[1], argc, argv); } @@ -6467,51 +6509,19 @@ Scheme_Object *scheme_compose_continuation(Scheme_Cont *cont, int num_rands, Sch return value; } -static Scheme_Object *chaperone_do_abort_one(Scheme_Object *obj, Scheme_Object *v) -{ - Scheme_Chaperone *px; - Scheme_Object *a[1]; - - while (1) { - if (SCHEME_PROMPT_TAGP(obj)) { - return v; - } else { - px = (Scheme_Chaperone *)obj; - - obj = px->prev; - a[0] = v; - v = _scheme_apply(SCHEME_CDR(px->redirects), 1, a); - - if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) - if (!scheme_chaperone_of(v, a[0])) - scheme_wrong_chaperoned("abort-current-continuation", "value", a[0], v); - } - } -} - -static Scheme_Object **chaperone_do_abort(Scheme_Object *obj, int num_args, Scheme_Object *args[]) -{ - Scheme_Object **vals; - Scheme_Object *v; - int i; - vals = MALLOC_N(Scheme_Object *, num_args); - for (i = 0; i < num_args; i++) { - v = chaperone_do_abort_one(obj, args[i]); - vals[i] = v; - } - - return vals; -} - static Scheme_Object *do_abort_continuation (int argc, Scheme_Object *argv[], int skip_dws) { Scheme_Object *prompt_tag; Scheme_Prompt *prompt; Scheme_Thread *p = scheme_current_thread; - Scheme_Object *val; + Scheme_Object *a[1]; + Scheme_Object **vals; int is_chaperoned = 0; if (!SCHEME_PROMPT_TAGP(argv[0])) { + /* + * Check if the prompt tag is proxied + */ if (SCHEME_NP_CHAPERONEP(argv[0]) && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[0]))) { is_chaperoned = 1; @@ -6537,14 +6547,19 @@ static Scheme_Object *do_abort_continuation (int argc, Scheme_Object *argv[], in if (argc == 2) { p->cjs.num_vals = 1; + /* + * If the prompt tag isn't proxied, continue with the aborted value. + * Otherwise, run the intercession function and then continue with its + * new results. + */ if (!is_chaperoned) p->cjs.val = argv[1]; else { - val = chaperone_do_abort_one(argv[0], argv[1]); - p->cjs.val = val; + a[0] = argv[1]; + vals = chaperone_do_abort(argv[0], 1, a); + p->cjs.val = (Scheme_Object *)vals[0]; } } else { - Scheme_Object **vals; int i; vals = MALLOC_N(Scheme_Object *, argc - 1); for (i = argc; i-- > 1; ) { @@ -6552,10 +6567,10 @@ static Scheme_Object *do_abort_continuation (int argc, Scheme_Object *argv[], in } p->cjs.num_vals = argc - 1; if (!is_chaperoned) - p->cjs.val = (Scheme_Object *)vals; + p->cjs.val = (Scheme_Object **)vals; else { - val = chaperone_do_abort(argv[0], argc - 1, vals); - p->cjs.val = val; + vals = chaperone_do_abort(argv[0], argc - 1, vals); + p->cjs.val = (Scheme_Object **)vals; } } p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;