1 ;;; -*- mode: scheme; coding: utf-8; -*-
3 ;; Copyright (C) 2010, 2013 Free Software Foundation, Inc.
4 ;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
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:
14 ;; The above copyright notice and this permission notice shall be
15 ;; included in all copies or substantial portions of the Software.
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
26 ;; Modified by Andreas Rottmann for Guile.
28 (define-module (test-srfi-45)
29 #:use-module (test-suite lib)
30 #:use-module (srfi srfi-45))
32 (define-syntax test-output
35 (let ((output (call-with-output-string proc)))
36 (pass-if (equal? expected output))))))
38 (define-syntax test-equal
41 (pass-if (equal? expected expr)))))
43 (define test-leaks? #f)
45 (define-syntax test-leak
49 (display "Leak test, please watch memory consumption;")
50 (display " press C-c when satisfied.\n")
53 (sigaction SIGINT (lambda (signal) (k #t)))
56 ;=========================================================================
57 ; TESTS AND BENCHMARKS:
58 ;=========================================================================
60 ;=========================================================================
65 (define s (delay (begin (display 'hello port) 1)))
66 (test-equal 1 (force s))
67 (test-equal 1 (force s))))
69 ;=========================================================================
72 (test-output "bonjour"
74 (let ((s (delay (begin (display 'bonjour port) 2))))
75 (test-equal 4 (+ (force s) (force s))))))
77 ;=========================================================================
78 ; Memoization test 3: (pointed out by Alejandro Forero Cuervo)
82 (define r (delay (begin (display 'hi port) 1)))
85 (test-equal 1 (force t))
86 (test-equal 1 (force r))))
88 ;=========================================================================
89 ; Memoization test 4: Stream memoization
91 (define (stream-drop s index)
95 (stream-drop (cdr (force s)) (- index 1)))))
100 (cons 1 (ones port)))))
102 (test-output "hohohohoho"
104 (define s (ones port))
106 (car (force (stream-drop s 4))))
108 (car (force (stream-drop s 4))))))
110 ;=========================================================================
111 ; Reentrancy test 1: from R5RS
114 (p (delay (begin (set! count (+ count 1))
119 (test-equal 6 (force p))
121 (test-equal 6 (force p)))
123 ;=========================================================================
124 ; Reentrancy test 2: from SRFI 40
126 (letrec ((f (let ((first? #t))
133 (test-equal 'second (force f)))
135 ;=========================================================================
136 ; Reentrancy test 3: due to John Shutt
138 (let* ((q (let ((count 5))
139 (define (get-count) count)
140 (define p (delay (if (<= count 0)
142 (begin (set! count (- count 1))
144 (set! count (+ count 2))
150 (test-equal 5 (get-count))
151 (test-equal 0 (force p))
152 (test-equal 10 (get-count)))
154 ;=========================================================================
155 ; Test leaks: All the leak tests should run in bounded space.
157 ;=========================================================================
158 ; Leak test 1: Infinite loop in bounded space.
160 (define (loop) (lazy (loop)))
161 (test-leak (force (loop))) ;==> bounded space
163 ;=========================================================================
164 ; Leak test 2: Pending memos should not accumulate
165 ; in shared structures.
169 (test-leak (force s))) ;==> bounded space
171 ;=========================================================================
172 ; Leak test 3: Safely traversing infinite stream.
175 (delay (cons n (from (+ n 1)))))
178 (lazy (traverse (cdr (force s)))))
180 (test-leak (force (traverse (from 0)))) ;==> bounded space
182 ;=========================================================================
183 ; Leak test 4: Safely traversing infinite stream
184 ; while pointer to head of result exists.
187 (define s (traverse (from 0)))
188 (test-leak (force s))) ;==> bounded space
190 ;=========================================================================
191 ; Convenient list deconstructor used below.
199 (cond ((null? lst) exp1)
200 ((pair? lst) (let ((h (car lst))
203 (else 'match-error))))))
205 ;========================================================================
206 ; Leak test 5: Naive stream-filter should run in bounded space.
209 (define (stream-filter p? s)
210 (lazy (match (force s)
213 (delay (cons h (stream-filter p? t)))
214 (stream-filter p? t))))))
217 (force (stream-filter (lambda (n) (= n 10000000000))
218 (from 0)))) ;==> bounded space
220 ;========================================================================
221 ; Leak test 6: Another long traversal should run in bounded space.
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).
228 (define (stream-ref s index)
232 ((h . t) (if (zero? index)
234 (stream-ref t (- index 1)))))))
236 ; Check that evenness is correctly implemented - should terminate:
239 (force (stream-ref (stream-filter zero? (from 0))
242 ;; Commented out since it takes too long
245 (define s (stream-ref (from 0) 100000000))
246 (test-equal 100000000 (force s))) ;==> bounded space
248 ;======================================================================
249 ; Leak test 7: Infamous example from SRFI 40.
252 (stream-ref (stream-filter
253 (lambda (x) (zero? (modulo x n)))
257 (test-equal 21 (force (times3 7)))
259 ;; Commented out since it takes too long
261 (test-equal 300000000 (force (times3 100000000))) ;==> bounded space
264 ;======================================================================
265 ; Test promise? predicate (non-standard Guile extension)
267 (pass-if "promise? predicate"
268 (promise? (delay 1)))