test-suite/tests/srfi-45.test

   1 ;;; -*- mode: scheme; coding: utf-8; -*-
   2
   3 ;; Copyright 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
  25 ;; Modified by Andreas Rottmann for Guile.
  26
  27 (define-module (test-srfi-45)
  28   #:use-module (test-suite lib)
  29   #:use-module (srfi srfi-45))
  30
  31 (define-syntax test-output
  32   (syntax-rules ()
  33     ((_ expected proc)
  34      (let ((output (call-with-output-string proc)))
  35        (pass-if (equal? expected output))))))
  36
  37 (define-syntax test-equal
  38   (syntax-rules ()
  39     ((_ expected expr)
  40      (pass-if (equal? expected expr)))))
  41
  42 (define test-leaks? #f)
  43
  44 (define-syntax test-leak
  45   (syntax-rules ()
  46     ((_ expr)
  47      (cond (test-leaks?
  48             (display "Leak test, please watch memory consumption;")
  49             (display "  press C-c when satisfied.\n")
  50             (call/cc
  51               (lambda (k)
  52                 (sigaction SIGINT (lambda (signal) (k #t)))
  53                 expr)))))))
  54
  55 ;=========================================================================
  56 ; TESTS AND BENCHMARKS:
  57 ;=========================================================================
  58
  59 ;=========================================================================
  60 ; Memoization test 1:
  61
  62 (test-output "hello"
  63   (lambda (port)
  64     (define s (delay (begin (display 'hello port) 1)))
  65     (test-equal 1 (force s))
  66     (test-equal 1 (force s))))
  67
  68 ;=========================================================================
  69 ; Memoization test 2:
  70
  71 (test-output "bonjour"
  72   (lambda (port)
  73     (let ((s (delay (begin (display 'bonjour port) 2))))
  74       (test-equal 4 (+ (force s) (force s))))))
  75
  76 ;=========================================================================
  77 ; Memoization test 3: (pointed out by Alejandro Forero Cuervo)
  78
  79 (test-output "hi"
  80   (lambda (port)
  81     (define r (delay (begin (display 'hi port) 1)))
  82     (define s (lazy r))
  83     (define t (lazy s))
  84     (test-equal 1 (force t))
  85     (test-equal 1 (force r))))
  86
  87 ;=========================================================================
  88 ; Memoization test 4: Stream memoization
  89
  90 (define (stream-drop s index)
  91   (lazy
  92    (if (zero? index)
  93        s
  94        (stream-drop (cdr (force s)) (- index 1)))))
  95
  96 (define (ones port)
  97   (delay (begin
  98            (display 'ho port)
  99            (cons 1 (ones port)))))
 100
 101 (test-output "hohohohoho"
 102   (lambda (port)
 103     (define s (ones port))
 104     (test-equal 1
 105                 (car (force (stream-drop s 4))))
 106     (test-equal 1
 107                 (car (force (stream-drop s 4))))))
 108
 109 ;=========================================================================
 110 ; Reentrancy test 1: from R5RS
 111
 112 (letrec ((count 0)
 113          (p (delay (begin (set! count (+ count 1))
 114                           (if (> count x)
 115                               count
 116                               (force p)))))
 117          (x 5))
 118   (test-equal 6 (force p))
 119   (set! x 10)
 120   (test-equal 6 (force p)))
 121
 122 ;=========================================================================
 123 ; Reentrancy test 2: from SRFI 40
 124
 125 (letrec ((f (let ((first? #t))
 126               (delay
 127                 (if first?
 128                     (begin
 129                       (set! first? #f)
 130                       (force f))
 131                     'second)))))
 132   (test-equal 'second (force f)))
 133
 134 ;=========================================================================
 135 ; Reentrancy test 3: due to John Shutt
 136
 137 (let* ((q (let ((count 5))
 138             (define (get-count) count)
 139             (define p (delay (if (<= count 0)
 140                                  count
 141                                  (begin (set! count (- count 1))
 142                                         (force p)
 143                                         (set! count (+ count 2))
 144                                         count))))
 145             (list get-count p)))
 146        (get-count (car q))
 147        (p (cadr q)))
 148
 149   (test-equal 5 (get-count))
 150   (test-equal 0 (force p))
 151   (test-equal 10 (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 (test-leak (force (loop)))   ;==> bounded space
 161
 162 ;=========================================================================
 163 ; Leak test 2: Pending memos should not accumulate
 164 ;              in shared structures.
 165
 166 (let ()
 167   (define s (loop))
 168   (test-leak (force s)))     ;==> bounded space
 169
 170 ;=========================================================================
 171 ; Leak test 3: Safely traversing infinite stream.
 172
 173 (define (from n)
 174   (delay (cons n (from (+ n 1)))))
 175
 176 (define (traverse s)
 177   (lazy (traverse (cdr (force s)))))
 178
 179 (test-leak (force (traverse (from 0))))         ;==> bounded space
 180
 181 ;=========================================================================
 182 ; Leak test 4: Safely traversing infinite stream
 183 ;              while pointer to head of result exists.
 184
 185 (let ()
 186   (define s (traverse (from 0)))
 187   (test-leak (force s)))     ;==> bounded space
 188
 189 ;=========================================================================
 190 ; Convenient list deconstructor used below.
 191
 192 (define-syntax match
 193   (syntax-rules ()
 194     ((match exp
 195        (()      exp1)
 196        ((h . t) exp2))
 197      (let ((lst exp))
 198        (cond ((null? lst) exp1)
 199              ((pair? lst) (let ((h (car lst))
 200                                 (t (cdr lst)))
 201                             exp2))
 202              (else 'match-error))))))
 203
 204 ;========================================================================
 205 ; Leak test 5: Naive stream-filter should run in bounded space.
 206 ;              Simplest case.
 207
 208 (define (stream-filter p? s)
 209   (lazy (match (force s)
 210           (()      (delay '()))
 211           ((h . t) (if (p? h)
 212                        (delay (cons h (stream-filter p? t)))
 213                        (stream-filter p? t))))))
 214
 215 (test-leak
 216  (force (stream-filter (lambda (n) (= n 10000000000))
 217                        (from 0))))                     ;==> bounded space
 218
 219 ;========================================================================
 220 ; Leak test 6: Another long traversal should run in bounded space.
 221
 222 ; The stream-ref procedure below does not strictly need to be lazy.
 223 ; It is defined lazy for the purpose of testing safe compostion of
 224 ; lazy procedures in the times3 benchmark below (previous
 225 ; candidate solutions had failed this).
 226
 227 (define (stream-ref s index)
 228   (lazy
 229    (match (force s)
 230      (()      'error)
 231      ((h . t) (if (zero? index)
 232                   (delay h)
 233                   (stream-ref t (- index 1)))))))
 234
 235 ; Check that evenness is correctly implemented - should terminate:
 236
 237 (test-equal 0
 238   (force (stream-ref (stream-filter zero? (from 0))
 239                      0)))
 240
 241 ;; Commented out since it takes too long
 242 #;
 243 (let ()
 244   (define s (stream-ref (from 0) 100000000))
 245   (test-equal 100000000 (force s)))     ;==> bounded space
 246
 247 ;======================================================================
 248 ; Leak test 7: Infamous example from SRFI 40.
 249
 250 (define (times3 n)
 251   (stream-ref (stream-filter
 252                (lambda (x) (zero? (modulo x n)))
 253                (from 0))
 254               3))
 255
 256 (test-equal 21 (force (times3 7)))
 257
 258 ;; Commented out since it takes too long
 259 #;
 260 (test-equal 300000000 (force (times3 100000000)))    ;==> bounded space