source: project/release/4/srfi-45/trunk/tests/run.scm @ 13848

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

Reduced bounds so the tests will see a finish

File size: 6.1 KB
Line 
1;;;; srfi-45 test
2
3(require-extension srfi-45)
4
5(define-syntax +bounded-space
6  (syntax-rules (force)
7    ((_ (force ?expr))
8      (begin
9        (print "+++ Bounded Space Test: (force " '?expr ") +++")
10        (force ?expr) ) ) ) )
11
12(define-syntax -bounded-space
13  (syntax-rules (force)
14    ((_ (force ?expr))
15      (print "+++ Skipping Bounded Space Test: (force " '?expr ") +++") ) ) )
16
17;=========================================================================
18; TESTS AND BENCHMARKS:
19;=========================================================================
20
21;=========================================================================
22; Memoization test 1:
23
24(print "+++ Should print 'hello once +++")
25
26(define s (delay (begin (print 'hello) 1)))
27
28(force s)
29(force s)
30
31;=========================================================================
32; Memoization test 2:
33
34(print "+++ Should print 'bonjour once +++")
35
36(let ((s (delay (begin (print 'bonjour) 2))))
37  (+ (force s) (force s)))
38
39;=========================================================================
40; Memoization test 3: (pointed out by Alejandro Forero Cuervo)
41
42(print "+++ Should print 'hi once +++")
43
44(define r (delay (begin (print 'hi) 1)))
45(define s (lazy r))
46(define t (lazy s))
47
48(force t)
49(force r)
50
51;=========================================================================
52; Memoization test 4: Stream memoization
53
54(print "+++ Should print 'ho five times +++")
55
56(define (stream-drop s index)
57  (lazy
58   (if (zero? index)
59       s
60       (stream-drop (cdr (force s)) (- index 1)))))
61
62(define (ones)
63  (delay (begin
64           (print 'ho)
65           (cons 1 (ones)))))
66
67(define s (ones))
68
69(car (force (stream-drop s 4)))
70(car (force (stream-drop s 4)))
71
72;=========================================================================
73; Reentrancy test 1: from R5RS
74
75(print "+++ Should print 6 twice +++")
76
77(define count 0)
78(define p
79  (delay (begin (set! count (+ count 1))
80                (if (> count x)
81                    count
82                    (force p)))))
83(define x 5)
84(print (force p))
85(set! x 10)
86(print (force p))
87
88
89;=========================================================================
90; Reentrancy test 2: from SRFI 40
91
92(print "+++ Should print 'second once +++")
93
94(define f
95  (let ((first? #t))
96    (delay
97      (if first?
98          (begin
99            (set! first? #f)
100            (force f))
101          'second))))
102
103(print (force f))
104
105;=========================================================================
106; Reentrancy test 3: due to John Shutt
107
108(print "+++ Should print 5 0 10 +++")
109
110(define q
111  (let ((count 5))
112    (define (get-count) count)
113    (define p (delay (if (<= count 0)
114                         count
115                         (begin (set! count (- count 1))
116                                (force p)
117                                (set! count (+ count 2))
118                                count))))
119    (list get-count p)))
120(define get-count (car q))
121(define p (cadr q))
122
123(print (get-count))
124(print (force p))
125(print (get-count))
126
127;=========================================================================
128; Test leaks:  All the leak tests should run in bounded space.
129
130;=========================================================================
131; Leak test 1: Infinite loop in bounded space.
132
133(define (loop) (lazy (loop)))
134
135(-bounded-space (force (loop)))
136
137;=========================================================================
138; Leak test 2: Pending memos should not accumulate
139;              in shared structures.
140
141(define s (loop))
142
143(-bounded-space (force s))
144
145;=========================================================================
146; Leak test 3: Safely traversing infinite stream.
147
148(define (from n)
149  (delay (cons n (from (+ n 1)))))
150
151(define (traverse s)
152  (lazy (traverse (cdr (force s)))))
153
154(-bounded-space (force (traverse (from 0))))
155
156;=========================================================================
157; Leak test 4: Safely traversing infinite stream
158;              while pointer to head of result exists.
159
160(define s (traverse (from 0)))
161
162(-bounded-space (force s))
163
164;=========================================================================
165; Convenient list deconstructor used below.
166
167(define-syntax test:match
168  (syntax-rules ()
169    ((test:match exp
170       (()      exp1)
171       ((h . t) exp2))
172     (let ((lst exp))
173       (cond ((null? lst) exp1)
174             ((pair? lst) (let ((h (car lst))
175                                (t (cdr lst)))
176                            exp2))
177             (else 'test:match-error))))))
178
179;========================================================================
180; Leak test 5: Naive stream-filter should run in bounded space.
181;              Simplest case.
182
183(define (stream-filter p? s)
184  (lazy (test:match (force s)
185          (()      (delay '()))
186          ((h . t) (if (p? h)
187                       (delay (cons h (stream-filter p? t)))
188                       (stream-filter p? t))))))
189
190(+bounded-space (force (stream-filter (lambda (n) (= n 100000 #;10000000000)) (from 0))))
191
192;========================================================================
193; Leak test 6: Another long traversal should run in bounded space.
194
195; The stream-ref procedure below does not strictly need to be lazy.
196; It is defined lazy for the purpose of testing safe compostion of
197; lazy procedures in the times3 benchmark below (previous
198; candidate solutions had failed this).
199
200(define (stream-ref s index)
201  (lazy
202   (test:match (force s)
203     (()      'error)
204     ((h . t) (if (zero? index)
205                  (delay h)
206                  (stream-ref t (- index 1)))))))
207
208; Check that evenness is correctly implemented - should terminate:
209
210(print "+++ Should print 0 +++")
211
212(print (force (stream-ref (stream-filter zero? (from 0)) 0)))
213
214(define s (stream-ref (from 0) 10000 #;100000000))
215
216(+bounded-space (force s))
217
218;======================================================================
219; Leak test 7: Infamous example from SRFI 40.
220
221(define (times3 n)
222  (stream-ref (stream-filter
223               (lambda (x) (zero? (modulo x n)))
224               (from 0))
225              3))
226
227(print "+++ Should print 21 +++")
228
229(print (force (times3 7)))
230
231(+bounded-space (force (times3 10000 #;100000000)))
Note: See TracBrowser for help on using the repository browser.