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

Last change on this file since 15602 was 15602, checked in by Kon Lovett, 11 years ago

Redefines 'delay'

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