source: project/release/5/continuations/tags/1.0/tests/run.scm @ 37408

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

continuations 1.0

File size: 2.1 KB
Line 
1(import continuations simple-tests)
2
3;; export continuation ...
4(define 1+ #f)
5;; ... with catch
6(define (init)
7  (+ 1 (catch cont
8              (set! 1+ (continuation->procedure cont))
9              (throw cont 0))))
10;; ... with continuation
11(define (init-again)
12  (+ 1 (let ((cc (continuation)))
13         (cond
14           ((continuation? cc)
15            (set! 1+ (continuation->procedure cc))
16            (throw cc 0))
17           (else cc)))))
18(define (search ok? lst)
19  (catch return
20         (for-each (lambda (item)
21                     (if (ok? item)
22                       (throw return item)))
23                   lst)
24         #f))
25(define (search-with-goto ok? lst)
26  (let ((start (continuation)))
27    (cond
28      ((null? lst) #f)
29      ((ok? (car lst)) (car lst))
30      (else
31        (set! lst (cdr lst))
32        (goto start)))))
33;; nonlocal return: throw and catch in different procedures
34(define (treat ok?)
35  (lambda (item cont)
36    (if (ok? item)
37      (throw cont item))))
38(define (handled-search handle lst)
39  (catch return
40         (for-each (lambda (item)
41                     (handle item return))
42                   lst)
43         #f))
44
45(define (product . nums)
46  (let ((cc (escape-procedure)))
47    (cond
48      ((escape-procedure? cc) ; continuation cc just created
49       (print "NORMAL BODY")
50       (cond
51         ((null? nums) 1)
52         ((zero? (car nums))
53          (cc 0))
54         (else
55           (* (car nums) (apply product (cdr nums))))))
56      ((number? cc) ; cc has been thrown a number
57       (print "EXCEPTIONAL CASE")
58       cc)
59      )))
60
61(define-test (continuations?)
62  (not (let ((cc (continuation)))
63         (cond
64           ((continuation? cc)
65            (throw cc (lambda (arg) #f)))
66           ((procedure? cc)
67            (cc cc)))))
68  (= 5 (+ 1 (call (lambda (cc) (* 5 (cc 4))))))
69  (= (search even? '(1 2 3)) 2)
70  (not (search even? '(1 3)))
71  (= (search-with-goto odd? '(0 1 2 3)) 1)
72  (not (search-with-goto odd? '(0 2)))
73  (= (handled-search (treat even?) '(1 2 3)) 2)
74  (zero? (product 1 2 0 3 4))
75  (= (product 1 2 3 4) 24)
76  )
77 
78(compound-test (CONTINUATIONS)
79  (continuations?)
80  )
Note: See TracBrowser for help on using the repository browser.