1;; Adapted for R7RS from original SRFI 41 r5rs.ss. 2 3;; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, 4;; USA. All rights reserved. Permission is hereby granted, free of 5;; charge, to any person obtaining a copy of this software and 6;; associated documentation files (the "Software"), to deal in the 7;; Software without restriction, including without limitation the 8;; rights to use, copy, modify, merge, publish, distribute, 9;; sublicense, and/or sell copies of the Software, and to permit 10;; persons to whom the Software is furnished to do so, subject to the 11;; following conditions: The above copyright notice and this 12;; permission notice shall be included in all copies or substantial 13;; portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", 14;; WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT 15;; LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A 16;; PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR 18;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR 19;; OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE 20;; OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 22;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; unit tests 23 24(define-library (srfi 41 test) 25 (import (scheme base) (srfi 41) (chibi test)) 26 (export run-tests) 27 (begin 28 29 (define (add1 n) (+ n 1)) 30 (define strm123 (stream 1 2 3)) 31 (define (lsec proc . args) 32 (lambda x (apply proc (append args x)))) 33 (define (rsec proc . args) 34 (lambda x (apply proc (reverse (append (reverse args) (reverse x)))))) 35 (define nats 36 (stream-cons 0 (stream-map add1 nats))) 37 38 ;; executing (run-tests) should produce no output 39 (define (run-tests) 40 41 (test-begin "srfi-41: streams") 42 43 ;; stream-null 44 (test #t (stream? stream-null)) 45 (test #t (stream-null? stream-null)) 46 (test #f (stream-pair? stream-null)) 47 48 ;; stream-cons 49 (test #t (stream? (stream-cons 1 stream-null))) 50 (test #f (stream-null? (stream-cons 1 stream-null))) 51 (test #t (stream-pair? (stream-cons 1 stream-null))) 52 53 ;; stream? 54 (test #t (stream? stream-null)) 55 (test #t (stream? (stream-cons 1 stream-null))) 56 (test #f (stream? "four")) 57 58 ;; stream-null? 59 (test #t (stream-null? stream-null)) 60 (test #f (stream-null? (stream-cons 1 stream-null))) 61 (test #f (stream-null? "four")) 62 63 ;; stream-pair? 64 (test #f (stream-pair? stream-null)) 65 (test #t (stream-pair? (stream-cons 1 stream-null))) 66 (test #f (stream-pair? "four")) 67 68 ;; stream-car 69 (test-error (stream-car "four")) ; "stream-car: non-stream" 70 (test-error (stream-car stream-null)) ; "stream-car: null stream" 71 (test 1 (stream-car strm123)) 72 73 ;; stream-cdr 74 (test-error (stream-cdr "four")) ; "stream-cdr: non-stream" 75 (test-error (stream-cdr stream-null)) ; "stream-cdr: null stream" 76 (test 2 (stream-car (stream-cdr strm123))) 77 78 ;; stream-lambda 79 (test 80 '(2 4 6) 81 (stream->list 82 (letrec ((double 83 (stream-lambda (strm) 84 (if (stream-null? strm) 85 stream-null 86 (stream-cons 87 (* 2 (stream-car strm)) 88 (double (stream-cdr strm))))))) 89 (double strm123)))) 90 91 ;; define-stream 92 (test 93 '(2 4 6) 94 (stream->list 95 (let () 96 (define-stream (double strm) 97 (if (stream-null? strm) 98 stream-null 99 (stream-cons 100 (* 2 (stream-car strm)) 101 (double (stream-cdr strm))))) 102 (double strm123)))) 103 104 ;; list->stream 105 (test-error (list->stream "four")) ; "list->stream: non-list argument" 106 (test '() (stream->list (list->stream '()))) 107 (test '(1 2 3) (stream->list (list->stream '(1 2 3)))) 108 109 ;; port->stream 110 (let* ((p (open-input-string "; Copyright 2007")) 111 (s (port->stream p))) 112 (test-error (port->stream "four")) 113 (test "; Copyright" (list->string (stream->list 11 s)) ) 114 (close-input-port p)) 115 116 ;; stream 117 (test '() (stream->list (stream))) 118 (test '(1) (stream->list (stream 1))) 119 (test '(1 2 3) (stream->list (stream 1 2 3))) 120 121 ;; stream->list 122 (test-error (stream->list '())) ; "stream->list: non-stream argument" 123 (test-error (stream->list "four" strm123)) ; "stream->list: non-integer count" 124 (test-error (stream->list -1 strm123)) ; "stream->list: negative count" 125 (test '() (stream->list (stream))) 126 (test '(1 2 3) (stream->list strm123)) 127 (test '(1 2 3) (stream->list 5 strm123)) 128 (test '(1 2 3) (stream->list 3 (stream-from 1))) 129 130 ;; stream-append 131 (test-error (stream-append "four")) ; "stream-append: non-stream argument" 132 (test '(1 2 3) (stream->list (stream-append strm123))) 133 (test '(1 2 3 1 2 3) (stream->list (stream-append strm123 strm123))) 134 (test '(1 2 3 1 2 3 1 2 3) 135 (stream->list (stream-append strm123 strm123 strm123))) 136 (test '(1 2 3) (stream->list (stream-append strm123 stream-null))) 137 (test '(1 2 3) (stream->list (stream-append stream-null strm123))) 138 139 ;; stream-concat 140 (test-error (stream-concat "four")) ; "stream-concat: non-stream argument" 141 (test '(1 2 3) (stream->list (stream-concat (stream strm123)))) 142 (test '(1 2 3 1 2 3) 143 (stream->list (stream-concat (stream strm123 strm123)))) 144 145 ;; stream-constant 146 (test 1 (stream-ref (stream-constant 1) 100)) 147 (test 1 (stream-ref (stream-constant 1 2) 100)) 148 (test 1 (stream-ref (stream-constant 1 2 3) 3)) 149 150 ;; stream-drop 151 (test-error (stream-drop "four" strm123)) ; "stream-drop: non-integer argument" 152 (test-error (stream-drop -1 strm123)) ; "stream-drop: negative argument" 153 (test-error (stream-drop 2 "four")) ; "stream-drop: non-stream argument" 154 (test '() (stream->list (stream-drop 0 stream-null))) 155 (test '(1 2 3) (stream->list (stream-drop 0 strm123))) 156 (test '(2 3) (stream->list (stream-drop 1 strm123))) 157 (test '() (stream->list (stream-drop 5 strm123))) 158 159 ;; stream-drop-while 160 (test-error ; "stream-drop-while: non-procedural argument" 161 (stream-drop-while "four" strm123)) 162 (test-error ; "stream-drop-while: non-stream argument" 163 (stream-drop-while odd? "four")) 164 (test '() (stream->list (stream-drop-while odd? stream-null))) 165 (test '(2 3) (stream->list (stream-drop-while odd? strm123))) 166 (test '(1 2 3) (stream->list (stream-drop-while even? strm123))) 167 (test '() (stream->list (stream-drop-while positive? strm123))) 168 (test '(1 2 3) (stream->list (stream-drop-while negative? strm123))) 169 170 ;; stream-filter 171 (test-error ; "stream-filter: non-procedural argument" 172 (stream-filter "four" strm123)) 173 (test-error (stream-filter odd? '())) ; "stream-filter: non-stream argument" 174 (test #t (stream-null? (stream-filter odd? (stream)))) 175 (test '(1 3) (stream->list (stream-filter odd? strm123))) 176 (test '(2) (stream->list (stream-filter even? strm123))) 177 (test '(1 2 3) (stream->list (stream-filter positive? strm123))) 178 (test '() (stream->list (stream-filter negative? strm123))) 179 (let loop ((n 10)) 180 (test #t (odd? (stream-ref (stream-filter odd? (stream-from 0)) n))) 181 (if (positive? n) (loop (- n 1)))) 182 (let loop ((n 10)) 183 (test #f (even? (stream-ref (stream-filter odd? (stream-from 0)) n))) 184 (if (positive? n) (loop (- n 1)))) 185 186 ;; stream-fold 187 (test-error ; "stream-fold: non-procedural argument" 188 (stream-fold "four" 0 strm123)) 189 (test-error (stream-fold + 0 '())) ; "stream-fold: non-stream argument" 190 (test 6 (stream-fold + 0 strm123)) 191 192 ;; stream-for-each 193 (test-error ; "stream-for-each: non-procedural argument" 194 (stream-for-each "four" strm123)) 195 (test-error ; "stream-for-each: no stream arguments" 196 (stream-for-each +)) 197 (test-error ; "stream-for-each: non-stream argument" 198 (stream-for-each + "four")) 199 (test 6 200 (let ((sum 0)) 201 (stream-for-each (lambda (x) (set! sum (+ sum x))) strm123) 202 sum)) 203 204 ;; stream-from 205 (test-error (stream-from "four")) ; "stream-from: non-numeric starting number" 206 (test-error (stream-from 1 "four")) ; "stream-from: non-numeric step size" 207 (test 100 (stream-ref (stream-from 0) 100)) 208 (test 201 (stream-ref (stream-from 1 2) 100)) 209 (test -100 (stream-ref (stream-from 0 -1) 100)) 210 211 ;; stream-iterate 212 (test-error (stream-iterate "four" 0)) ; "stream-iterate: non-procedural argument" 213 (test '(1 2 3) (stream->list 3 (stream-iterate (lsec + 1) 1))) 214 215 ;; stream-length 216 (test-error (stream-length "four")) ; "stream-length: non-stream argument" 217 (test 0 (stream-length (stream))) 218 (test 3 (stream-length strm123)) 219 220 ;; stream-let 221 (test '(2 4 6) 222 (stream->list 223 (stream-let loop ((strm strm123)) 224 (if (stream-null? strm) 225 stream-null 226 (stream-cons 227 (* 2 (stream-car strm)) 228 (loop (stream-cdr strm))))))) 229 230 ;; stream-map 231 (test-error (stream-map "four" strm123)) ; "stream-map: non-procedural argument" 232 (test-error (stream-map odd?)) ; "stream-map: no stream arguments" 233 (test-error (stream-map odd? "four")) ; "stream-map: non-stream argument" 234 (test '(-1 -2 -3) (stream->list (stream-map - strm123))) 235 (test '(2 4 6) (stream->list (stream-map + strm123 strm123))) 236 (test '(2 4 6) (stream->list (stream-map + strm123 (stream-from 1)))) 237 (test '(2 4 6) (stream->list (stream-map + (stream-from 1) strm123))) 238 (test '(3 6 9) (stream->list (stream-map + strm123 strm123 strm123))) 239 240 ;; stream-match 241 (test-error (stream-match '(1 2 3) (_ 'ok))) ; "stream-match: non-stream argument" 242 (test-error (stream-match strm123 (() 42))) ; "stream-match: pattern failure" 243 (test 'ok (stream-match stream-null (() 'ok))) 244 (test 'ok (stream-match strm123 (() 'no) (else 'ok))) 245 (test 1 (stream-match (stream 1) (() 'no) ((a) a))) 246 (test 'ok (stream-match (stream 1) (() 'no) ((_) 'ok))) 247 (test '(1 2 3) (stream-match strm123 ((a b c) (list a b c)))) 248 (test 1 (stream-match strm123 ((a . _) a))) 249 (test '(1 2) (stream-match strm123 ((a b . _) (list a b)))) 250 (test '(1 2 3) 251 (stream-match strm123 ((a b . c) (list a b (stream-car c))))) 252 (test '(1 2 3) (stream-match strm123 (s (stream->list s)))) 253 (test 'ok (stream-match strm123 ((a . _) (= a 1) 'ok))) 254 (test 'no (stream-match strm123 ((a . _) (= a 2) 'yes) (_ 'no))) 255 (test 'no (stream-match strm123 ((a b c) (= a b) 'yes) (_ 'no))) 256 (test 'yes (stream-match (stream 1 1 2) ((a b c) (= a b) 'yes) (_ 'no))) 257 258 ;; stream-of 259 (test '(7 15 31) 260 (stream->list 261 (stream-of (+ y 6) 262 (x in (stream-range 1 6)) 263 (odd? x) 264 (y is (* x x))))) 265 (test '(1 2 3 4 2 4 6 8 3 6 9 12) 266 (stream->list 267 (stream-of (* x y) 268 (x in (stream-range 1 4)) 269 (y in (stream-range 1 5))))) 270 (test 1 (stream-car (stream-of 1))) 271 272 ;; stream-range 273 (test-error (stream-range "four" 0)) ; "stream-range: non-numeric starting number" 274 (test-error (stream-range 0 "four")) ; "stream-range: non-numeric ending number" 275 (test-error (stream-range 1 2 "three")) ; "stream-range: non-numeric step size" 276 (test '(0 1 2 3 4) (stream->list (stream-range 0 5))) 277 (test '(5 4 3 2 1) (stream->list (stream-range 5 0))) 278 (test '(0 2 4) (stream->list (stream-range 0 5 2))) 279 (test '(5 3 1) (stream->list (stream-range 5 0 -2))) 280 (test '() (stream->list (stream-range 0 1 -1))) 281 282 ;; stream-ref 283 (test-error (stream-ref '() 4)) ; "stream-ref: non-stream argument" 284 (test-error (stream-ref nats 3.5)) ; "stream-ref: non-integer argument" 285 (test-error (stream-ref nats -3)) ; "stream-ref: negative argument" 286 (test-error (stream-ref strm123 5)) ; "stream-ref: beyond end of stream" 287 (test 1 (stream-ref strm123 0)) 288 (test 2 (stream-ref strm123 1)) 289 (test 3 (stream-ref strm123 2)) 290 291 ;; stream-reverse 292 (test-error (stream-reverse '())) ; "stream-reverse: non-stream argument" 293 (test '() (stream->list (stream-reverse (stream)))) 294 (test '(3 2 1) (stream->list (stream-reverse strm123))) 295 296 ;; stream-scan 297 (test-error ; "stream-scan: non-procedural argument" 298 (stream-scan "four" 0 strm123)) 299 (test-error (stream-scan + 0 '())) ; "stream-scan: non-stream argument" 300 (test '(0 1 3 6) (stream->list (stream-scan + 0 strm123))) 301 302 ;; stream-take 303 (test-error (stream-take 5 "four")) ; "stream-take: non-stream argument" 304 (test-error (stream-take "four" strm123)) ; "stream-take: non-integer argument" 305 (test-error (stream-take -4 strm123)) ; "stream-take: negative argument" 306 (test '() (stream->list (stream-take 5 stream-null))) 307 (test '() (stream->list (stream-take 0 stream-null))) 308 (test '() (stream->list (stream-take 0 strm123))) 309 (test '(1 2) (stream->list (stream-take 2 strm123))) 310 (test '(1 2 3) (stream->list (stream-take 3 strm123))) 311 (test '(1 2 3) (stream->list (stream-take 5 strm123))) 312 313 ;; stream-take-while 314 (test-error ; "stream-take-while: non-stream argument" 315 (stream-take-while odd? "four")) 316 (test-error ; "stream-take-while: non-procedural argument" 317 (stream-take-while "four" strm123)) 318 (test '(1) (stream->list (stream-take-while odd? strm123))) 319 (test '() (stream->list (stream-take-while even? strm123))) 320 (test '(1 2 3) (stream->list (stream-take-while positive? strm123))) 321 (test '() (stream->list (stream-take-while negative? strm123))) 322 323 ;; stream-unfold 324 (test-error ; "stream-unfold: non-procedural mapper" 325 (stream-unfold "four" odd? + 0)) 326 (test-error ; "stream-unfold: non-procedural pred?" 327 (stream-unfold + "four" + 0)) 328 (test-error ; "stream-unfold: non-procedural generator" 329 (stream-unfold + odd? "four" 0)) 330 (test '(0 1 4 9 16 25 36 49 64 81) 331 (stream->list (stream-unfold (rsec expt 2) (rsec < 10) (rsec + 1) 0))) 332 333 ;; stream-unfolds 334 (test 335 '(0 1 2 3 4) 336 (stream->list 337 (stream-unfolds 338 (lambda (x) 339 (let ((n (car x)) (s (cdr x))) 340 (if (zero? n) 341 (values 'dummy '()) 342 (values 343 (cons (- n 1) (stream-cdr s)) 344 (list (stream-car s)))))) 345 (cons 5 (stream-from 0))))) 346 347 ;; stream-zip 348 (test-error (stream-zip)) ; "stream-zip: no stream arguments" 349 (test-error (stream-zip "four")) ; "stream-zip: non-stream argument" 350 (test-error (stream-zip strm123 "four")) ; "stream-zip: non-stream argument" 351 (test '() (stream->list (stream-zip strm123 stream-null))) 352 (test '((1) (2) (3)) (stream->list (stream-zip strm123))) 353 (test '((1 1) (2 2) (3 3)) (stream->list (stream-zip strm123 strm123))) 354 (test '((1 1) (2 2) (3 3)) 355 (stream->list (stream-zip strm123 (stream-from 1)))) 356 (test '((1 1 1) (2 2 2) (3 3 3)) 357 (stream->list (stream-zip strm123 strm123 strm123))) 358 359 (test-end)))) 360