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:
parent
87ecb55d40
commit
a181011b55
|
@ -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)
|
||||
|
|
|
@ -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);
|
||||
}
|
||||
|
|
Loading…
Reference in New Issue
Block a user