source: project/release/4/continuations/tags/1.2.1/tests/run.scm @ 29413

Last change on this file since 29413 was 29413, checked in by juergen, 6 years ago

setup file corrected

File size: 3.1 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(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  )
Note: See TracBrowser for help on using the repository browser.