From a181011b553f2ae6ee559d96c3e5edac8266adfc Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Mon, 11 Jun 2012 21:04:45 -0400 Subject: [PATCH] Check for proxied prompt tags when needed Fixes a bug where some control operators would not recognize proxied prompt tags (non-proxied were fine) --- collects/tests/racket/prompt.rktl | 28 +++++++++ src/racket/src/fun.c | 97 +++++++++++++++++++++---------- 2 files changed, 94 insertions(+), 31 deletions(-) diff --git a/collects/tests/racket/prompt.rktl b/collects/tests/racket/prompt.rktl index 1fd43d5ef3..7e29f71b61 100644 --- a/collects/tests/racket/prompt.rktl +++ b/collects/tests/racket/prompt.rktl @@ -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) diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index ba15177d07..3762b3fa39 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -4611,8 +4611,12 @@ call_cc (int argc, Scheme_Object *argv[]) 0, argc, argv); if (argc > 1) { if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[1]))) { - scheme_wrong_contract("call-with-current-continuation", "continuation-prompt-tag?", - 1, argc, argv); + 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,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); if (argc > 1) { if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[1]))) { - scheme_wrong_contract("call-with-composable-continuation", "continuation-prompt-tag?", - 1, argc, argv); - } - prompt_tag = 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]))) { - scheme_wrong_contract("current-continuation-marks", "continuation-prompt-tag?", - 0, argc, argv); + 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,10 +7007,14 @@ cont_marks(int argc, Scheme_Object *argv[]) if (argc > 1) { if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[1]))) { - scheme_wrong_contract("continuation-marks", "continuation-prompt-tag?", - 1, argc, argv); - } - prompt_tag = 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,10 +7093,14 @@ extract_cc_marks(int argc, Scheme_Object *argv[]) } if (argc > 2) { if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[2]))) { - scheme_wrong_contract("continuation-mark-set->list", "continuation-prompt-tag?", - 2, argc, argv); - } - prompt_tag = 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,10 +7157,14 @@ 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]))) { - scheme_wrong_contract("continuation-mark-set->list*", "continuation-prompt-tag?", - 3, argc, argv); - } - prompt_tag = 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,10 +7533,14 @@ extract_one_cc_mark(int argc, Scheme_Object *argv[]) if (argc > 3) { if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[3]))) { - scheme_wrong_contract("continuation-mark-set-first", "continuation-prompt-tag?", - 3, argc, argv); - } - prompt_tag = 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)) { if (SCHEME_FALSEP(argv[0])) { @@ -7553,8 +7584,12 @@ 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))) { - scheme_wrong_contract("continuation-prompt-available?", "continuation-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("continuation-prompt-available?", "continuation-prompt-tag?", + 0, argc, argv); } if (argc > 1) {