From c2afc03b3b2fed0b4724d1a20f4e4100ed7dc84b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 15 Jan 2011 07:49:59 -0700 Subject: [PATCH] fix interaction of `continuation-mark-set-first' and prompts including a documentation fix --- .../scribblings/reference/cont-marks.scrbl | 6 +- collects/tests/racket/contmark.rktl | 122 ++++++++++++++++++ collects/tests/racket/prompt-tests.rktl | 7 +- src/racket/src/fun.c | 7 +- 4 files changed, 138 insertions(+), 4 deletions(-) diff --git a/collects/scribblings/reference/cont-marks.scrbl b/collects/scribblings/reference/cont-marks.scrbl index f94bf18cb2..d75195a531 100644 --- a/collects/scribblings/reference/cont-marks.scrbl +++ b/collects/scribblings/reference/cont-marks.scrbl @@ -108,14 +108,16 @@ elements to indicate the lack of a value.} @defproc[(continuation-mark-set-first [mark-set (or/c continuation-mark-set? #f)] [key-v any/c] + [none-v any/c #f] [prompt-tag continuation-prompt-tag? (default-continuation-prompt-tag)]) any]{ Returns the first element of the list that would be returned by @racket[(continuation-mark-set->list (or mark-set (current-continuation-marks prompt-tag)) key-v prompt-tag)], or -@racket[#f] if the result would be the empty list. Typically, this +@racket[none-v] if the result would be the empty list. Typically, this result can be computed more quickly using -@racket[continuation-mark-set-first].} +@racket[continuation-mark-set-first] than using +@racket[continuation-mark-set->list].} @defproc[(call-with-immediate-continuation-mark [key-v any/c] diff --git a/collects/tests/racket/contmark.rktl b/collects/tests/racket/contmark.rktl index 77f072caaa..09aed98c02 100644 --- a/collects/tests/racket/contmark.rktl +++ b/collects/tests/racket/contmark.rktl @@ -793,6 +793,128 @@ (test (list s #t) list s (for/and ([i (in-range 100)]) (go))))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Test interaction of prompts and `continuation-mark-set-first' + +(let () + (define key 'key) + (define value 'value) + (define pt (make-continuation-prompt-tag)) + + (for-each + (lambda (thunk) + (test #f (lambda (f) (f)) thunk)) + + (list + (lambda () + (with-continuation-mark key value + (call-with-continuation-prompt + (lambda () + (continuation-mark-set-first + #f + key))))) + + (lambda () + (with-continuation-mark key value + (call-with-continuation-prompt + (lambda () + (continuation-mark-set-first + (current-continuation-marks) + key))))) + + (lambda () + (with-continuation-mark key value + (call-with-continuation-prompt + (lambda () + (continuation-mark-set-first + (current-continuation-marks (default-continuation-prompt-tag)) + key))))) + + (lambda () + (with-continuation-mark key value + (call-with-continuation-prompt + (lambda () + (continuation-mark-set-first + #f + key + #f + (default-continuation-prompt-tag)))))) + + (lambda () + (with-continuation-mark key value + (call-with-continuation-prompt + (lambda () + (continuation-mark-set-first + (current-continuation-marks) + key + #f + (default-continuation-prompt-tag)))))) + + (lambda () + (with-continuation-mark key value + (call-with-continuation-prompt + (lambda () + (continuation-mark-set-first + (current-continuation-marks) + key + #f + pt)) + pt))) + + (lambda () + (with-continuation-mark key value + (call-with-continuation-prompt + (lambda () + (continuation-mark-set-first + (current-continuation-marks (default-continuation-prompt-tag)) + key + #f + (default-continuation-prompt-tag)))))) + + (lambda () + (with-continuation-mark key value + (call-with-continuation-prompt + (lambda () + (continuation-mark-set-first + (current-continuation-marks pt) + key + #f + (default-continuation-prompt-tag))) + pt))))) + + (test 'alt 'alt-fail + (with-continuation-mark key value + (call-with-continuation-prompt + (lambda () + (continuation-mark-set-first + #f + key + 'alt))))) + + (test value 'no-block + (with-continuation-mark key value + (call-with-continuation-prompt + (lambda () + (continuation-mark-set-first + (current-continuation-marks) + key + #f + (default-continuation-prompt-tag))) + pt))) + + (test value 'no-block2 + (call-with-continuation-prompt + (lambda () + (with-continuation-mark key value + (call-with-continuation-prompt + (lambda () + (continuation-mark-set-first + (current-continuation-marks pt) + key + #f + pt))))) + pt))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/collects/tests/racket/prompt-tests.rktl b/collects/tests/racket/prompt-tests.rktl index 5a856ffe83..47bbd5a89b 100644 --- a/collects/tests/racket/prompt-tests.rktl +++ b/collects/tests/racket/prompt-tests.rktl @@ -855,11 +855,16 @@ (lambda () (k (lambda () (continuation-mark-set-first #f 'x #f catch-tag)))) catch-tag) - (test 8 + (test #f call-with-continuation-prompt (lambda () (k (lambda () (continuation-mark-set-first #f 'y #f catch-tag)))) catch-tag) + (test (if (eq? catch-tag (default-continuation-prompt-tag)) #f 8) + call-with-continuation-prompt + (lambda () + (k (lambda () (continuation-mark-set-first #f 'y #f catch-tag)))) + (default-continuation-prompt-tag)) (test (if blocked? '(17) '(17 18)) diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index c23f40a001..7bbadba98d 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -8125,6 +8125,8 @@ scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key while (chain) { if (chain->key == key) return chain->val; + else if (SAME_OBJ(chain->key, prompt_tag)) + break; else chain = chain->next; } @@ -8165,6 +8167,8 @@ scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key val = seg[pos].val; vpos = seg[pos].pos; break; + } else if (SAME_OBJ(seg[pos].key, prompt_tag)) { + break; } else { cache = seg[pos].cache; if (cache && SCHEME_HASHTP(cache)) @@ -8347,7 +8351,8 @@ extract_one_cc_mark(int argc, Scheme_Object *argv[]) } } - r = scheme_extract_one_cc_mark_to_tag(SCHEME_TRUEP(argv[0]) ? argv[0] : NULL, argv[1], prompt_tag); + r = scheme_extract_one_cc_mark_to_tag(SCHEME_TRUEP(argv[0]) ? argv[0] : NULL, argv[1], + prompt_tag ? SCHEME_PTR_VAL(prompt_tag) : NULL); if (!r) { if (argc > 2) r = argv[2];