source: project/generator/tests/generator-test.scm @ 5069

Last change on this file since 5069 was 5069, checked in by Kon Lovett, 13 years ago

Changed to chicken-setup tests directory structure.

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