1 | (require-library continuations simple-tests) |
---|
2 | |
---|
3 | (import continuations continuations-used simple-tests) |
---|
4 | |
---|
5 | ;;; from " A short introduction to call-with-current-continuation" |
---|
6 | ;;; http://community.scheme-wiki.org |
---|
7 | ;;; and "Continuations by example ..." |
---|
8 | ;;; http://matt.might.net/articles |
---|
9 | |
---|
10 | (define (search ok? lst) |
---|
11 | (catch return |
---|
12 | (for-each (lambda (item) |
---|
13 | (if (ok? item) |
---|
14 | (throw return item))) |
---|
15 | lst) |
---|
16 | #f)) |
---|
17 | |
---|
18 | (define (search-with-goto ok? lst) |
---|
19 | (let ((start (continuation))) |
---|
20 | (cond |
---|
21 | ((null? lst) #f) |
---|
22 | ((ok? (car lst)) (car lst)) |
---|
23 | (else |
---|
24 | (set! lst (cdr lst)) |
---|
25 | (goto start))))) |
---|
26 | |
---|
27 | ;; nonlocal return: throw and catch in different procedures |
---|
28 | (define (treat ok?) |
---|
29 | (lambda (item cont) |
---|
30 | (if (ok? item) |
---|
31 | (throw cont item)))) |
---|
32 | |
---|
33 | (define (handled-search handle lst) |
---|
34 | (catch return |
---|
35 | (for-each (lambda (item) |
---|
36 | (handle item return)) |
---|
37 | lst) |
---|
38 | #f)) |
---|
39 | |
---|
40 | ;; export continuation ... |
---|
41 | (define 1+ #f) |
---|
42 | ;; ... with catch |
---|
43 | (define (init) |
---|
44 | (+ 1 (catch cont |
---|
45 | (set! 1+ (continuation->procedure cont)) |
---|
46 | (throw cont 0)))) |
---|
47 | ;; ... with continuation |
---|
48 | (define (init-again) |
---|
49 | (+ 1 (let ((cc (continuation))) |
---|
50 | (cond |
---|
51 | ((continuation? cc) |
---|
52 | (set! 1+ (continuation->procedure cc)) |
---|
53 | (throw cc 0)) |
---|
54 | (else cc))))) |
---|
55 | |
---|
56 | (run-tests |
---|
57 | (= (search even? '(1 2 3)) 2) |
---|
58 | (not (search even? '(1 3))) |
---|
59 | (= (search-with-goto odd? '(0 1 2 3)) 1) |
---|
60 | (not (search-with-goto odd? '(0 2))) |
---|
61 | (= (handled-search (treat even?) '(1 2 3)) 2) |
---|
62 | "AMB" |
---|
63 | (define amb (make-amb)) |
---|
64 | (define (pythagoras . choices) |
---|
65 | (let ((a (apply (amb 'choose) choices)) |
---|
66 | (b (apply (amb 'choose) choices)) |
---|
67 | (c (apply (amb 'choose) choices))) |
---|
68 | ((amb 'assert) (= (* c c) (+ (* a a) (* b b)))) |
---|
69 | ((amb 'assert) (< b a)) |
---|
70 | (list a b c))) |
---|
71 | (equal? (pythagoras 1 2 3 4 5 6 7) '(4 3 5)) |
---|
72 | "COOPERATIVE THREADS" |
---|
73 | (define threads (make-threads)) |
---|
74 | (equal? |
---|
75 | (let ((result '())) |
---|
76 | (define make-thunk |
---|
77 | (let ((counter 10)) |
---|
78 | (lambda (name) |
---|
79 | (rec (loop) |
---|
80 | (if (< counter 0) |
---|
81 | ((threads 'quit))) |
---|
82 | (set! result (cons (cons name counter) result)) |
---|
83 | (set! counter (- counter 1)) |
---|
84 | ((threads 'yield)) |
---|
85 | (loop))))) |
---|
86 | ((threads 'spawn) (make-thunk 'a)) |
---|
87 | ((threads 'spawn) (make-thunk 'aa)) |
---|
88 | ((threads 'spawn) (make-thunk 'aaa)) |
---|
89 | ((threads 'start)) |
---|
90 | (reverse result)) |
---|
91 | '((a . 10) (aa . 9) (aaa . 8) (a . 7) (aa . 6) (aaa . 5) |
---|
92 | (a . 4) (aa . 3) (aaa . 2) (a . 1) (aa . 0))) |
---|
93 | "ITERATORS" |
---|
94 | (equal? |
---|
95 | (let ((tree-iterator (lambda (tree) |
---|
96 | (lambda (yield) |
---|
97 | (let walk ((tree tree)) |
---|
98 | (if (pair? tree) |
---|
99 | (begin (walk (car tree)) |
---|
100 | (walk (cdr tree))) |
---|
101 | (yield tree)))))) |
---|
102 | (result '())) |
---|
103 | (iterate var (tree-iterator '(3 . ((4 . 5) . 6))) |
---|
104 | (set! result (cons var result))) |
---|
105 | (reverse result)) |
---|
106 | '(3 4 5 6)) |
---|
107 | ) |
---|