Commit | Line | Data |
---|---|---|
f16a2007 AR |
1 | ;;; -*- mode: scheme; coding: utf-8; -*- |
2 | ||
d291d799 MW |
3 | ;; Copyright (C) 2010, 2013 Free Software Foundation, Inc. |
4 | ;; Copyright (C) 2003 André van Tonder. All Rights Reserved. | |
f16a2007 AR |
5 | ;; |
6 | ;; Permission is hereby granted, free of charge, to any person | |
7 | ;; obtaining a copy of this software and associated documentation | |
8 | ;; files (the "Software"), to deal in the Software without | |
9 | ;; restriction, including without limitation the rights to use, copy, | |
10 | ;; modify, merge, publish, distribute, sublicense, and/or sell copies | |
11 | ;; of the Software, and to permit persons to whom the Software is | |
12 | ;; furnished to do so, subject to the following conditions: | |
13 | ;; | |
14 | ;; The above copyright notice and this permission notice shall be | |
15 | ;; included in all copies or substantial portions of the Software. | |
16 | ;; | |
17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, | |
18 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF | |
19 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND | |
20 | ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS | |
21 | ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN | |
22 | ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN | |
23 | ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE | |
24 | ;; SOFTWARE. | |
25 | ||
26 | ;; Modified by Andreas Rottmann for Guile. | |
27 | ||
28 | (define-module (test-srfi-45) | |
29 | #:use-module (test-suite lib) | |
30 | #:use-module (srfi srfi-45)) | |
31 | ||
32 | (define-syntax test-output | |
33 | (syntax-rules () | |
34 | ((_ expected proc) | |
35 | (let ((output (call-with-output-string proc))) | |
36 | (pass-if (equal? expected output)))))) | |
37 | ||
38 | (define-syntax test-equal | |
39 | (syntax-rules () | |
40 | ((_ expected expr) | |
41 | (pass-if (equal? expected expr))))) | |
42 | ||
43 | (define test-leaks? #f) | |
44 | ||
45 | (define-syntax test-leak | |
46 | (syntax-rules () | |
47 | ((_ expr) | |
48 | (cond (test-leaks? | |
49 | (display "Leak test, please watch memory consumption;") | |
50 | (display " press C-c when satisfied.\n") | |
51 | (call/cc | |
52 | (lambda (k) | |
53 | (sigaction SIGINT (lambda (signal) (k #t))) | |
54 | expr))))))) | |
55 | ||
56 | ;========================================================================= | |
57 | ; TESTS AND BENCHMARKS: | |
58 | ;========================================================================= | |
59 | ||
60 | ;========================================================================= | |
61 | ; Memoization test 1: | |
62 | ||
63 | (test-output "hello" | |
64 | (lambda (port) | |
65 | (define s (delay (begin (display 'hello port) 1))) | |
66 | (test-equal 1 (force s)) | |
67 | (test-equal 1 (force s)))) | |
68 | ||
69 | ;========================================================================= | |
70 | ; Memoization test 2: | |
71 | ||
72 | (test-output "bonjour" | |
73 | (lambda (port) | |
74 | (let ((s (delay (begin (display 'bonjour port) 2)))) | |
75 | (test-equal 4 (+ (force s) (force s)))))) | |
76 | ||
77 | ;========================================================================= | |
78 | ; Memoization test 3: (pointed out by Alejandro Forero Cuervo) | |
79 | ||
80 | (test-output "hi" | |
81 | (lambda (port) | |
82 | (define r (delay (begin (display 'hi port) 1))) | |
83 | (define s (lazy r)) | |
84 | (define t (lazy s)) | |
85 | (test-equal 1 (force t)) | |
86 | (test-equal 1 (force r)))) | |
87 | ||
88 | ;========================================================================= | |
89 | ; Memoization test 4: Stream memoization | |
90 | ||
91 | (define (stream-drop s index) | |
92 | (lazy | |
93 | (if (zero? index) | |
94 | s | |
95 | (stream-drop (cdr (force s)) (- index 1))))) | |
96 | ||
97 | (define (ones port) | |
98 | (delay (begin | |
99 | (display 'ho port) | |
100 | (cons 1 (ones port))))) | |
101 | ||
102 | (test-output "hohohohoho" | |
103 | (lambda (port) | |
104 | (define s (ones port)) | |
105 | (test-equal 1 | |
106 | (car (force (stream-drop s 4)))) | |
107 | (test-equal 1 | |
108 | (car (force (stream-drop s 4)))))) | |
109 | ||
110 | ;========================================================================= | |
111 | ; Reentrancy test 1: from R5RS | |
112 | ||
113 | (letrec ((count 0) | |
114 | (p (delay (begin (set! count (+ count 1)) | |
115 | (if (> count x) | |
116 | count | |
117 | (force p))))) | |
118 | (x 5)) | |
119 | (test-equal 6 (force p)) | |
120 | (set! x 10) | |
121 | (test-equal 6 (force p))) | |
122 | ||
123 | ;========================================================================= | |
124 | ; Reentrancy test 2: from SRFI 40 | |
125 | ||
126 | (letrec ((f (let ((first? #t)) | |
127 | (delay | |
128 | (if first? | |
129 | (begin | |
130 | (set! first? #f) | |
131 | (force f)) | |
132 | 'second))))) | |
133 | (test-equal 'second (force f))) | |
134 | ||
135 | ;========================================================================= | |
136 | ; Reentrancy test 3: due to John Shutt | |
137 | ||
138 | (let* ((q (let ((count 5)) | |
139 | (define (get-count) count) | |
140 | (define p (delay (if (<= count 0) | |
141 | count | |
142 | (begin (set! count (- count 1)) | |
143 | (force p) | |
144 | (set! count (+ count 2)) | |
145 | count)))) | |
146 | (list get-count p))) | |
147 | (get-count (car q)) | |
148 | (p (cadr q))) | |
149 | ||
150 | (test-equal 5 (get-count)) | |
151 | (test-equal 0 (force p)) | |
152 | (test-equal 10 (get-count))) | |
153 | ||
154 | ;========================================================================= | |
155 | ; Test leaks: All the leak tests should run in bounded space. | |
156 | ||
157 | ;========================================================================= | |
158 | ; Leak test 1: Infinite loop in bounded space. | |
159 | ||
160 | (define (loop) (lazy (loop))) | |
161 | (test-leak (force (loop))) ;==> bounded space | |
162 | ||
163 | ;========================================================================= | |
164 | ; Leak test 2: Pending memos should not accumulate | |
165 | ; in shared structures. | |
166 | ||
167 | (let () | |
168 | (define s (loop)) | |
169 | (test-leak (force s))) ;==> bounded space | |
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 | (test-leak (force (traverse (from 0)))) ;==> bounded space | |
181 | ||
182 | ;========================================================================= | |
183 | ; Leak test 4: Safely traversing infinite stream | |
184 | ; while pointer to head of result exists. | |
185 | ||
186 | (let () | |
187 | (define s (traverse (from 0))) | |
188 | (test-leak (force s))) ;==> bounded space | |
189 | ||
190 | ;========================================================================= | |
191 | ; Convenient list deconstructor used below. | |
192 | ||
193 | (define-syntax match | |
194 | (syntax-rules () | |
195 | ((match exp | |
196 | (() exp1) | |
197 | ((h . t) exp2)) | |
198 | (let ((lst exp)) | |
199 | (cond ((null? lst) exp1) | |
200 | ((pair? lst) (let ((h (car lst)) | |
201 | (t (cdr lst))) | |
202 | exp2)) | |
203 | (else 'match-error)))))) | |
204 | ||
205 | ;======================================================================== | |
206 | ; Leak test 5: Naive stream-filter should run in bounded space. | |
207 | ; Simplest case. | |
208 | ||
209 | (define (stream-filter p? s) | |
210 | (lazy (match (force s) | |
211 | (() (delay '())) | |
212 | ((h . t) (if (p? h) | |
213 | (delay (cons h (stream-filter p? t))) | |
214 | (stream-filter p? t)))))) | |
215 | ||
216 | (test-leak | |
217 | (force (stream-filter (lambda (n) (= n 10000000000)) | |
218 | (from 0)))) ;==> bounded space | |
219 | ||
220 | ;======================================================================== | |
221 | ; Leak test 6: Another long traversal should run in bounded space. | |
222 | ||
223 | ; The stream-ref procedure below does not strictly need to be lazy. | |
224 | ; It is defined lazy for the purpose of testing safe compostion of | |
225 | ; lazy procedures in the times3 benchmark below (previous | |
226 | ; candidate solutions had failed this). | |
227 | ||
228 | (define (stream-ref s index) | |
229 | (lazy | |
230 | (match (force s) | |
231 | (() 'error) | |
232 | ((h . t) (if (zero? index) | |
233 | (delay h) | |
234 | (stream-ref t (- index 1))))))) | |
235 | ||
236 | ; Check that evenness is correctly implemented - should terminate: | |
237 | ||
238 | (test-equal 0 | |
239 | (force (stream-ref (stream-filter zero? (from 0)) | |
240 | 0))) | |
241 | ||
242 | ;; Commented out since it takes too long | |
243 | #; | |
244 | (let () | |
245 | (define s (stream-ref (from 0) 100000000)) | |
246 | (test-equal 100000000 (force s))) ;==> bounded space | |
247 | ||
248 | ;====================================================================== | |
249 | ; Leak test 7: Infamous example from SRFI 40. | |
250 | ||
251 | (define (times3 n) | |
252 | (stream-ref (stream-filter | |
253 | (lambda (x) (zero? (modulo x n))) | |
254 | (from 0)) | |
255 | 3)) | |
256 | ||
257 | (test-equal 21 (force (times3 7))) | |
258 | ||
259 | ;; Commented out since it takes too long | |
260 | #; | |
261 | (test-equal 300000000 (force (times3 100000000))) ;==> bounded space | |
d291d799 MW |
262 | |
263 | ||
264 | ;====================================================================== | |
265 | ; Test promise? predicate (non-standard Guile extension) | |
266 | ||
267 | (pass-if "promise? predicate" | |
268 | (promise? (delay 1))) |