source: project/release/4/continuations/trunk/tests/run.scm @ 33737

Last change on this file since 33737 was 33737, checked in by juergen, 21 months ago

continuations 1.4.1 with current-continuation renamed escape-procedure

File size: 4.4 KB
Line 
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(compound-test (continuations)
11
12  (define-test (CONTINUATION-INTERFACE)
13    (check
14      ;; export continuation ...
15      (define 1+ #f)
16      ;; ... with catch
17      (define (init)
18        (+ 1 (catch cont
19                    (set! 1+ (continuation->procedure cont))
20                    (throw cont 0))))
21      ;; ... with continuation
22      (define (init-again)
23        (+ 1 (let ((cc (continuation)))
24               (cond
25                 ((continuation? cc)
26                  (set! 1+ (continuation->procedure cc))
27                  (throw cc 0))
28                 (else cc)))))
29      (define (search ok? lst)
30        (catch return
31               (for-each (lambda (item)
32                           (if (ok? item)
33                             (throw return item)))
34                         lst)
35               #f))
36      (define (search-with-goto ok? lst)
37        (let ((start (continuation)))
38          (cond
39            ((null? lst) #f)
40            ((ok? (car lst)) (car lst))
41            (else
42              (set! lst (cdr lst))
43              (goto start)))))
44      ;; nonlocal return: throw and catch in different procedures
45      (define (treat ok?)
46        (lambda (item cont)
47          (if (ok? item)
48            (throw cont item))))
49      (define (handled-search handle lst)
50        (catch return
51               (for-each (lambda (item)
52                           (handle item return))
53                         lst)
54               #f))
55      (= (search even? '(1 2 3)) 2)
56      (not (search even? '(1 3)))
57      (= (search-with-goto odd? '(0 1 2 3)) 1)
58      (not (search-with-goto odd? '(0 2)))
59      (= (handled-search (treat even?) '(1 2 3)) 2)
60  ))
61
62  (define-test (ESCAPE-PROCEDURE-INTERFACE)
63    (check
64      (define (product . nums)
65        (let ((cc (escape-procedure)))
66          (cond
67            ((escape-procedure? cc) ; continuation cc just created
68             ;; normal body
69             (cond
70               ((null? nums) 1)
71               ((zero? (car nums))
72                (cc 0))
73               (else
74                 (* (car nums) (apply product (cdr nums))))))
75            ((number? cc) ; cc has been thrown a number
76             ;; exceptional case
77             cc)
78            )))
79      (= (product 1 2 3 4 5) 120)
80      (= (product 1 0 3 4 5) 0)))
81 
82  (define-test (AMB)
83    (check
84      (define amb (make-amb))
85      (define (pythagoras . choices)
86        (let ((a (apply (amb 'choose) choices))
87              (b (apply (amb 'choose) choices))
88              (c (apply (amb 'choose) choices)))
89          ((amb 'assert) (= (* c c) (+ (* a a) (* b b))))
90          ((amb 'assert) (< b a))
91          (list a b c)))
92      (equal? (pythagoras 1 2 3 4 5 6 7) '(4 3 5))
93  ))
94
95  (define-test (COOPERATIVE-THREADS)
96    (check
97      (define threads (make-threads))
98      (equal?
99        (let ((result '()))
100          (define make-thunk
101            (let ((counter 10))
102              (lambda (name)
103                (rec (loop)
104                  (if (< counter 0)
105                    ((threads 'quit)))
106                  (set! result (cons (cons name counter) result))
107                  (set! counter (- counter 1))
108                  ((threads 'yield))
109                  (loop)))))
110          ((threads 'spawn) (make-thunk 'a))
111          ((threads 'spawn) (make-thunk 'aa))
112          ((threads 'spawn) (make-thunk 'aaa))
113          ((threads 'start))
114          (reverse result))
115        '((a . 10) (aa . 9) (aaa . 8) (a . 7) (aa . 6) (aaa . 5)
116          (a . 4) (aa .  3) (aaa . 2) (a . 1) (aa . 0)))
117  ))
118
119  (define-test (ITERATORS)
120    (check
121      (equal?
122        (let ((tree-iterator (lambda (tree)
123                               (lambda (yield)
124                                 (let walk ((tree tree))
125                                   (if (pair? tree)
126                                     (begin (walk (car tree))
127                                            (walk (cdr tree)))
128                                     (yield tree))))))
129              (result '()))
130          (iterate var (tree-iterator '(3 . ((4 . 5) . 6)))
131            (set! result (cons var result)))
132          (reverse result))
133        '(3 4 5 6))
134  ))
135  (CONTINUATION-INTERFACE)
136  (ESCAPE-PROCEDURE-INTERFACE)
137  (AMB)
138  (COOPERATIVE-THREADS)
139  (ITERATORS)
140  )
Note: See TracBrowser for help on using the repository browser.