suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Support multiple values for control proxy functions

Browse Source
This commit is contained in:
Asumu Takikawa 2012-06-11 15:45:39 -04:00
parent 1cce922d97
commit 5aa76c27a9
4 changed files with 146 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/racket/contract/private/misc.rkt
View File

@ -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

22
collects/tests/racket/contract-test.rktl
View File

@ -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

33
collects/tests/racket/prompt.rktl
View File

@ -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?)

129
src/racket/src/fun.c
View File

@ -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;