diff --git a/pkgs/racket-test-core/tests/racket/prompt.rktl b/pkgs/racket-test-core/tests/racket/prompt.rktl index 591cbcead3..b99831f63f 100644 --- a/pkgs/racket-test-core/tests/racket/prompt.rktl +++ b/pkgs/racket-test-core/tests/racket/prompt.rktl @@ -500,6 +500,89 @@ (grab N M void 10)) p)) +;; ---------------------------------------- +;; Check that a non-composable-continuation jump isn't +;; fooled by a dynamic-wind frame that is common to the +;; source and destination but not followed by all +;; matching frames. + +(let () + (define accum null) + (define (output! v) (set! accum (cons v accum))) + (define (check-output! expect) + (let ([got (reverse accum)]) + (set! accum null) + (displayln got) + (test expect values got))) + + ;; Make a composable continuation that holds one dynamic-wind frame + (define (make-composable-dw pre post) + (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (output! pre)) + (lambda () ((call-with-composable-continuation + (lambda (k) (lambda () k))))) + (lambda () (output! post)))))) + + (define dw1 (make-composable-dw "+1" "-1")) + (check-output! '("+1" "-1")) + + (define dw2 (make-composable-dw "+2" "-2")) + (check-output! '("+2" "-2")) + + (define dw3 (make-composable-dw "+3" "-3")) + (check-output! '("+3" "-3")) + + (define (compose-dw a-dw b-dw) + (lambda (f) + (a-dw (lambda () (b-dw f))))) + + ;; compose dw1 and dw2, with "work" in the middle: + ((compose-dw dw1 dw2) (lambda () (output! "work"))) + (check-output! '("+1" "+2" "work" "-2" "-1")) + + ;; Compose two composable continuations, and capture the composition + ;; as non-composable: + (define (make-non-composable dw) + (call-with-continuation-prompt + (lambda () + (dw + (lambda () + ((call/cc + (lambda (k) (lambda () k))))))))) + + (define dw2+dw1 (make-non-composable (compose-dw dw2 dw1))) + (check-output! '("+2" "+1" "-1" "-2")) + + (define dw3+dw1 (make-non-composable (compose-dw dw3 dw1))) + (check-output! '("+3" "+1" "-1" "-3")) + + (call-with-continuation-prompt + (lambda () + (dw2+dw1 (lambda () (output! "inside"))))) + (check-output! '("+2" "+1" "inside" "-1" "-2")) + + (define dw3+dw2+dw1 (make-non-composable (compose-dw (compose-dw dw3 dw2) dw1))) + (check-output! '("+3" "+2" "+1" "-1" "-2" "-3")) + + ;; From a dw3+dw2+d1 composition, jump to a dw2+dw1 composition; + ;; even though the sourec and destination both have dw2 and dw1 + ;; innermost, the full chains are different, so the jump goes + ;; all the way out of dw3+dw2+dw1 and back into dw2+dw1 + (call-with-continuation-prompt + (lambda () + (dw3+dw2+dw1 (lambda () (dw2+dw1 (lambda () (output! "inside"))))))) + (check-output! '("+3" "+2" "+1" "-1" "-2" "-3" "+2" "+1" "inside" "-1" "-2")) + + ;; From a dw2+d1 composition, jump to a dw3+dw1 composition; + ;; this one should still jump all the way out and all the way + ;; back in: + (call-with-continuation-prompt + (lambda () + (dw2+dw1 (lambda () (dw3+dw1 (lambda () (output! "inside"))))))) + (check-output! '("+2" "+1" "-1" "-2" "+3" "+1" "inside" "-1" "-3"))) + ;;---------------------------------------- (report-errs) diff --git a/racket/src/racket/src/eval.c b/racket/src/racket/src/eval.c index 1220964bab..f01cd004c7 100644 --- a/racket/src/racket/src/eval.c +++ b/racket/src/racket/src/eval.c @@ -1472,7 +1472,7 @@ static Scheme_Dynamic_Wind *intersect_dw(Scheme_Dynamic_Wind *a, Scheme_Dynamic_ { int alen = 0, blen = 0; int a_has_tag = 0, a_prompt_delta = 0, b_prompt_delta = 0; - Scheme_Dynamic_Wind *dw; + Scheme_Dynamic_Wind *dw, *match_a, *match_b; for (dw = a; dw && (dw->prompt_tag != prompt_tag); dw = dw->prev) { } @@ -1504,18 +1504,32 @@ static Scheme_Dynamic_Wind *intersect_dw(Scheme_Dynamic_Wind *a, Scheme_Dynamic_ } /* At this point, we have chains that are the same length. */ + match_a = NULL; + match_b = NULL; while (blen) { if (SAME_OBJ(a->id ? a->id : (Scheme_Object *)a, - b->id ? b->id : (Scheme_Object *)b)) - break; + b->id ? b->id : (Scheme_Object *)b)) { + if (!match_a) { + match_a = a; + match_b = b; + } + } else { + match_a = NULL; + match_b = NULL; + } a = a->prev; b = b->prev; blen--; } - *_common_depth = (b ? b->depth : -1); + if (!match_a) { + match_a = a; + match_b = b; + } - return a; + *_common_depth = (match_b ? match_b->depth : -1); + + return match_a; } static Scheme_Prompt *lookup_cont_prompt(Scheme_Cont *c,