source: project/release/3/generator/tests/generator-test.scm @ 7886

Last change on this file since 7886 was 7886, checked in by Kon Lovett, 12 years ago

Testbase expansion options are #f, except "catching", by default.

File size: 2.9 KB
Line 
1;;; generator-test.scm
2
3(use testbase testbase-output-human)
4(use generator)
5(use srfi-1)
6
7(define-for-syntax test-with-catching #t)
8
9;; Generated value saving
10
11(define (make-collector)
12        (let ([lst '()])
13                (lambda v
14                        (if (null? v)
15                                (reverse! lst)
16                                (begin
17                                  (set-cdr! v lst)
18                                  (set! lst v))))))
19
20;;
21
22(define-test genny-test "Generators"
23  (initial
24    (define-generator (list->iterator ls)
25      (for-each yield ls)
26      (yield 'EOL))
27
28    (define-generator (counter n)
29      (yield n)
30      (counter (add1 n))) )
31
32  (let (
33      [lsi (list->iterator '(1 2))]
34      [gather (make-collector)])
35
36    (side-effect (gather (lsi)) (gather (lsi)) (gather (lsi)))
37    (expect-equal '(1 2 EOL) (gather))
38    ;(expect-eqv 1 (lsi))
39    ;(expect-eqv 2 (lsi))
40    ;(expect-eq 'EOL (lsi))
41  )
42
43  (let (
44      [cti (counter 20)]
45      [gather (make-collector)])
46
47    (side-effect (gather (cti)) (gather (cti)))
48    (expect-equal '(20 21) (gather))
49    ;(expect-eqv 20 (cti))
50    ;(expect-eqv 21 (cti))
51  )
52)
53
54(define-test gennyv-test "Generators/Values"
55  (initial
56    (define-generator/values (list->iterator/v ls1 ls2)
57      (for-each (cut yield <> <>) ls1 ls2)
58      (yield 'EOL 'EOL)) )
59
60  (let (
61      [lsiv (list->iterator/v '(1 2) '(a b))]
62      [gather (make-collector)])
63
64    (side-effect (gather (receive (lsiv))) (gather (receive (lsiv))) (gather (receive (lsiv))))
65    (expect-equal '((1 a) (2 b) (EOL EOL)) (gather))
66    ;(expect-equal/values (values 1 'a) (lsiv))
67    ;(expect-equal/values (values 2 'b) (lsiv))
68    ;(expect-eq/values (values 'EOL 'EOL) (lsiv))
69  )
70)
71
72;From "Teach Yourself Scheme in Fixnum Days"
73(define-test coro-test "Coroutines"
74  (initial
75    (define-coroutine (matcher-coroutine tree-cor-1 tree-cor-2 (v))
76      (let loop ()
77        (let ((leaf1 (resume tree-cor-1))
78              (leaf2 (resume tree-cor-2)))
79          (if (eqv? leaf1 leaf2)
80              (if (null? leaf1) #t (loop))
81              #f))))
82
83    (define-coroutine (leaf-gen-coroutine tree matcher-cor)
84      (let loop ((tree tree))
85        (cond ((null? tree)
86               'skip)
87              ((pair? tree)
88               (loop (car tree))
89               (loop (cdr tree)))
90              (else
91               (resume matcher-cor tree))))
92      (resume matcher-cor '()))
93
94    (define (same-fringe? tree1 tree2)
95      (letrec ((tree-cor-1
96                (leaf-gen-coroutine
97                 tree1
98                 (lambda (v) (matcher-cor v))))
99               (tree-cor-2
100                (leaf-gen-coroutine
101                 tree2
102                 (lambda (v) (matcher-cor v))))
103               (matcher-cor
104                (matcher-coroutine
105                 (lambda X (tree-cor-1))
106                 (lambda X (tree-cor-2)))))
107      (matcher-cor (void)))) )
108
109  (expect-true (same-fringe? '(1 (2 3)) '((1 2) 3)))
110  (expect-false (same-fringe? '(1 2 3) '(1 (3 2))))
111)
112
113(test::for-each (cut test::styler-set! <> test::output-style-human))
114(run-test "Generator Tests")
Note: See TracBrowser for help on using the repository browser.