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

Check for proxied prompt tags when needed

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -205,6 +205,15 @@
tag tag
(lambda x x))) (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) do-test imp-tag 5)
(test '(12 14) do-test imp-tag-2 5 6) (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-2 5) exn:fail?)
@ -214,6 +223,25 @@
(err/rt-test (do-test cha-tag "bad") exn:fail?) (err/rt-test (do-test cha-tag "bad") exn:fail?)
(err/rt-test (do-test bad-tag 5) 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) (report-errs)

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

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