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

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

Testing of SRFI 45 `delay'. Better (?) re-fetch handling.

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