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

fix continuation-barrier checking

Browse Source 
Continuation-barrier checking was sometimes too strict,
disallowing jumps out past a barrier (as opposed to
into a barrier) that should be allowed.
This commit is contained in:
Matthew Flatt 2017-12-12 08:52:26 -07:00
parent fc77c91102
commit 544b7a3d53
2 changed files with 72 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

127
pkgs/racket-test-core/tests/racket/prompt-tests.rktl
View File

@ -1473,6 +1473,53 @@
(let ([p1 (make-continuation-prompt-tag 'p1)]
[output null]
[exit-k #f])
(let ([go
(lambda (launch)
(let ([k (call-with-continuation-barrier
(lambda ()
(let/cc esc
(call-with-continuation-prompt
(lambda ()
(dynamic-wind
(lambda () (void))
(lambda ()
(with-handlers ([void (lambda (exn)
(test #f "should not be used!" #t))])
(launch esc)))
(lambda ()
((call/cc
(lambda (k)
(set! exit-k k)
(lambda () 10))
p1))
(set! output (cons 'post output)))))
p1))))])
(call-with-continuation-prompt
(lambda ()
(exit-k (lambda () 'hi)))
p1)))])
(err/rt-test
(go (lambda (esc) (esc 'middle)))
exn:fail:contract:continuation?)
(test '(post post) values output)
(let ([meta (call-with-continuation-prompt
(lambda ()
((call-with-composable-continuation
(lambda (k) (lambda () k))))))])
(err/rt-test
(go (lambda (esc)
(meta
(lambda () (esc 'ok)))))
exn:fail:contract:continuation?))
(test '(post post post post) values output)))
;; Similar, but not a barrier error, because the jump
;; just escapes past a barrier instead of jumping into
;; one
(let ([p1 (make-continuation-prompt-tag 'p1)]
[output null]
[exit-k #f]
[count 3])
(let ([go
(lambda (launch)
(let ([k (let/cc esc
@ -1492,69 +1539,27 @@
p1))
(set! output (cons 'post output)))))
p1))])
(cond
[(zero? count) 'three]
[else
(set! count (sub1 count))
(call-with-continuation-barrier
(lambda ()
(call-with-continuation-prompt
(lambda ()
(exit-k (lambda () 'hi)))
p1)))))])
(err/rt-test
(go (lambda (esc) (esc 'middle)))
exn:fail:contract:continuation?)
(test '(post post) values output)
p1)))])))])
(test 'three go (lambda (esc) (esc 'middle)))
(test '(post post post post) values output)
(let ([meta (call-with-continuation-prompt
(lambda ()
((call-with-composable-continuation
(lambda (k) (lambda () k))))))])
(err/rt-test
(go (lambda (esc)
(test 'three
go (lambda (esc)
(meta
(lambda () (esc 'ok)))))
exn:fail:contract:continuation?))
(test '(post post post post) values output)))
;; Similar, but more checking of dropped d-ws:
(let ([p1 (make-continuation-prompt-tag 'p1)]
[output null]
[exit-k #f]
[done? #f])
;; Capture a continuation w.r.t. the default prompt tag:
(call/cc
(lambda (esc)
(dynamic-wind
(lambda () (void))
(lambda ()
;; Set a prompt for tag p1:
(call-with-continuation-prompt
(lambda ()
(dynamic-wind
(lambda () (void))
;; inside d-w, jump out:
(lambda () (esc 'done))
(lambda ()
;; As we jump out, capture a continuation
;; w.r.t. p1:
((call/cc
(lambda (k)
(set! exit-k k)
(lambda () 10))
p1))
(set! output (cons 'inner output)))))
p1))
(lambda ()
;; This post thunk is not in the
;; delimited continuation captured
;; via tag p1:
(set! output (cons 'outer output))))))
(unless done?
(set! done? #t)
;; Now invoke the delimited continuation, which must
;; somehow continue the jump to `esc':
(call-with-continuation-prompt
(lambda ()
(exit-k (lambda () 10)))
p1))
(test '(inner outer inner) values output))
(lambda () (esc 'ok))))))
(test '(post post post post post) values output)))
;; Again, more checking of output
(let ([p1 (make-continuation-prompt-tag 'p1)]
@ -2014,10 +2019,20 @@
(k (lambda () 17)))
(test #t procedure? once-k)
(test k values 17)
(err/rt-test (call-with-continuation-barrier
(err/rt-test (call-with-continuation-prompt
(lambda ()
(once-k 18)))
exn:fail:contract:continuation?))
(call-with-continuation-barrier
(lambda ()
(once-k 18)))))
(lambda (x)
(and (exn:fail:contract? x)
(not (exn:fail:contract:continuation? x))))))
(printf "Trying long chain under barrier...\n")
(let ([k (call-with-continuation-barrier
(lambda ()
(long-loop (lambda ()
((let/cc k (lambda () k)))))))])
(err/rt-test (k 18) exn:fail:contract:continuation?))
(printf "Trying long chain again...\n")
(let ([k (call-with-continuation-prompt
(lambda ()

4
racket/src/racket/src/eval.c
View File

@ -1544,7 +1544,7 @@ static Scheme_Prompt *check_barrier(Scheme_Prompt *prompt,
Scheme_Meta_Continuation *prompt_cont, MZ_MARK_POS_TYPE prompt_pos,
Scheme_Cont *c)
/* A continuation barrier is analogous to a dynamic-wind. A jump is
allowed if no dynamic-wind-like barriers would be executed for
allowed if no dynamic-wind-like pre-thunks would be executed for
the jump. */
{
Scheme_Prompt *barrier_prompt, *b1, *b2;
@ -1567,7 +1567,7 @@ static Scheme_Prompt *check_barrier(Scheme_Prompt *prompt,
b2 = NULL;
}
if (b1 != b2) {
if (b2 && (b1 != b2)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
"continuation application: attempt to cross a continuation barrier");
}