1235 lines
33 KiB
Racket
1235 lines
33 KiB
Racket
#lang racket
|
|
|
|
(require redex
|
|
"grammar.ss"
|
|
"meta.ss"
|
|
"reduce.ss")
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Abbreviations:
|
|
|
|
;; The classic (let ([v (call/cc call/cc)])
|
|
;; ((call/cc call/cc) v))
|
|
(define call/cc-loop
|
|
`(<>
|
|
() []
|
|
(% 0
|
|
((λ (v) ((call/cc (λ (x) (call/cc x 0)) 0) v))
|
|
(call/cc (λ (x) (call/cc x 0)) 0))
|
|
(λ (x) x))))
|
|
|
|
(define (show prog)
|
|
(stepper :-> prog))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Tests
|
|
(define (test desc expr result)
|
|
(let ([r (car (apply-reduction-relation* :-> expr))])
|
|
(unless (equal? r result)
|
|
(printf "~s:\n~s\n" desc expr)
|
|
(printf "=> ~s\n\n" r)
|
|
(error 'test "expected ~s" result)))
|
|
(set! tests-passed (add1 tests-passed)))
|
|
(define tests-passed 0)
|
|
|
|
;; Basic ----------------------------------------
|
|
|
|
(define (basic-tests)
|
|
(test "(λx.e)[y←v] ≠ λy.(e[x←y][y←v])"
|
|
'(<>
|
|
([k 4]) []
|
|
(((λ (k1) (λ (k) k))
|
|
(λ () k))
|
|
0))
|
|
'(<> ([k 4]) [] 0))
|
|
(test "(λx.e)[y←v] ≠ λz.(e[x←z][y←v]) if z ∈ FV(e)"
|
|
'(<>
|
|
([k2 5])
|
|
()
|
|
(((λ (k1) (λ (k) k2))
|
|
(λ () k))
|
|
0))
|
|
'(<> ([k2 5]) [] 5))
|
|
(test "basic dw"
|
|
'(<>
|
|
() []
|
|
(dynamic-wind (λ () (print 1))
|
|
(λ () (print 2))
|
|
(λ () (print 3))))
|
|
'(<> () (1 2 3) #f))
|
|
(test "call/cc dw"
|
|
'(<>
|
|
() []
|
|
(%
|
|
0
|
|
(call/cc
|
|
(λ (k)
|
|
(dynamic-wind (λ () (print 1))
|
|
(λ () (k 0))
|
|
(λ () (print 3))))
|
|
0)
|
|
(λ (x) x)))
|
|
'(<> () (1 3) 0))
|
|
(test "abort"
|
|
'(<>
|
|
() []
|
|
(%
|
|
0
|
|
(+ 10 (abort 0 7))
|
|
(λ (x) (+ x 1))))
|
|
'(<>
|
|
() []
|
|
8))
|
|
(test "abort inner"
|
|
'(<>
|
|
() []
|
|
(%
|
|
0
|
|
(+ 10
|
|
(%
|
|
1
|
|
(abort 1 7)
|
|
(λ (x) (+ x 1))))
|
|
(λ (x) (+ x 2))))
|
|
'(<>
|
|
() []
|
|
18))
|
|
(test "abort outer"
|
|
'(<>
|
|
() []
|
|
(%
|
|
0
|
|
(+ 10
|
|
(%
|
|
1
|
|
(abort 0 7)
|
|
(λ (x) (+ x 1))))
|
|
(λ (x) (+ x 2))))
|
|
'(<>
|
|
() []
|
|
9))
|
|
(test "abort inner with same tag"
|
|
'(<>
|
|
() []
|
|
(%
|
|
0
|
|
(+ 10
|
|
(%
|
|
0
|
|
(abort 0 7)
|
|
(λ (x) (+ x 1))))
|
|
(λ (x) (+ x 2))))
|
|
'(<>
|
|
() []
|
|
18))
|
|
(test "abort handler in tail position"
|
|
'(<>
|
|
() []
|
|
(%
|
|
0
|
|
(call/cm
|
|
100 1
|
|
(λ ()
|
|
(%
|
|
1
|
|
(abort 1 (λ ()
|
|
(call/cm
|
|
100 2
|
|
(λ ()
|
|
(current-marks 100 0)))))
|
|
(λ (f)
|
|
(f)))))
|
|
(λ (x) x)))
|
|
'(<>
|
|
() []
|
|
(list 2)))
|
|
(test "abort dw"
|
|
'(<>
|
|
() []
|
|
(%
|
|
0
|
|
(call/cc
|
|
(λ (k)
|
|
(dynamic-wind (λ () (print 1))
|
|
(λ () (abort 0 7))
|
|
(λ () (print 3))))
|
|
0)
|
|
(λ (x) (+ x 1))))
|
|
'(<> () (1 3) 8))
|
|
(test "abort tag eval"
|
|
'(<>
|
|
() []
|
|
(% (print 1) 2 3))
|
|
'(<> () [1] 2))
|
|
(test "abort handler eval"
|
|
'(<>
|
|
() []
|
|
(% 1 2 (print 3)))
|
|
'(<> () [3] 2))
|
|
(test "call/cc 2 levels dw"
|
|
'(<>
|
|
()
|
|
[]
|
|
(%
|
|
0
|
|
(call/cc
|
|
(λ (k)
|
|
(dynamic-wind
|
|
(λ () (print 1))
|
|
(λ ()
|
|
(dynamic-wind
|
|
(λ () (print 2))
|
|
(λ ()
|
|
(k 10))
|
|
(λ () (print 3))))
|
|
(λ () (print 4))))
|
|
0)
|
|
(λ (x) x)))
|
|
'(<> () [1 2 3 4] 10))
|
|
(test "abort 2 levels dw"
|
|
'(<>
|
|
()
|
|
[]
|
|
(%
|
|
0
|
|
(dynamic-wind
|
|
(λ () (print 1))
|
|
(λ ()
|
|
(dynamic-wind
|
|
(λ () (print 2))
|
|
(λ ()
|
|
(abort 0 10))
|
|
(λ () (print 3))))
|
|
(λ () (print 4)))
|
|
(λ (x) (+ x 1))))
|
|
'(<> () [1 2 3 4] 11))
|
|
(test "in thunk isn't really in"
|
|
'(<>
|
|
() []
|
|
(%
|
|
0
|
|
(call/cc
|
|
(λ (k)
|
|
(dynamic-wind
|
|
(λ () (begin
|
|
(print 1)
|
|
(k 11)))
|
|
(λ () (print 2))
|
|
(λ () (print 3))))
|
|
0)
|
|
(λ (x) x)))
|
|
'(<> () [1] 11))
|
|
(test "in thunk isn't really in, but it's in surrounding"
|
|
'(<>
|
|
() []
|
|
(%
|
|
0
|
|
(call/cc
|
|
(λ (k)
|
|
(dynamic-wind
|
|
(λ () (print -1))
|
|
(λ ()
|
|
(dynamic-wind
|
|
(λ () (begin
|
|
(print 1)
|
|
(k 11)))
|
|
(λ () (print 2))
|
|
(λ () (print 3))))
|
|
(λ () (print -2))))
|
|
0)
|
|
(λ (x) x)))
|
|
'(<> () [-1 1 -2] 11))
|
|
(test "dw shared during jump"
|
|
'(<>
|
|
() []
|
|
(% 0
|
|
(dynamic-wind
|
|
(λ () (print 0))
|
|
(λ () ((call/cc (λ (f) f) 0) (λ (x) 10)))
|
|
(λ () (print 1)))
|
|
(λ (x) x)))
|
|
'(<> () [0 1] 10))
|
|
(test "dw not shared during jump"
|
|
'(<>
|
|
() []
|
|
(% 0
|
|
((dynamic-wind
|
|
(λ () (print 0))
|
|
(λ () (call/cc (λ (f) f) 0))
|
|
(λ () (print 1)))
|
|
(λ (x) 10))
|
|
(λ (x) x)))
|
|
'(<> () [0 1 0 1] 10))
|
|
(test "composable captures continuation marks"
|
|
'(<>
|
|
() []
|
|
(%
|
|
100
|
|
((λ (k) (k (λ (v) (current-marks 0 100))))
|
|
(% 0
|
|
(call/cm 0 100
|
|
(λ ()
|
|
((call/comp (λ (k) (λ (v) k)) 0)
|
|
99)) )
|
|
(λ (x) x)))
|
|
(λ (x) x)))
|
|
'(<> () [] (list 100)))
|
|
(test "continuation marks wrapping % not captured"
|
|
'(<>
|
|
() []
|
|
(%
|
|
101
|
|
((λ (k) (k (λ (v) (current-marks 0 101))))
|
|
(call/cm 0 100
|
|
(λ ()
|
|
(% 0
|
|
((call/comp (λ (k) (λ (v) k)) 0)
|
|
99)
|
|
(λ (x) x)))))
|
|
(λ (x) x)))
|
|
'(<> () [] (list)))
|
|
(test "visible marks restricted by prompt tag"
|
|
'(<>
|
|
() []
|
|
(% 101
|
|
(call/cm 0 100
|
|
(λ ()
|
|
(% 102
|
|
(call/cm 0 99
|
|
(λ ()
|
|
(current-marks 0 102)))
|
|
(λ (x) x))))
|
|
(λ (x) x)))
|
|
'(<> () [] (list 99)))
|
|
(test "visible marks not restricted by other prompt tags"
|
|
'(<>
|
|
() []
|
|
(% 101
|
|
(call/cm 0 100
|
|
(λ ()
|
|
(% 102
|
|
(call/cm 0 99
|
|
(λ ()
|
|
(current-marks 0 101)))
|
|
(λ (x) x))))
|
|
(λ (x) x)))
|
|
'(<> () [] (list 99 100)))
|
|
(test "getting marks fails if there's no prompt with the given tag"
|
|
'(<>
|
|
() []
|
|
(% 101
|
|
(call/cm 0 100
|
|
(λ ()
|
|
(current-marks 0 102)))
|
|
(λ (x) x)))
|
|
'(<> () [] (% 101 (wcm ((0 100)) (current-marks 0 102)) (λ (x) x))))
|
|
(test "pre and post thunks in a composable continuation"
|
|
'(<>
|
|
() []
|
|
((λ (f)
|
|
(f (λ (v) 10)))
|
|
(%
|
|
0
|
|
(dynamic-wind
|
|
(λ () (print 1))
|
|
(λ ()
|
|
(call/comp (λ (k) k) 0))
|
|
(λ () (print 2)))
|
|
(λ (x) x))))
|
|
'(<>
|
|
()
|
|
[1 2 1 2]
|
|
(λ (v) 10)))
|
|
(test "prompt enclosing prompt-tag expression"
|
|
'(<> () []
|
|
(% 0
|
|
(% (abort 0 1) 2 3)
|
|
(λ (x) x)))
|
|
'(<> () [] 1))
|
|
(test "prompt enclosing prompt-handler expression"
|
|
'(<> () []
|
|
(% 0
|
|
(begin
|
|
(% 0 1 (abort 0 2))
|
|
(print 3))
|
|
(λ (x) x)))
|
|
'(<> () [] 2))
|
|
(test "prompt-tag position in continuation-marks context"
|
|
'(<> () []
|
|
(% 0
|
|
(call/cm
|
|
1 2
|
|
(λ ()
|
|
(% (abort 0 (current-marks 1 0))
|
|
3
|
|
4)))
|
|
(λ (x) x)))
|
|
'(<> () [] (list 2)))
|
|
(test "prompt-handler position in continuation-marks context"
|
|
'(<> () []
|
|
(% 0
|
|
(call/cm
|
|
1 2
|
|
(λ ()
|
|
(call/cm
|
|
1 3
|
|
(% 0
|
|
4
|
|
(abort 0 (current-marks 1 0))))))
|
|
(λ (x) x)))
|
|
'(<> () [] (list 2)))
|
|
(test "if-test position in continuation-marks context"
|
|
'(<> ()
|
|
[]
|
|
(% 0
|
|
(call/cm
|
|
1 2
|
|
(λ () (if (abort 0 (current-marks 1 0)) 3 4)))
|
|
(λ (x) x)))
|
|
'(<> () [] (list 2)))
|
|
(test "dw in continuation-marks context"
|
|
'(<> ()
|
|
[]
|
|
(% 0
|
|
(call/cm 1 2
|
|
(λ ()
|
|
(dynamic-wind
|
|
(λ () #f)
|
|
(λ () (current-marks 1 0))
|
|
(λ () #t))))
|
|
(λ (x) x)))
|
|
'(<> () [] (list 2)))
|
|
(test "wcm without key in continuation-marks context"
|
|
'(<> ()
|
|
[]
|
|
(% 0
|
|
(wcm ([1 2])
|
|
((λ (x) x)
|
|
(wcm ([3 4])
|
|
(current-marks 3 0))))
|
|
(λ (x) x)))
|
|
'(<> () [] (list 4))))
|
|
|
|
;; R6RS dynamic-wind ----------------------------------------
|
|
|
|
(define (r6rs-dw-tests)
|
|
(test "out thunk is really out"
|
|
'(<>
|
|
([n 0]
|
|
[do-jump? #t]
|
|
[k-out #f])
|
|
[]
|
|
(%
|
|
0
|
|
(begin
|
|
(begin
|
|
(call/cc
|
|
(λ (k)
|
|
(dynamic-wind
|
|
(λ () (set! n (+ n 1)))
|
|
(λ () (k 99))
|
|
(λ ()
|
|
(begin
|
|
(set! n (+ n 1))
|
|
(call/cc (λ (k) (set! k-out k)) 0)))))
|
|
0)
|
|
(if do-jump?
|
|
(begin
|
|
(set! do-jump? #f)
|
|
(k-out 0))
|
|
11))
|
|
(begin
|
|
(set! k-out #f)
|
|
n))
|
|
(λ (x) x)))
|
|
'(<> ([n 2] [do-jump? #f] [k-out #f]) [] 2))
|
|
(test "out thunk is really out during trimming"
|
|
'(<>
|
|
([n 0]
|
|
[do-jump? #t]
|
|
[k-out #f])
|
|
[]
|
|
(%
|
|
0
|
|
(begin
|
|
(call/cc
|
|
(λ (k)
|
|
(dynamic-wind
|
|
(λ () (set! n (+ n 1)))
|
|
(λ () (k 100))
|
|
(λ ()
|
|
(begin
|
|
(set! n (+ n 1))
|
|
(call/cc (λ (k) (set! k-out k)) 0)))))
|
|
0)
|
|
(begin
|
|
(if do-jump?
|
|
(begin
|
|
(set! do-jump? #f)
|
|
(k-out 0))
|
|
11)
|
|
(begin
|
|
(set! k-out #f)
|
|
n)))
|
|
(λ (x) x)))
|
|
'(<> ([n 2] [do-jump? #f] [k-out #f]) () 2))
|
|
(test "jumping during the results of trimming, pre-thunk"
|
|
'(<>
|
|
([pre-count 0]
|
|
[pre-jump? #f]
|
|
[after-jump? #t]
|
|
[grab? #t]
|
|
[the-k #f])
|
|
[]
|
|
(%
|
|
0
|
|
(begin
|
|
(dynamic-wind
|
|
(λ ()
|
|
(begin
|
|
(set! pre-count (+ pre-count 1))
|
|
(if pre-jump?
|
|
(begin
|
|
(set! pre-jump? #f)
|
|
(begin
|
|
(set! after-jump? #f)
|
|
(the-k 999)))
|
|
999)))
|
|
(λ ()
|
|
(if grab?
|
|
(call/cc
|
|
(λ (k)
|
|
(begin
|
|
(set! grab? #f)
|
|
(set! the-k k)))
|
|
0)
|
|
999))
|
|
(λ () (+ 0 10)))
|
|
(begin
|
|
(if after-jump?
|
|
(begin
|
|
(set! pre-jump? #t)
|
|
(the-k 999))
|
|
999)
|
|
(begin
|
|
(set! the-k #f) ;; just to make testing simpler
|
|
pre-count)))
|
|
(λ (x) x)))
|
|
'(<>
|
|
([pre-count 3]
|
|
[pre-jump? #f]
|
|
[after-jump? #f]
|
|
[grab? #f]
|
|
[the-k #f])
|
|
()
|
|
3))
|
|
(test "jumping during the results of trimming, post-thunk"
|
|
'(<>
|
|
([post-count 0]
|
|
[post-jump? #t]
|
|
[jump-main? #t]
|
|
[grab? #t]
|
|
[the-k #f])
|
|
[]
|
|
(%
|
|
0
|
|
(begin
|
|
(begin
|
|
(if grab?
|
|
(call/cc
|
|
(λ (k)
|
|
(begin
|
|
(set! grab? #f)
|
|
(set! the-k k)))
|
|
0)
|
|
999)
|
|
(dynamic-wind
|
|
(λ () (+ 0 1))
|
|
(λ ()
|
|
(if jump-main?
|
|
(begin
|
|
(set! jump-main? #f)
|
|
(the-k 999))
|
|
999))
|
|
(λ ()
|
|
(begin
|
|
(set! post-count (+ post-count 1))
|
|
(if post-jump?
|
|
(begin
|
|
(set! post-jump? #f)
|
|
(the-k 999))
|
|
999)))))
|
|
(begin
|
|
(set! the-k #f) ;; just to make testing simpler
|
|
post-count))
|
|
(λ (x) x)))
|
|
'(<>
|
|
([post-count 2]
|
|
[post-jump? #f]
|
|
[jump-main? #f]
|
|
[grab? #f]
|
|
[the-k #f])
|
|
[]
|
|
2))
|
|
(test "hop out one level"
|
|
'(<>
|
|
()
|
|
[]
|
|
|
|
(%
|
|
0
|
|
((dynamic-wind (λ () (print 0))
|
|
(λ () (call/cc (λ (k) k) 0))
|
|
(λ () (print 1)))
|
|
(λ (y) (print 7)))
|
|
(λ (x) x)))
|
|
'(<>
|
|
()
|
|
[0 1 0 1 7]
|
|
#f))
|
|
(test "hop out two levels"
|
|
'(<> ()
|
|
[]
|
|
(%
|
|
0
|
|
((dynamic-wind
|
|
(λ () (print 1))
|
|
(λ ()
|
|
(dynamic-wind
|
|
(λ () (print 2))
|
|
(λ () (call/cc (λ (k) k) 0))
|
|
(λ () (print 3))))
|
|
(λ () (print 4)))
|
|
(λ (y) (print 8)))
|
|
(λ (x) x)))
|
|
'(<>
|
|
()
|
|
[1 2 3 4 1 2 3 4 8]
|
|
#f))
|
|
(test "don't duplicate tail"
|
|
'(<>
|
|
()
|
|
[]
|
|
(%
|
|
0
|
|
(dynamic-wind
|
|
(λ () (print 1))
|
|
(λ ()
|
|
((dynamic-wind (λ () (print 2))
|
|
(λ () (call/cc (λ (k) k) 0))
|
|
(λ () (print 3)))
|
|
(λ (y) (print 9))))
|
|
(λ () (print 4)))
|
|
(λ (x) x)))
|
|
'(<>
|
|
()
|
|
[1 2 3 2 3 9 4]
|
|
#f))
|
|
(test "don't duplicate tail, 2 deep"
|
|
'(<>
|
|
()
|
|
[]
|
|
|
|
(%
|
|
0
|
|
(dynamic-wind
|
|
(λ () (print 1))
|
|
(λ ()
|
|
(dynamic-wind
|
|
(λ () (print 2))
|
|
(λ ()
|
|
((dynamic-wind (λ () (print 3))
|
|
(λ () (call/cc (λ (k) k) 0))
|
|
(λ () (print 4)))
|
|
(λ (y) (print 9))))
|
|
(λ () (print 5))))
|
|
(λ () (print 6)))
|
|
(λ (x) x)))
|
|
'(<>
|
|
()
|
|
[1 2 3 4 3 4 9 5 6]
|
|
#f))
|
|
(test "hop out and back into another one"
|
|
'(<>
|
|
()
|
|
[]
|
|
(%
|
|
0
|
|
((λ (ok)
|
|
(dynamic-wind (λ () (print 1))
|
|
(λ () (ok (λ (y) (print 9))))
|
|
(λ () (print 2))))
|
|
(dynamic-wind (λ () (print 3))
|
|
(λ () (call/cc (λ (k) k) 0))
|
|
(λ () (print 4))))
|
|
(λ (x) x)))
|
|
'(<>
|
|
()
|
|
[3 4 1 2 3 4 1 9 2]
|
|
#f))
|
|
(test "hop out one level and back in two levels"
|
|
'(<>
|
|
()
|
|
[]
|
|
(%
|
|
0
|
|
((λ (ok)
|
|
(dynamic-wind
|
|
(λ () (print 1))
|
|
(λ ()
|
|
(dynamic-wind
|
|
(λ () (print 2))
|
|
(λ () (ok (λ (y) (print 9))))
|
|
(λ () (print 3))))
|
|
(λ () (print 4))))
|
|
(call/cc (λ (k) k) 0))
|
|
(λ (x) x)))
|
|
'(<>
|
|
()
|
|
[1 2 3 4 1 2 9 3 4]
|
|
#f))
|
|
(test "hop out two levels and back in two levels"
|
|
'(<>
|
|
()
|
|
[]
|
|
(%
|
|
0
|
|
((λ (ok)
|
|
(dynamic-wind
|
|
(λ () (print 1))
|
|
(λ ()
|
|
(dynamic-wind
|
|
(λ () (print 2))
|
|
(λ () (ok (λ (y) (print 9))))
|
|
(λ () (print 3))))
|
|
(λ () (print 4))))
|
|
(dynamic-wind
|
|
(λ () (print 5))
|
|
(λ ()
|
|
(dynamic-wind
|
|
(λ () (print 6))
|
|
(λ () (call/cc (λ (k) k) 0))
|
|
(λ () (print 7))))
|
|
(λ () (print 8))))
|
|
(λ (x) x)))
|
|
'(<>
|
|
()
|
|
[5 6 7 8 1 2 3 4 5 6 7 8 1 2 9 3 4]
|
|
#f)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; composability
|
|
|
|
(define (cont-tests)
|
|
(test "captured under new %"
|
|
'(<>
|
|
([retry #f])
|
|
[]
|
|
(begin
|
|
(%
|
|
0
|
|
(+ 18
|
|
(call/cc
|
|
(λ (k)
|
|
(begin
|
|
(set! retry k)
|
|
17))
|
|
0))
|
|
(λ (x) x))
|
|
((λ (y)
|
|
(begin
|
|
(set! retry #f)
|
|
y))
|
|
(+ 1 (%
|
|
0
|
|
(retry 10)
|
|
(λ (x) x))))))
|
|
'(<>
|
|
([retry #f])
|
|
[]
|
|
29))
|
|
(test "catch in composed"
|
|
'(<>
|
|
() []
|
|
(%
|
|
0
|
|
((λ (k)
|
|
((λ (k2)
|
|
(%
|
|
0
|
|
(k2 (list 89))
|
|
(λ (x) x)))
|
|
(%
|
|
0
|
|
(k (λ ()
|
|
(first (call/cc (λ (k2)
|
|
(cons k2 (list)))
|
|
0))))
|
|
(λ (x) x))))
|
|
(%
|
|
0
|
|
((call/cc (λ (k) (λ () k))
|
|
0))
|
|
(λ (x) x)))
|
|
(λ (x) x)))
|
|
'(<>
|
|
() []
|
|
89))
|
|
(test "simple composable"
|
|
'(<>
|
|
[] ()
|
|
((λ (k)
|
|
(k (λ () 8)))
|
|
(%
|
|
0
|
|
((call/comp
|
|
(λ (k) (λ () k))
|
|
0))
|
|
(λ (x) x))))
|
|
'(<> [] () 8))
|
|
(test "composable doesn't introduce %"
|
|
'(<>
|
|
[] ()
|
|
(%
|
|
0
|
|
((λ (k)
|
|
((λ (k2)
|
|
(if (first (rest k2))
|
|
((first k2) (list 10 #f))
|
|
(first k2)))
|
|
(k (λ ()
|
|
(call/cc (λ (k2)
|
|
(cons k2 (list #t)))
|
|
0)))))
|
|
(%
|
|
0
|
|
((call/comp
|
|
(λ (k) (λ () k))
|
|
0))
|
|
(λ (x) x)))
|
|
(λ (x) x)))
|
|
'(<>
|
|
[] ()
|
|
10))
|
|
(test "post thunk runs current continuation as composable"
|
|
'(<>
|
|
([a #f]
|
|
[do-a? #t])
|
|
[]
|
|
(%
|
|
0
|
|
(dynamic-wind
|
|
(λ () (print 1))
|
|
(λ ()
|
|
(begin
|
|
(dynamic-wind
|
|
(λ () (print 2))
|
|
(λ ()
|
|
((call/cc (λ (k)
|
|
(begin
|
|
(set! a k)
|
|
(λ () 12)))
|
|
0)))
|
|
(λ () (print 3)))
|
|
(dynamic-wind
|
|
(λ () (print 4))
|
|
(λ ()
|
|
(if do-a?
|
|
(begin
|
|
(set! do-a? #f)
|
|
(a (λ () 11)))
|
|
(begin
|
|
(set! a #f)
|
|
12)))
|
|
(λ ()
|
|
(begin
|
|
(print 5)
|
|
(call/comp
|
|
(λ (k)
|
|
(k 10))
|
|
0))))))
|
|
(λ () (print 6)))
|
|
(λ (x) x)))
|
|
'(<>
|
|
([a #f][do-a? #f])
|
|
[1 2 3 4 5 1 6 2 3 4 5 1 6 6]
|
|
12))
|
|
(test "post thunk runs current continuation as composable under %"
|
|
'(<>
|
|
([a #f]
|
|
[do-a? #t])
|
|
[]
|
|
(%
|
|
0
|
|
(dynamic-wind
|
|
(λ () (print 1))
|
|
(λ ()
|
|
(begin
|
|
(dynamic-wind
|
|
(λ () (print 2))
|
|
(λ ()
|
|
((call/cc (λ (k)
|
|
(begin
|
|
(set! a k)
|
|
(λ () 12)))
|
|
0)))
|
|
(λ () (print 3)))
|
|
(dynamic-wind
|
|
(λ () (print 4))
|
|
(λ ()
|
|
(if do-a?
|
|
(begin
|
|
(set! do-a? #f)
|
|
(a (λ () 11)))
|
|
(begin
|
|
(set! a #f)
|
|
12)))
|
|
(λ ()
|
|
(begin
|
|
(print 5)
|
|
(call/comp
|
|
(λ (k)
|
|
(%
|
|
0
|
|
(k 10)
|
|
(λ (x) x)))
|
|
0))))))
|
|
(λ () (print 6)))
|
|
(λ (x) x)))
|
|
'(<>
|
|
([a #f] [do-a? #f])
|
|
[1 2 3 4 5 1 2 3 4 5 1 6 6 2 3 4 5 1 6 6]
|
|
12))
|
|
(test "post think trims dws to run on exit"
|
|
'(<>
|
|
([output (list)]
|
|
[exit-k #f]
|
|
[done? #f])
|
|
[]
|
|
(%
|
|
0
|
|
(begin
|
|
;; Capture a continuation w.r.t. the default prompt tag:
|
|
(call/cc
|
|
(λ (esc)
|
|
(dynamic-wind
|
|
(λ () 0)
|
|
(λ ()
|
|
;; Set a prompt for tag p1:
|
|
(%
|
|
1
|
|
|
|
(dynamic-wind
|
|
(λ () 0)
|
|
;; inside d-w, jump out:
|
|
(λ () (esc 100))
|
|
(λ ()
|
|
(begin
|
|
;; As we jump out, capture a continuation
|
|
;; w.r.t. p1:
|
|
((call/cc
|
|
(λ (k)
|
|
(begin
|
|
(set! exit-k k)
|
|
(λ () 10)))
|
|
1))
|
|
(set! output (cons 99 output)))))
|
|
(λ (x) x)))
|
|
(λ ()
|
|
;; This post thunk is not in the
|
|
;; delimited continuation captured
|
|
;; via tag p1:
|
|
(set! output (cons 101 output)))))
|
|
0)
|
|
(if done?
|
|
(begin
|
|
(set! exit-k #f)
|
|
output)
|
|
(begin
|
|
(set! done? #t)
|
|
;; Now invoke the delimited continuation, which must
|
|
;; somehow continue the jump to `esc':
|
|
(%
|
|
1
|
|
(exit-k (λ () 10))
|
|
(λ (x) x)))))
|
|
(λ (x) (x))))
|
|
'(<>
|
|
([output (list 99 101 99)]
|
|
[exit-k #f]
|
|
[done? #t])
|
|
()
|
|
(list 99 101 99)))
|
|
(test "post thunk captures continuation that is invoked without target % (gets stuck)"
|
|
'(<>
|
|
([output (list)]
|
|
[exit-k #f])
|
|
()
|
|
(%
|
|
0
|
|
((λ (k)
|
|
(abort 0
|
|
(λ ()
|
|
(%
|
|
1
|
|
(exit-k (λ () (set! exit-k #f)))
|
|
(λ (x) x)))))
|
|
(call/cc
|
|
(λ (esc)
|
|
(%
|
|
1
|
|
(dynamic-wind
|
|
(λ () 0)
|
|
(λ () (esc 100))
|
|
(λ ()
|
|
(begin
|
|
((call/cc
|
|
(λ (k)
|
|
(begin
|
|
(set! exit-k k)
|
|
(λ () 10)))
|
|
1))
|
|
(set! output (cons 101 output)))))
|
|
(λ (x) x)))
|
|
0))
|
|
(λ (f) (f))))
|
|
(term (<>
|
|
((output (list 101 101))
|
|
(exit-k #f))
|
|
()
|
|
(%
|
|
1
|
|
((cont 0
|
|
((λ (k)
|
|
(abort
|
|
0
|
|
(λ ()
|
|
(%
|
|
1
|
|
(exit-k (λ () (set! exit-k #f)))
|
|
(λ (x) x)))))
|
|
hole))
|
|
100)
|
|
(λ (x1) x1)))))
|
|
(test "similar way to get stuck, but using the pre thunk"
|
|
'(<>
|
|
([output (list)]
|
|
[exit-k #f])
|
|
()
|
|
(%
|
|
0
|
|
((λ (k)
|
|
(abort 0
|
|
(λ ()
|
|
(%
|
|
1
|
|
(exit-k (λ () (set! exit-k #f)))
|
|
(λ (x) x)))))
|
|
(call/cc
|
|
(λ (esc)
|
|
(%
|
|
1
|
|
(dynamic-wind
|
|
(λ ()
|
|
(begin
|
|
((call/cc
|
|
(λ (k)
|
|
(begin
|
|
(set! exit-k k)
|
|
(λ () 10)))
|
|
1))
|
|
(set! output (cons 101 output))))
|
|
(λ () (esc 100))
|
|
(λ () 0))
|
|
(λ (x) x)))
|
|
0))
|
|
(λ (f) (f))))
|
|
(term (<>
|
|
((output (list 101 101))
|
|
(exit-k #f))
|
|
()
|
|
(%
|
|
1
|
|
(dw
|
|
x_1 ; <--- beware: this is a fresh variable. Will it always be x_1?
|
|
(begin
|
|
((call/cc
|
|
(λ (k1)
|
|
(begin
|
|
(set! exit-k k1)
|
|
(λ () 10)))
|
|
1))
|
|
(set! output (cons 101 output)))
|
|
((cont
|
|
0
|
|
((λ (k)
|
|
(abort
|
|
0
|
|
(λ ()
|
|
(%
|
|
1
|
|
(exit-k (λ () (set! exit-k #f)))
|
|
(λ (x)
|
|
x)))))
|
|
hole))
|
|
100)
|
|
0)
|
|
(λ (x1) x1)))))
|
|
(test "loop"
|
|
'(<>
|
|
([counter (list 4 3 2 1 0)])
|
|
[]
|
|
(%
|
|
0
|
|
((λ (k)
|
|
((λ (k2)
|
|
(if (first (rest k2))
|
|
((first k2) (λ ()
|
|
(if (zero? (first counter))
|
|
(list 10 #f)
|
|
(begin
|
|
(set! counter (rest counter))
|
|
((call/cc (λ (k) (λ ()
|
|
(cons k (list #t))))
|
|
0))))))
|
|
(first k2)))
|
|
(%
|
|
1
|
|
(k (λ ()
|
|
((call/cc (λ (k) (λ ()
|
|
(cons k (list #t))))
|
|
0))))
|
|
(λ (x) x))))
|
|
(%
|
|
1
|
|
((call/cc (λ (k) (λ () k))
|
|
1))
|
|
(λ (x) x)))
|
|
(λ (x) x)))
|
|
'(<>
|
|
([counter (list 0)])
|
|
[]
|
|
10))
|
|
(void))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Chain
|
|
|
|
(define chain-defns
|
|
`([make
|
|
(λ (pre post)
|
|
(%
|
|
0
|
|
(dynamic-wind
|
|
(λ () (print pre))
|
|
(λ ()
|
|
((call/comp
|
|
(λ (k) (λ () k))
|
|
0)))
|
|
(λ () (print post)))
|
|
(λ (x) x)))]
|
|
[chain
|
|
(λ (E_1 E_2)
|
|
(%
|
|
0
|
|
(E_1 (λ ()
|
|
(E_2 (λ ()
|
|
((call/comp
|
|
(λ (k) (λ () k))
|
|
0))))))
|
|
(λ (x) x)))]
|
|
[composable->replacing
|
|
(λ (E)
|
|
(%
|
|
0
|
|
(E (λ ()
|
|
((call/cc
|
|
(λ (k) (λ () k))
|
|
0))))
|
|
(λ (x) x)))]))
|
|
|
|
(define (with-chain-bindings e)
|
|
`((λ (one-two three-four)
|
|
((λ (one-three-four-two one-NINE-three-four-two )
|
|
((λ (one-two* three-four* one-three-four-two* one-NINE-three-four-two*)
|
|
(%
|
|
0
|
|
,e
|
|
(λ (x) x)))
|
|
(composable->replacing one-two)
|
|
(composable->replacing three-four)
|
|
(composable->replacing one-three-four-two)
|
|
(composable->replacing one-NINE-three-four-two)))
|
|
(chain one-two three-four)
|
|
(chain one-two (λ (x) ((λ (z)
|
|
(begin (print 9) z))
|
|
(three-four x))))))
|
|
(make 1 2)
|
|
(make 3 4)))
|
|
|
|
(define chain-output '(1 2 3 4 1 3 4 2 1 3 4 9 2 1 2 3 4 1 3 4 2 1 3 4 9 2))
|
|
|
|
(define (chain-tests)
|
|
(test "check chain setup"
|
|
`(<>
|
|
(,@chain-defns)
|
|
[]
|
|
,(with-chain-bindings 10))
|
|
`(<>
|
|
(,@chain-defns)
|
|
[,@chain-output]
|
|
10))
|
|
(test "chain sharing"
|
|
`(<>
|
|
(,@chain-defns)
|
|
[]
|
|
,(with-chain-bindings
|
|
`(one-three-four-two* (λ ()
|
|
(one-two* (λ () 0))))))
|
|
`(<>
|
|
(,@chain-defns)
|
|
[,@chain-output 1 3 4 2]
|
|
0))
|
|
(test "chain non-sharing"
|
|
`(<>
|
|
(,@chain-defns)
|
|
[]
|
|
,(with-chain-bindings
|
|
`(one-three-four-two* (λ ()
|
|
(three-four* (λ () 0))))))
|
|
`(<>
|
|
(,@chain-defns)
|
|
[,@chain-output 1 3 4 2 3 4]
|
|
0))
|
|
(test "chain sharing with spliced frame"
|
|
`(<>
|
|
(,@chain-defns)
|
|
[]
|
|
,(with-chain-bindings
|
|
`(one-three-four-two* (λ ()
|
|
(one-NINE-three-four-two* (λ () 0))))))
|
|
`(<>
|
|
(,@chain-defns)
|
|
[,@chain-output 1 3 4 9 2]
|
|
0))
|
|
(test "chain sharing with spliced frame (skipped)"
|
|
`(<>
|
|
(,@chain-defns)
|
|
[]
|
|
,(with-chain-bindings
|
|
`(one-NINE-three-four-two* (λ ()
|
|
(one-three-four-two* (λ () 0))))))
|
|
`(<>
|
|
(,@chain-defns)
|
|
[,@chain-output 1 3 4 2]
|
|
0)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Run
|
|
|
|
(begin
|
|
(basic-tests)
|
|
(r6rs-dw-tests)
|
|
(cont-tests)
|
|
(chain-tests)
|
|
(printf "All ~s tests passed.\n" tests-passed)) |