(let ([try (lambda (thread m-top n-top do-mid-stream do-abort) (let ([result #f]) (thread-wait (thread (lambda () (set! result (let pre-loop ([m m-top]) (if (zero? m) (list (do-mid-stream (lambda () (call-with-continuation-prompt (lambda () (let loop ([n n-top]) (if (zero? n) (do-abort (lambda () (abort-current-continuation (default-continuation-prompt-tag) (lambda () 5000)))) (+ (loop (sub1 n)))))))))) (list (car (pre-loop (sub1 m)))))))))) (test '(5000) values result)))]) (try thread 5000 10000 (lambda (mid) (mid)) (lambda (abort) (((call/cc (lambda (k) (lambda () k)))) (lambda () (lambda (x) 5000)))))) (test-breaks-ok) ;;---------------------------------------- ;; Prompt escapes ;; Simple return (test 10 call-with-continuation-prompt (lambda () 10)) (test-values '(10 11) (lambda () (call-with-continuation-prompt (lambda () (values 10 11))))) (test-values '() (lambda () (call-with-continuation-prompt (lambda () (values))))) ;; Aborts (test 11 call-with-continuation-prompt (lambda () (abort-current-continuation (default-continuation-prompt-tag) 11)) (default-continuation-prompt-tag) values) (test 11 call-with-continuation-prompt (lambda () (abort-current-continuation (default-continuation-prompt-tag) (lambda () 11)))) (test 12 call-with-continuation-prompt (lambda () (abort-current-continuation (default-continuation-prompt-tag) 12)) (default-continuation-prompt-tag) values) (test 12 call-with-continuation-prompt (lambda () (abort-current-continuation (default-continuation-prompt-tag) (lambda () 12))) (default-continuation-prompt-tag)) (test-values '(11 12) (lambda () (call-with-continuation-prompt (lambda () (abort-current-continuation (default-continuation-prompt-tag) 11 12)) (default-continuation-prompt-tag) values))) (test-values '(11 12) (lambda () (call-with-continuation-prompt (lambda () (abort-current-continuation (default-continuation-prompt-tag) (lambda () (values 11 12))))))) (test 8 call-with-continuation-prompt (lambda () (+ 17 (abort-current-continuation (default-continuation-prompt-tag) (lambda () 8))))) (test 81 call-with-continuation-prompt (lambda () (+ 17 (call-with-continuation-prompt (lambda () (abort-current-continuation (default-continuation-prompt-tag) (lambda () 81))) (make-continuation-prompt-tag))))) (let ([p (make-continuation-prompt-tag)]) (test 810 call-with-continuation-prompt (lambda () (+ 17 (call-with-continuation-prompt (lambda () (abort-current-continuation p 810)) (make-continuation-prompt-tag)))) p values)) ;; Aborts with handler (test 110 call-with-continuation-prompt (lambda () (abort-current-continuation (default-continuation-prompt-tag) 11)) (default-continuation-prompt-tag) (lambda (x) (* x 10))) (test 23 call-with-continuation-prompt (lambda () (abort-current-continuation (default-continuation-prompt-tag) 11 12)) (default-continuation-prompt-tag) (lambda (x y) (+ x y))) ;; Handler in tail position: (test '(11 12 17) 'handler-in-tail-position (with-continuation-mark 'x 16 (call-with-continuation-prompt (lambda () (abort-current-continuation (default-continuation-prompt-tag) 11 12)) (default-continuation-prompt-tag) (lambda (x y) (with-continuation-mark 'x 17 (list* x y (continuation-mark-set->list (current-continuation-marks) 'x))))))) (test-breaks-ok) ;; Abort to a prompt in a d-w post that is deeper than a ;; prompt with the same tag at the continuation-jump site: (test 0 values (let ([p1 (make-continuation-prompt-tag)] [p2 (make-continuation-prompt-tag)]) (let/cc k (call-with-continuation-prompt (lambda () (call-with-continuation-prompt (lambda () (dynamic-wind void (lambda () (call-with-continuation-prompt (lambda () (k 0)) p2)) (lambda () (abort-current-continuation p1 (lambda () 0))))) p1)) p2)))) ;; ---------------------------------------- ;; Continuations (with-cc-variants (test -17 call-with-continuation-prompt (lambda () -17))) (with-cc-variants (test 17 call-with-continuation-prompt (lambda () (let/cc k (k 17))))) (test-breaks-ok) (with-cc-variants (test 29 'in-other-prompt1 (let ([retry #f]) (test 35 call-with-continuation-prompt (lambda () (+ 18 (let/cc k (set! retry k) 17)))) (+ 1 (call-with-continuation-prompt (lambda () (retry 10))))))) (with-cc-variants (test 60 'in-other-prompt2 (let ([retry #f]) (test 35 call-with-continuation-prompt (lambda () (+ 18 (let/cc k (set! retry k) 17)))) (+ 1 (call-with-continuation-prompt (lambda () (+ (call-with-continuation-prompt (lambda () (retry 12))) (call-with-continuation-prompt (lambda () (retry 11)))))))))) (with-cc-variants (test '(#f #t) 'in-other-thread1 (let ([retry #f] [result #f] [did? #f]) (call-with-continuation-prompt (lambda () (+ 18 (begin0 (let/cc k (set! retry k) 17) (set! did? #t))))) (set! did? #f) (thread-wait (thread (lambda () (set! result (retry 0))))) (list result did?)))) (with-cc-variants (test 18 'in-other-thread2 (let ([retry #f] [result #f]) (call-with-continuation-prompt (lambda () (+ 18 (let/cc k (set! retry k) 17)))) (thread-wait (thread (lambda () (set! result (call-with-continuation-prompt (lambda () (retry 0))))))) result))) (with-cc-variants (test 25 'back-in-original-thread (let ([retry #f] [result #f]) (thread-wait (thread (lambda () (+ 18 (let/cc k (set! retry k) 17))))) (call-with-continuation-prompt (lambda () (retry 7)))))) (test-breaks-ok) ;; Catch continuation in composed continuation: (with-cc-variants (test 89 'catch-composed (let ([k (call-with-continuation-prompt (lambda () ((let/cc k (lambda () k)))))]) (let ([k2 (call-with-continuation-prompt (lambda () (k (lambda () (car (let/cc k2 (list k2)))))))]) (call-with-continuation-prompt (lambda () (k2 '(89)))))))) ;; Grab continuation shallow inside meta-prompt with ;; delimiting prompt deep in a different meta-prompt. (with-cc-variants (let ([k (call-with-continuation-prompt (lambda () ((call/cc (lambda (k) (lambda () k))))))]) (test 10 call-with-continuation-prompt (lambda () (let loop ([n 300]) (if (zero? n) (k (lambda () (let/cc k2 (k2 10)))) (cons n (loop (sub1 n))))))))) ;; Grab continuation deep inside meta-prompt with ;; delimiting prompt shallow in a different meta-prompt. (with-cc-variants (let ([k (call-with-continuation-prompt (lambda () (let loop ([n 12]) (if (zero? n) ((call/cc (lambda (k) (lambda () k)))) (cons 1 (loop (sub1 n)))))))]) (test '(1 1 1 1 1 1 1 1 1 1 1 1 . 10) call-with-continuation-prompt (lambda () ((list-tail k 12) (lambda () (let/cc k2 (k2 10)))))))) (test-breaks-ok) ;; ---------------------------------------- ;; Overlapping continuations ;; Nested (let ([p1 (make-continuation-prompt-tag)] [p2 (make-continuation-prompt-tag)]) (let ([k1 #f] [k2 #f]) (test '(p1 p2 100) call-with-continuation-prompt (lambda () (cons 'p1 (call-with-continuation-prompt (lambda () (cons 'p2 ((call/cc (lambda (-k1) (set! k1 -k1) (call/cc (lambda (-k2) (set! k2 -k2) (lambda () '(100))) p2)) p1)))) p2))) p1) (err/rt-test (k1) exn:fail:contract:continuation?) (err/rt-test (k2) exn:fail:contract:continuation?) (err/rt-test (call-with-continuation-prompt (lambda () (k1)) p2) exn:fail:contract:continuation?) (err/rt-test (call-with-continuation-prompt (lambda () (k2)) p1) exn:fail:contract:continuation?) (test '(p1 p2 101) call-with-continuation-prompt (lambda () (k1 (lambda () '(101)))) p1) (test '(p2 102) call-with-continuation-prompt (lambda () (k2 (lambda () '(102)))) p2) (test '(p1 p2 102-1) call-with-continuation-prompt (lambda () (k1 (lambda () (k2 (lambda () '(102-1)))))) p1))) ;; Use default tag to catch a meta-continuation of p1. ;; Due to different implementations of the default tag, ;; this test is interesting in the main thread and ;; a sub thread: (let () (define (go) (let ([p1 (make-continuation-prompt-tag)]) (let ([k (call-with-continuation-prompt (lambda () ((call/cc (lambda (k) (lambda () k)) p1))) p1)]) (let ([k2 (list (call-with-continuation-prompt (lambda () (k (lambda () (let/cc k k)))) p1))]) (if (procedure? (car k2)) ((car k2) 10) (test '(10) values k2)))))) (go) (let ([finished #f]) (thread-wait (thread (lambda () (go) (set! finished 'finished)))) (test 'finished values finished))) ;; Use default tag to catch a meta-continuation of p1, ;; then catch continuation again (i.e., loop). (let ([finished #f]) (define (go) (let ([p1 (make-continuation-prompt-tag)] [counter 10]) (let ([k (call-with-continuation-prompt (lambda () ((call/cc (lambda (k) (lambda () k)) p1))) p1)]) (let ([k2 (list (call-with-continuation-prompt (lambda () (k (lambda () ((let/cc k (lambda () k)))))) p1))]) (if (procedure? (car k2)) ((car k2) (lambda () (if (zero? counter) 10 (begin (set! counter (sub1 counter)) ((let/cc k (lambda () k))))))) (test '(10) values k2)) (set! finished 'finished))))) (go) (let ([finished #f]) (thread-wait (thread (lambda () (go) (set! finished 'finished)))) (test 'finished values finished))) ;; ---------------------------------------- ;; Composable continuations (err/rt-test (call-with-continuation-barrier ;; When the test is not run in a REPL but is run in the ;; main thread, then it should fail without the barrier, ;; too. But we don't have enough control over the test ;; environment to assume that. (lambda () (call-with-composable-continuation (lambda (x) x)))) exn:fail:contract:continuation?) (err/rt-test (call-with-composable-continuation (lambda (x) x) (make-continuation-prompt-tag 'px)) exn:fail:contract?) (let ([k (call-with-continuation-prompt (lambda () (call-with-composable-continuation (lambda (k) k))))]) (test 12 k 12) (test 13 k (k (k (k 13)))) (test-values '(12 13) (lambda () (k 12 13)))) (let ([k (call-with-continuation-prompt (lambda () ((call-with-composable-continuation (lambda (k) (lambda () k))))))]) (test 12 k (lambda () 12)) (test-values '(12 13) (lambda () (k (lambda () (values 12 13))))) ;; Composition shouldn't introduce a prompt: (test 10 call-with-continuation-prompt (lambda () (let ([k2 (k (lambda () (let/cc k2 k2)))]) (if (procedure? k2) (k2 10) k2)))) ;; Escape from composed continuation: (let ([p (make-continuation-prompt-tag)]) (test 8 call-with-continuation-prompt (lambda () (+ 99 (k (lambda () (abort-current-continuation p 8))))) p values)) (test 8 call-with-continuation-prompt (lambda () (+ 99 (k (lambda () (abort-current-continuation (default-continuation-prompt-tag) 8))))) (default-continuation-prompt-tag) values)) ;; Etc. (let ([k1 (call-with-continuation-prompt (lambda () ((call-with-composable-continuation (lambda (k) (lambda () k))))))] [k2 (call-with-continuation-prompt (lambda () ((call-with-composable-continuation (lambda (k) (lambda () k))))))]) (test 1000 call-with-continuation-prompt (lambda () (k1 (lambda () (k2 (lambda () 1000)))))) (test -1000 k1 (lambda () (k2 (lambda () -1000)))) (let ([k3 (call-with-continuation-prompt (lambda () (k1 (lambda () ((call-with-composable-continuation (lambda (k) (lambda () k))))))))]) (test 1001 call-with-continuation-prompt (lambda () (k3 (lambda () 1001)))) (test -1001 k3 (lambda () -1001)) (test 1002 call-with-continuation-prompt (lambda () (k1 (lambda () (k3 (lambda () 1002)))))) (test -1002 k1 (lambda () (k3 (lambda () -1002))))) (let ([k4 (call-with-continuation-prompt (lambda () (k1 (lambda () ((call-with-composable-continuation (lambda (k) (lambda () k))))))))]) (test -1003 k4 (lambda () -1003))) (let ([k5 (call-with-continuation-prompt (lambda () ((k1 (lambda () (call-with-composable-continuation (lambda (k) (lambda () k))))))))]) (test -1004 k5 (lambda () -1004)) (let ([k6 (call-with-continuation-prompt (lambda () ((k5 (lambda () (call-with-composable-continuation (lambda (k) (lambda () k))))))))]) (test -1005 k6 (lambda () -1005)))) (let ([k7 (call-with-continuation-prompt (lambda () ((k1 (lambda () ((k1 (lambda () (call-with-composable-continuation (lambda (k) (lambda () (lambda () k))))))))))))]) (test -1006 k7 (lambda () (lambda () -1006))) (test '(-1007) call-with-continuation-prompt (lambda () (list (k7 (lambda () (lambda () -1007))))))) ) ;; Check that escape drops the meta-continuation: (test 0 'esc (let ([p1 (make-continuation-prompt-tag)]) (let/cc esc (let ([k (call-with-continuation-prompt (lambda () ((call-with-composable-continuation (lambda (k) (lambda () k)) p1))) p1)]) (/ (k (lambda () (esc 0)))))))) ;; ---------------------------------------- ;; Dynamic wind (test 89 'dw (let ([k (dynamic-wind void (lambda () (let ([k+e (let/cc k (cons k void))]) ((cdr k+e) 89) (car k+e))) void)]) (let/cc esc (k (cons void esc))))) (let ([l null]) (let ([k2 (dynamic-wind (lambda () (set! l (cons 'pre0 l))) (lambda () (let ([k (call-with-continuation-prompt (lambda () (dynamic-wind (lambda () (set! l (cons 'pre l))) (lambda () (let ([k (let/cc k k)]) k)) (lambda () (set! l (cons 'post l))))))]) (test '(post pre pre0) values l) ;; Jump from one to the other: (let ([k2 (call-with-continuation-prompt (lambda () (dynamic-wind (lambda () (set! l (cons 'pre2 l))) (lambda () (dynamic-wind (lambda () (set! l (cons 'pre3 l))) (lambda () (let/cc k2 (k k2))) (lambda () (set! l (cons 'post3 l))))) (lambda () (set! l (cons 'post2 l))))))]) (test '(post pre post2 post3 pre3 pre2 post pre pre0) values l) k2))) (lambda () (set! l (cons 'post0 l))))]) (test '(post0 post pre post2 post3 pre3 pre2 post pre pre0) values l) ;; Restore in context with fewer DWs: (test 8 call-with-continuation-prompt (lambda () (k2 8))) (test '(post2 post3 pre3 pre2 post0 post pre post2 post3 pre3 pre2 post pre pre0) values l) ;; Restore in context with more DWs: (set! l null) (dynamic-wind (lambda () (set! l (cons 'pre4 l))) (lambda () (dynamic-wind (lambda () (set! l (cons 'pre5 l))) (lambda () (call-with-continuation-prompt k2)) (lambda () (set! l (cons 'post5 l))))) (lambda () (set! l (cons 'post4 l)))) (test '(post4 post5 post2 post3 pre3 pre2 pre5 pre4) values l))) ;; Like the meta-continuation test above, but add a dynamic wind ;; to be restored in the p1 continuation: (let ([p1 (make-continuation-prompt-tag)] [did #f]) (let ([k (call-with-continuation-prompt (lambda () (dynamic-wind (lambda () (set! did 'in)) (lambda () ((call/cc (lambda (k) (lambda () k)) p1))) (lambda () (set! did 'out)))) p1)]) (set! did #f) (let ([k2 (list (call-with-continuation-prompt (lambda () (k (lambda () (test 'in values did) ((let/cc k (lambda () k)))))) p1))]) (test 'out values did) (if (procedure? (car k2)) ((car k2) (lambda () (test 'in values did) 10)) (test '(10) values k2))))) ;; Composable continuations (let ([l null]) (let ([k2 (dynamic-wind (lambda () (set! l (cons 'pre0 l))) (lambda () (let ([k (call-with-continuation-prompt (lambda () (dynamic-wind (lambda () (set! l (cons 'pre l))) (lambda () ((call-with-composable-continuation (lambda (k) (lambda () k))))) (lambda () (set! l (cons 'post l))))))]) (test '(post pre pre0) values l) (test 12 k (lambda () 12)) (test '(post pre post pre pre0) values l) k)) (lambda () (set! l (cons 'post0 l))))]) (test '(post0 post pre post pre pre0) values l) (test 73 k2 (lambda () 73)) (test '(post pre post0 post pre post pre pre0) values l) (set! l null) ;; Add d-w inside k2: (let ([k3 (call-with-continuation-prompt (lambda () (k2 (lambda () (dynamic-wind (lambda () (set! l (cons 'pre2 l))) (lambda () ((call-with-composable-continuation (lambda (k) (lambda () k))))) (lambda () (set! l (cons 'post2 l))))))))]) (test '(post post2 pre2 pre) values l) (test 99 k3 (lambda () 99)) (test '(post post2 pre2 pre post post2 pre2 pre) values l)) (set! l null) ;; Add d-w outside k2: (let ([k4 (call-with-continuation-prompt (lambda () (dynamic-wind (lambda () (set! l (cons 'pre2 l))) (lambda () (k2 (lambda () ((call-with-composable-continuation (lambda (k) (lambda () k))))))) (lambda () (set! l (cons 'post2 l))))))]) (test '(post2 post pre pre2) values l) (test 99 k4 (lambda () 99)) (test '(post2 post pre pre2 post2 post pre pre2) values l)))) ;; Jump back into post: (let ([l null] [p1 (make-continuation-prompt-tag)] [p2 (make-continuation-prompt-tag)] [k2 #f]) (define (out v) (set! l (cons v l))) (call-with-continuation-prompt (lambda () (dynamic-wind (lambda () (out 'pre)) (lambda () (call-with-continuation-prompt (lambda () (dynamic-wind (lambda () (out 'pre2)) (lambda () (void)) (lambda () (call/cc (lambda (k) (set! k2 k)) p2) (out 'post2)))) p2)) (lambda () (out 'post1)))) p1) (call-with-continuation-prompt (lambda () (k2 10)) p2) (test '(post2 post1 post2 pre2 pre) values l)) ;; Jump into post, then back out (let ([l null] [p1 (make-continuation-prompt-tag)] [p2 (make-continuation-prompt-tag)] [k2 #f] [count 0]) (define (out v) (set! l (cons v l))) (let/cc esc (call-with-continuation-prompt (lambda () (dynamic-wind (lambda () (out 'pre1)) (lambda () (call-with-continuation-prompt (lambda () (dynamic-wind (lambda () (out 'pre2)) (lambda () (void)) (lambda () (call/cc (lambda (k) (set! k2 k)) p2) (out 'post2) (esc)))) p2)) (lambda () (out 'post1)))) p1)) (printf "here ~a\n" count) (set! count (add1 count)) (unless (= count 3) (call-with-continuation-prompt (lambda () (k2 10)) p2)) (test '(post2 post2 post1 post2 pre2 pre1) values l)) (printf "into post from escape\n") ;; Jump into post from an escape, rather than ;; from a result continuation (let ([l null] [p1 (make-continuation-prompt-tag)] [p2 (make-continuation-prompt-tag)] [k2 #f] [count 0]) (define (out v) (set! l (cons v l))) (let/cc esc (call-with-continuation-prompt (lambda () (dynamic-wind (lambda () (out 'pre1)) (lambda () (call-with-continuation-prompt (lambda () (dynamic-wind (lambda () (out 'pre2)) (lambda () (esc)) (lambda () (call/cc (lambda (k) (set! k2 k)) p2) (out 'post2)))) p2)) (lambda () (out 'post1)))) p1)) (set! count (add1 count)) (unless (= count 3) (call-with-continuation-prompt (lambda () (k2 10)) p2)) (test '(post2 post2 post1 post2 pre2 pre1) values l)) ;; ---------------------------------------- ;; Continuation marks (let ([go (lambda (access-tag catch-tag blocked?) (let ([k (call-with-continuation-prompt (lambda () (with-continuation-mark 'x 17 ((call/cc (lambda (k) (lambda () k)) catch-tag)))) catch-tag)]) (with-continuation-mark 'x 18 (with-continuation-mark 'y 8 (begin (printf "here\n") (test 18 continuation-mark-set-first #f 'x #f catch-tag) (test '(18) continuation-mark-set->list (current-continuation-marks catch-tag) 'x catch-tag) (test 17 call-with-continuation-prompt (lambda () (k (lambda () (continuation-mark-set-first #f 'x #f catch-tag)))) catch-tag) (test 8 call-with-continuation-prompt (lambda () (k (lambda () (continuation-mark-set-first #f 'y #f catch-tag)))) catch-tag) (test (if blocked? '(17) '(17 18)) call-with-continuation-prompt (lambda () (k (lambda () (continuation-mark-set->list (current-continuation-marks access-tag) 'x access-tag)))) catch-tag) (test '(17) continuation-mark-set->list (continuation-marks k catch-tag) 'x catch-tag) (test (if blocked? '() '(8)) call-with-continuation-prompt (lambda () (k (lambda () (continuation-mark-set->list (current-continuation-marks access-tag) 'y access-tag)))) catch-tag) 'done)))))]) (go (default-continuation-prompt-tag) (default-continuation-prompt-tag) #t) (let ([p2 (make-continuation-prompt-tag 'p2)]) (call-with-continuation-prompt (lambda () (go p2 p2 #t) (go p2 (default-continuation-prompt-tag) #f) (go (default-continuation-prompt-tag) p2 #f)) p2))) (define (non-tail v) (values v)) (let () (define (go access-tag blocked?) (let ([k (call-with-continuation-prompt (lambda () (with-continuation-mark 'x 71 ((call-with-composable-continuation (lambda (k) (lambda () k)))))))]) (test #f continuation-mark-set-first #f 'x) (test 71 k (lambda () (continuation-mark-set-first #f 'x))) (test '(71) continuation-mark-set->list (continuation-marks k) 'x) (test 71 'wcm (with-continuation-mark 'x 81 (k (lambda () (continuation-mark-set-first #f 'x))))) (test '(71 81) 'wcm (with-continuation-mark 'x 81 (non-tail (k (lambda () (continuation-mark-set->list (current-continuation-marks) 'x)))))) (test '(71) 'wcm (with-continuation-mark 'x 81 (k (lambda () (continuation-mark-set->list (current-continuation-marks) 'x))))) (test '(91 71 81) 'wcm (with-continuation-mark 'x 81 (non-tail (k (lambda () (non-tail (with-continuation-mark 'x 91 (continuation-mark-set->list (current-continuation-marks) 'x)))))))) (test '(91 81) 'wcm (with-continuation-mark 'x 81 (non-tail (k (lambda () (with-continuation-mark 'x 91 (continuation-mark-set->list (current-continuation-marks) 'x))))))) (test '(91) 'wcm (with-continuation-mark 'x 81 (k (lambda () (with-continuation-mark 'x 91 (continuation-mark-set->list (current-continuation-marks) 'x)))))) (let ([k2 (with-continuation-mark 'x 101 (call-with-continuation-prompt (lambda () (with-continuation-mark 'x 111 (non-tail (k (lambda () ((call-with-composable-continuation (lambda (k2) (test (if blocked? '(71 111) '(71 111 101)) continuation-mark-set->list (current-continuation-marks access-tag) 'x access-tag) (lambda () k2)))))))))))]) (test '(71 111) continuation-mark-set->list (continuation-marks k2) 'x) (test '(71 111) k2 (lambda () (continuation-mark-set->list (current-continuation-marks) 'x))) (test 71 k2 (lambda () (continuation-mark-set-first #f 'x))) (test '(71 111 121) 'wcm (with-continuation-mark 'x 121 (non-tail (k2 (lambda () (continuation-mark-set->list (current-continuation-marks) 'x)))))) ) (let ([k2 (with-continuation-mark 'x 101 (call-with-continuation-prompt (lambda () (with-continuation-mark 'x 111 (k (lambda () ((call-with-composable-continuation (lambda (k2) (test (if blocked? '(71) '(71 101)) continuation-mark-set->list (current-continuation-marks access-tag) 'x access-tag) (lambda () k2))))))))))]) (test '(71) continuation-mark-set->list (continuation-marks k2) 'x) (test '(71) k2 (lambda () (continuation-mark-set->list (current-continuation-marks) 'x))) (test 71 k2 (lambda () (continuation-mark-set-first #f 'x))) (test '(71 121) 'wcm (with-continuation-mark 'x 121 (non-tail (k2 (lambda () (continuation-mark-set->list (current-continuation-marks) 'x))))))))) (go (default-continuation-prompt-tag) #t) (let ([p2 (make-continuation-prompt-tag 'p2)]) (call-with-continuation-prompt (lambda () (go p2 #f)) p2))) ;; Check interaction of dynamic winds, continuation composition, and continuation marks (let ([pre-saw-xs null] [post-saw-xs null] [pre-saw-ys null] [post-saw-ys null]) (let ([k (call-with-continuation-prompt (lambda () (with-continuation-mark 'x 77 (dynamic-wind (lambda () (set! pre-saw-xs (continuation-mark-set->list (current-continuation-marks) 'x)) (set! pre-saw-ys (continuation-mark-set->list (current-continuation-marks) 'y))) (lambda () ((call-with-composable-continuation (lambda (k) (lambda () k))))) (lambda () (set! post-saw-xs (continuation-mark-set->list (current-continuation-marks) 'x)) (set! post-saw-ys (continuation-mark-set->list (current-continuation-marks) 'y)))))))]) (test '(77) values pre-saw-xs) (test '() values pre-saw-ys) (test '(77) values post-saw-xs) (test '() values post-saw-ys) (let ([jump-in (lambda (wrap r-val y-val) (test r-val 'wcm (wrap (lambda (esc) (with-continuation-mark 'y y-val (k (lambda () (esc))))))) (test '(77) values pre-saw-xs) (test (list y-val) values pre-saw-ys) (test '(77) values post-saw-xs) (test (list y-val) values post-saw-ys) (let ([k3 (call-with-continuation-prompt (lambda () ((call-with-composable-continuation (lambda (k) (lambda () k))))))]) (test r-val 'wcm (wrap (lambda (esc) (k3 (lambda () (with-continuation-mark 'y y-val (k (lambda () (k3 (lambda () (esc)))))))))))))]) (jump-in (lambda (f) (f (lambda () 10))) 10 88) (jump-in (lambda (f) (let/cc esc (f (lambda () (esc 20))))) 20 99) (printf "here\n") (jump-in (lambda (f) (let ([p1 (make-continuation-prompt-tag)]) (call-with-continuation-prompt (lambda () (f (lambda () (abort-current-continuation p1 (lambda () 30))))) p1))) 30 111) (void)))) ;; Tail meta-calls should overwrite continuation marks (let ([k (call-with-continuation-prompt (lambda () ((call-with-composable-continuation (lambda (k) (lambda () k))))))]) (with-continuation-mark 'n #f (let loop ([n 10]) (unless (zero? n) (with-continuation-mark 'n n (k (lambda () (test (list n) continuation-mark-set->list (current-continuation-marks) 'n) (loop (sub1 n))))))))) ;; Tail meta-calls should propagate cont marks (let ([k (call-with-continuation-prompt (lambda () ((call-with-composable-continuation (lambda (k) (lambda () k))))))]) (with-continuation-mark 'n 10 (let loop ([n 10]) (test n continuation-mark-set-first #f 'n) (test (list n) continuation-mark-set->list (current-continuation-marks) 'n) (unless (zero? n) (k (lambda () (with-continuation-mark 'n (sub1 n) (loop (sub1 n))))))))) ;; Captured mark should replace installed mark (let ([k (call-with-continuation-prompt (lambda () (with-continuation-mark 'n #t ((call-with-composable-continuation (lambda (k) (lambda () k)))))))]) (with-continuation-mark 'n #f (let loop ([n 10]) (unless (zero? n) (with-continuation-mark 'n n (k (lambda () (test (list #t) continuation-mark-set->list (current-continuation-marks) 'n) (test #t continuation-mark-set-first #f 'n) (loop (sub1 n))))))))) ;; ---------------------------------------- ;; Olivier Danvy's traversal ;; Shift & reset via composable and abort (let () (define traverse (lambda (xs) (letrec ((visit (lambda (xs) (if (null? xs) '() (visit (call-with-composable-continuation (lambda (k) (abort-current-continuation (default-continuation-prompt-tag) (let ([v (cons (car xs) (call-with-continuation-prompt (lambda () (k (cdr xs)))))]) (lambda () v)))))))))) (call-with-continuation-prompt (lambda () (visit xs)))))) (test '(1 2 3 4 5) traverse '(1 2 3 4 5))) ;; Shift & reset using composable and call/cc (let () (define call-in-application-context (call-with-continuation-prompt (lambda () ((call-with-current-continuation (lambda (k) (lambda () k))))))) (define traverse (lambda (xs) (letrec ((visit (lambda (xs) (if (null? xs) '() (visit (call-with-composable-continuation (lambda (k) (call-in-application-context (lambda () (cons (car xs) (call-with-continuation-prompt (lambda () (k (cdr xs)))))))))))))) (call-with-continuation-prompt (lambda () (visit xs)))))) (test '(1 2 3 4 5) traverse '(1 2 3 4 5))) ;; control and prompt using composable and abort (let () (define traverse (lambda (xs) (letrec ((visit (lambda (xs) (if (null? xs) (list-tail '() 0) (visit (call-with-composable-continuation (lambda (k) (abort-current-continuation (default-continuation-prompt-tag) (lambda () (cons (car xs) (k (cdr xs)))))))))))) (call-with-continuation-prompt (lambda () (visit xs)))))) (test '(5 4 3 2 1) traverse '(1 2 3 4 5))) ;; control and prompt using composable and call/cc (let () (define call-in-application-context (call-with-continuation-prompt (lambda () ((call-with-current-continuation (lambda (k) (lambda () k))))))) (define traverse (lambda (xs) (letrec ((visit (lambda (xs) (if (null? xs) (list-tail '() 0) (visit (call-with-composable-continuation (lambda (k) (call-in-application-context (lambda () (cons (car xs) (k (cdr xs)))))))))))) (call-with-continuation-prompt (lambda () (visit xs)))))) (test '(5 4 3 2 1) traverse '(1 2 3 4 5))) ;; ---------------------------------------- ;; Check unwinding of runstack overflows on prompt escape (let ([try (lambda (thread m-top n-top do-mid-stream do-abort) (let ([result #f]) (thread-wait (thread (lambda () (set! result (let pre-loop ([m m-top]) (if (zero? m) (list (do-mid-stream (lambda () (call-with-continuation-prompt (lambda () (let loop ([n n-top]) (if (zero? n) (do-abort (lambda () (abort-current-continuation (default-continuation-prompt-tag) (lambda () 5000)))) (+ (loop (sub1 n)))))))))) (list (car (pre-loop (sub1 m)))))))))) (test '(5000) values result)))]) (try thread 5000 10000 (lambda (mid) (mid)) (lambda (abort) (abort))) (try thread 5000 10000 (lambda (mid) (mid)) (lambda (abort) ((call-with-continuation-prompt (lambda () ((call-with-composable-continuation (lambda (k) (lambda () k)))))) (lambda () 5000)))) (try thread 5000 10000 (lambda (mid) (mid)) (lambda (abort) ((call-with-continuation-prompt (lambda () ((call/cc (lambda (k) (lambda () k)))))) (lambda () 5000)))) (try thread 5000 10000 (lambda (mid) (mid)) (lambda (abort) (((call/cc (lambda (k) (lambda () k)))) (lambda () (lambda (x) 5000))))) (try thread 5000 10000 (lambda (mid) (call-with-continuation-barrier mid)) (lambda (abort) (((call/cc (lambda (k) (lambda () k)))) (lambda () (lambda (x) 5000))))) (let ([p (make-continuation-prompt-tag 'p)]) (try (lambda (f) (thread (lambda () (call-with-continuation-prompt f p)))) 5000 10000 (lambda (mid) (mid)) (lambda (abort) ((call/cc (lambda (k) (thread-wait (thread (lambda () (call-with-continuation-prompt (lambda () (k abort)) p)))) (lambda () (abort-current-continuation p void))) p))))) ) (test-breaks-ok) ;; ---------------------------------------- ;; Some repeats, but ensure a continuation prompt ;; and check d-w interaction. (let ([output null]) (call-with-continuation-prompt (lambda () (dynamic-wind (lambda () (set! output (cons 'in output))) (lambda () (let ([finished #f]) (define (go) (let ([p1 (make-continuation-prompt-tag)] [counter 10]) (let ([k (call-with-continuation-prompt (lambda () ((call/cc (lambda (k) (lambda () k)) p1))) p1)]) (let ([k2 (list (call-with-continuation-prompt (lambda () (k (lambda () ((let/cc k (lambda () k)))))) p1))]) (current-milliseconds) (if (procedure? (car k2)) ((car k2) (lambda () (if (zero? counter) 10 (begin (set! counter (sub1 counter)) ((let/cc k (lambda () k))))))) (values '(10) values k2)) (set! finished 'finished))))) (go))) (lambda () (set! output (cons 'out output))))) (default-continuation-prompt-tag) void) (test '(out in) values output)) (let ([output null]) (call-with-continuation-prompt (lambda () (dynamic-wind (lambda () (set! output (cons 'in output))) (lambda () (let ([p1 (make-continuation-prompt-tag)]) (let/cc esc (let ([k (call-with-continuation-prompt (lambda () ((call-with-composable-continuation (lambda (k) (lambda () k)) p1))) p1)]) (/ (k (lambda () (esc 0)))))))) (lambda () (set! output (cons 'out output))))) (default-continuation-prompt-tag) void) (test '(out in) values output)) ;;---------------------------------------- ;; tests invoking delimited captures in dynamic-wind pre- and post-thunks ;; Arrange for a post-thunk to remove a target ;; for an escape: (err/rt-test (let ([p1 (make-continuation-prompt-tag 'p1)] [exit-k #f]) (let ([x (let/ec esc (call-with-continuation-prompt (lambda () (dynamic-wind (lambda () (void)) (lambda () (esc 'done)) (lambda () ((call/cc (lambda (k) (set! exit-k k) (lambda () 10)) p1)) (printf "post\n")))) p1))]) (call-with-continuation-barrier (lambda () (call-with-continuation-prompt (lambda () (exit-k (lambda () 'hi))) p1))))) exn:fail:contract:continuation?) ;; Same thing, but escape via prompt: (err/rt-test (let ([p1 (make-continuation-prompt-tag 'p1)] [p2 (make-continuation-prompt-tag 'p2)] [output null] [exit-k #f]) (let ([x (call-with-continuation-prompt (lambda () (call-with-continuation-prompt (lambda () (dynamic-wind (lambda () (void)) (lambda () (abort-current-continuation p2 1 2 3)) (lambda () ((call/cc (lambda (k) (set! exit-k k) (lambda () 10)) p1)) (set! output (cons 'post output))))) p1)) p2 void)]) (call-with-continuation-barrier (lambda () (call-with-continuation-prompt (lambda () (exit-k (lambda () 'hi))) p1))))) exn:fail:contract?) ;; Arrange for a barrier to interfere with a continuation ;; jump after dynamic-winds are already being processed: (let ([p1 (make-continuation-prompt-tag 'p1)] [output null] [exit-k #f]) (let ([go (lambda (launch) (let ([k (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-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) (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 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)) ;; Again, more checking of output (let ([p1 (make-continuation-prompt-tag 'p1)] [p2 (make-continuation-prompt-tag 'p2)] [output null] [exit-k #f]) ;; Set up a prompt tp jump to: (call-with-continuation-prompt (lambda () (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 () (abort-current-continuation p2 "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))))) p2 (lambda (v) (set! output (cons 'orig output)))) ;; Now call, redirecting the escape to here: (call-with-continuation-prompt (lambda () (call-with-continuation-prompt (lambda () (exit-k (lambda () 10))) p1)) p2 (lambda (v) (set! output (cons 'new output)))) (test '(new inner orig outer inner) values output)) ;; abort past a tag (test 10 values (let ([p1 (make-continuation-prompt-tag)] [p2 (make-continuation-prompt-tag)]) (call-with-continuation-prompt (lambda () (call/cc (lambda (k) (call-with-continuation-prompt (lambda () (k 10)) p2)) p1)) p1))) ;; Check that a prompt is not somehow tied to its original ;; barrier, so that jumps are not allowed when they should ;; be: (test 0 values (let ([p1 (make-continuation-prompt-tag 'p1)] [p2 (make-continuation-prompt-tag 'p2)]) (let ([k (call-with-continuation-prompt (lambda () (call-with-continuation-prompt (lambda () ((call-with-current-continuation (lambda (k) (lambda () k)) p2))) p1)) p2)]) (call-with-continuation-barrier (lambda () (call-with-continuation-barrier (lambda () (let ([k1 (call-with-continuation-prompt (lambda () (k (lambda () ;; prompt for p1 has been restored (call/cc (lambda (k1) k1) p1)))) p2)]) (call-with-continuation-prompt (lambda () (k1 0)) p1))))))))) (test 12 values (let ([p1 (make-continuation-prompt-tag 'p1)]) (let ([k (call-with-continuation-barrier (lambda () (call-with-continuation-prompt (lambda () ((call-with-current-continuation (lambda (k) (lambda () k)) p1))) p1)))]) (call-with-continuation-barrier (lambda () (call-with-continuation-barrier (lambda () (call-with-continuation-barrier (lambda () (call-with-continuation-prompt (lambda () (let/cc w (call-with-continuation-prompt (lambda () (k (lambda () (w 12)))) p1))))))))))))) ;; Test capturing and invoking a composable continuation in a post thunk (let () (define call/pt call-with-continuation-prompt) (define call/comp-cc call-with-composable-continuation) (define (go p0 direct?) (define accum null) (define (print v) (set! accum (append accum (list v)))) (define a #f) (define do-a? #t) (call/pt (lambda () (dynamic-wind (lambda () (print 1)) (lambda () (begin (dynamic-wind (lambda () (print 2)) (lambda () ((call/cc (lambda (k) (begin (set! a k) (lambda () 12))) p0))) (lambda () (print 3))) (dynamic-wind (lambda () (print 4)) (lambda () (if do-a? (begin (set! do-a? #f) (a (lambda () 11))) 12)) (lambda () (begin (print 5) (call/comp-cc (lambda (k) (if direct? (k 10) (call/pt (lambda () (k 10)) p0 (lambda (x) x)))) p0)))))) (lambda () (print 6)))) p0 (lambda (x) x)) accum) (test '(1 2 3 4 5 1 6 2 3 4 5 1 6 6) go (default-continuation-prompt-tag) #t) (test '(1 2 3 4 5 1 6 2 3 4 5 1 6 6) go (make-continuation-prompt-tag) #t) (test '(1 2 3 4 5 1 2 3 4 5 1 6 6 2 3 4 5 1 6 6) go (default-continuation-prompt-tag) #f) (test '(1 2 3 4 5 1 2 3 4 5 1 6 6 2 3 4 5 1 6 6) go (make-continuation-prompt-tag) #f)) ;; ---------------------------------------- ;; Run two levels of continuations where an explicit ;; prompt in a capturing thread is represented by an ;; implicit prompt in the calling thread. (let () (define (go wrap) (let () (define (foo thunk) (call-with-continuation-prompt (lambda () (wrap (lambda () (let/cc ret (let ([run? #f]) (let/cc run (thread (lambda () (sync (system-idle-evt)) (set! run? #t) (run)))) (when run? (ret (thunk)))))))))) (define s (make-semaphore)) (foo (lambda () (semaphore-post s))) (test s sync s))) (go (lambda (f) (f))) (go (lambda (f) (dynamic-wind void f void)))) ;; ---------------------------------------- ;; Second continuation spans two meta-continuations, ;; and cuts the deeper meta-continuation in half: (test '("x1") 'nested-half (let* ([says null] [say (lambda (s) (set! says (cons s says)))] [a (make-continuation-prompt-tag 'a)] [b (make-continuation-prompt-tag 'b)]) (let ([ak (with-continuation-mark 'x "x0" (call-with-continuation-prompt (lambda () (with-continuation-mark 'y "y0" (let ([bk (call-with-continuation-prompt (lambda () (let ([f (call-with-composable-continuation (lambda (k) (lambda () k)) b)]) (say "bcall") (begin0 (f) (say "breturn")))) b)]) (call-with-continuation-prompt (lambda () ((bk (lambda () (let ([f (call/cc (lambda (k) (lambda () (lambda () k))) a)]) (begin0 (f) (say "areturn"))))))) b)))) a))]) (with-continuation-mark 'x "x1" (call-with-continuation-prompt (lambda () (ak (lambda () (lambda () (continuation-mark-set->list (current-continuation-marks) 'x))))) a))))) ;; ---------------------------------------- ;; Try long chain of composable continuations (let ([long-loop (lambda (on-overflow) (let ([v (make-vector 6)]) (vector-set-performance-stats! v) (let ([overflows (vector-ref v 5)]) ;; Although this is a constant-space loop, the implementation ;; pushes each captured continuation further and further down ;; the C stack. Eventually, the relevant segment wraps around, ;; with an overflow. Push a little deeper and then capture ;; that. (let loop ([n 0][fuel #f]) (vector-set-performance-stats! v) (cond [(and (not fuel) ((vector-ref v 5) . > . overflows)) (begin (printf "Overflow at ~a\n" n) (loop n 5))] [(and fuel (zero? fuel)) (on-overflow)] [else ((call-with-continuation-prompt (lambda () ((call-with-composable-continuation (lambda (k) (lambda (n f) k))) (add1 n) (and fuel (sub1 fuel))))) loop)])))))] [once-k #f]) (printf "Breaking long chain...\n") (let ([t (thread (lambda () (long-loop void)))]) (sleep 0.05) (break-thread t) (sync (system-idle-evt)) (test #f thread-running? t)) (printf "Trying long chain...\n") (let ([k (long-loop (lambda () ((let/cc k (lambda () k)))))]) (when (procedure? k) (set! once-k k) (k (lambda () 17))) (test #t procedure? once-k) (test k values 17) (err/rt-test (call-with-continuation-barrier (lambda () (once-k 18))) exn:fail:contract:continuation?)) (printf "Trying long chain again...\n") (let ([k (call-with-continuation-prompt (lambda () (long-loop (lambda () ((call-with-composable-continuation (lambda (k) (lambda () k))))))))]) (test 18 k (lambda () 18)) (err/rt-test (k (lambda () (/ 0))) exn:fail:contract:divide-by-zero?) (test 45 call-with-continuation-prompt (lambda () (k (lambda () (abort-current-continuation (default-continuation-prompt-tag) (lambda () 45))))))))