srfi-45.test 8.4 KB

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