Check for proxied prompt tags when needed

Fixes a bug where some control operators would
not recognize proxied prompt tags (non-proxied were fine)
This commit is contained in:
Asumu Takikawa 2012-06-11 21:04:45 -04:00
parent 87ecb55d40
commit a181011b55
2 changed files with 94 additions and 31 deletions

View File

@ -205,6 +205,15 @@
tag
(lambda x x)))
(define (in-prompt tag k . vs)
(call-with-continuation-prompt
(lambda () (apply k vs))
tag))
;; make sure proxied tags are still tags
(test #t continuation-prompt-tag? imp-tag)
;; make sure proxies do the right thing
(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?)
@ -214,6 +223,25 @@
(err/rt-test (do-test cha-tag "bad") exn:fail?)
(err/rt-test (do-test bad-tag 5) exn:fail?)
;; sanity checks
(test 5 in-prompt imp-tag call/cc (lambda (k) (k 5)) imp-tag)
(test 5 in-prompt imp-tag
call-with-composable-continuation
(lambda (k) (k 5))
imp-tag)
(test #t in-prompt imp-tag
continuation-prompt-available? imp-tag)
(call-with-continuation-prompt
(lambda ()
(with-continuation-mark 'mark 'val
(test
'val
(compose (lambda (s) (continuation-mark-set-first s 'mark))
current-continuation-marks)
imp-tag)))
imp-tag)
;;----------------------------------------
(report-errs)

View File

@ -4611,6 +4611,10 @@ call_cc (int argc, Scheme_Object *argv[])
0, argc, argv);
if (argc > 1) {
if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[1]))) {
if (SCHEME_NP_CHAPERONEP(argv[1])
&& SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[1])))
argv[1] = SCHEME_CHAPERONE_VAL(argv[1]);
else
scheme_wrong_contract("call-with-current-continuation", "continuation-prompt-tag?",
1, argc, argv);
}
@ -6607,9 +6611,13 @@ static Scheme_Object *do_call_with_control (int argc, Scheme_Object *argv[], int
scheme_check_proc_arity("call-with-composable-continuation", 1, 0, argc, argv);
if (argc > 1) {
if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[1]))) {
if (SCHEME_NP_CHAPERONEP(argv[1])
&& SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[1])))
prompt_tag = SCHEME_CHAPERONE_VAL(argv[1]);
else
scheme_wrong_contract("call-with-composable-continuation", "continuation-prompt-tag?",
1, argc, argv);
}
} else
prompt_tag = argv[1];
} else
prompt_tag = scheme_default_prompt_tag;
@ -6964,21 +6972,28 @@ Scheme_Object *scheme_all_current_continuation_marks()
static Scheme_Object *
cc_marks(int argc, Scheme_Object *argv[])
{
Scheme_Object *prompt_tag;
if (argc) {
if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[0]))) {
prompt_tag = argv[0];
if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(prompt_tag))) {
if (SCHEME_NP_CHAPERONEP(prompt_tag)
&& SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(prompt_tag)))
prompt_tag = SCHEME_CHAPERONE_VAL(prompt_tag);
else
scheme_wrong_contract("current-continuation-marks", "continuation-prompt-tag?",
0, argc, argv);
}
if (!SAME_OBJ(scheme_default_prompt_tag, argv[0]))
if (!scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(argv[0])))
if (!SAME_OBJ(scheme_default_prompt_tag, prompt_tag))
if (!scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag)))
scheme_contract_error("current-continuation-marks",
"no corresponding prompt in the continuation",
"prompt tag", 1, argv[0],
"prompt tag", 1, prompt_tag,
NULL);
}
return scheme_current_continuation_marks(argc ? argv[0] : NULL);
return scheme_current_continuation_marks(argc ? prompt_tag : NULL);
}
static Scheme_Object *
@ -6992,9 +7007,13 @@ cont_marks(int argc, Scheme_Object *argv[])
if (argc > 1) {
if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[1]))) {
if (SCHEME_NP_CHAPERONEP(argv[1])
&& SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[1])))
prompt_tag = SCHEME_CHAPERONE_VAL(argv[1]);
else
scheme_wrong_contract("continuation-marks", "continuation-prompt-tag?",
1, argc, argv);
}
} else
prompt_tag = argv[1];
} else
prompt_tag = scheme_default_prompt_tag;
@ -7074,9 +7093,13 @@ extract_cc_marks(int argc, Scheme_Object *argv[])
}
if (argc > 2) {
if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[2]))) {
if (SCHEME_NP_CHAPERONEP(argv[2])
&& SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[2])))
prompt_tag = SCHEME_CHAPERONE_VAL(argv[2]);
else
scheme_wrong_contract("continuation-mark-set->list", "continuation-prompt-tag?",
2, argc, argv);
}
} else
prompt_tag = argv[2];
} else
prompt_tag = scheme_default_prompt_tag;
@ -7134,9 +7157,13 @@ extract_cc_markses(int argc, Scheme_Object *argv[])
none = scheme_false;
if (argc > 3) {
if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[3]))) {
if (SCHEME_NP_CHAPERONEP(argv[3])
&& SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[3])))
prompt_tag = SCHEME_CHAPERONE_VAL(argv[3]);
else
scheme_wrong_contract("continuation-mark-set->list*", "continuation-prompt-tag?",
3, argc, argv);
}
} else
prompt_tag = argv[3];
} else
prompt_tag = scheme_default_prompt_tag;
@ -7506,9 +7533,13 @@ extract_one_cc_mark(int argc, Scheme_Object *argv[])
if (argc > 3) {
if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[3]))) {
if (SCHEME_NP_CHAPERONEP(argv[3])
&& SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[3])))
prompt_tag = SCHEME_CHAPERONE_VAL(argv[3]);
else
scheme_wrong_contract("continuation-mark-set-first", "continuation-prompt-tag?",
3, argc, argv);
}
} else
prompt_tag = argv[3];
if (!SAME_OBJ(scheme_default_prompt_tag, prompt_tag)) {
@ -7553,6 +7584,10 @@ static Scheme_Object *continuation_prompt_available(int argc, Scheme_Object *arg
prompt_tag = argv[0];
if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(prompt_tag))) {
if (SCHEME_NP_CHAPERONEP(prompt_tag)
&& SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(prompt_tag)))
prompt_tag = SCHEME_CHAPERONE_VAL(prompt_tag);
else
scheme_wrong_contract("continuation-prompt-available?", "continuation-prompt-tag?",
0, argc, argv);
}