123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269 |
- ;;; -*- mode: scheme; coding: utf-8; -*-
- ;; Copyright (C) 2010, 2013 Free Software Foundation, Inc.
- ;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
- ;;
- ;; Permission is hereby granted, free of charge, to any person
- ;; obtaining a copy of this software and associated documentation
- ;; files (the "Software"), to deal in the Software without
- ;; restriction, including without limitation the rights to use, copy,
- ;; modify, merge, publish, distribute, sublicense, and/or sell copies
- ;; of the Software, and to permit persons to whom the Software is
- ;; furnished to do so, subject to the following conditions:
- ;;
- ;; The above copyright notice and this permission notice shall be
- ;; included in all copies or substantial portions of the Software.
- ;;
- ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
- ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
- ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
- ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
- ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
- ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
- ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
- ;; SOFTWARE.
- ;; Modified by Andreas Rottmann for Guile.
- (define-module (test-srfi-45)
- #:use-module (test-suite lib)
- #:use-module (srfi srfi-45))
- (define-syntax test-output
- (syntax-rules ()
- ((_ expected proc)
- (let ((output (call-with-output-string proc)))
- (pass-if (equal? expected output))))))
- (define-syntax test-equal
- (syntax-rules ()
- ((_ expected expr)
- (pass-if (equal? expected expr)))))
- (define test-leaks? #f)
- (define-syntax test-leak
- (syntax-rules ()
- ((_ expr)
- (cond (test-leaks?
- (display "Leak test, please watch memory consumption;")
- (display " press C-c when satisfied.\n")
- (call/cc
- (lambda (k)
- (sigaction SIGINT (lambda (signal) (k #t)))
- expr)))))))
- ;=========================================================================
- ; TESTS AND BENCHMARKS:
- ;=========================================================================
- ;=========================================================================
- ; Memoization test 1:
- (test-output "hello"
- (lambda (port)
- (define s (delay (begin (display 'hello port) 1)))
- (test-equal 1 (force s))
- (test-equal 1 (force s))))
- ;=========================================================================
- ; Memoization test 2:
- (test-output "bonjour"
- (lambda (port)
- (let ((s (delay (begin (display 'bonjour port) 2))))
- (test-equal 4 (+ (force s) (force s))))))
- ;=========================================================================
- ; Memoization test 3: (pointed out by Alejandro Forero Cuervo)
- (test-output "hi"
- (lambda (port)
- (define r (delay (begin (display 'hi port) 1)))
- (define s (lazy r))
- (define t (lazy s))
- (test-equal 1 (force t))
- (test-equal 1 (force r))))
- ;=========================================================================
- ; Memoization test 4: Stream memoization
- (define (stream-drop s index)
- (lazy
- (if (zero? index)
- s
- (stream-drop (cdr (force s)) (- index 1)))))
- (define (ones port)
- (delay (begin
- (display 'ho port)
- (cons 1 (ones port)))))
- (test-output "hohohohoho"
- (lambda (port)
- (define s (ones port))
- (test-equal 1
- (car (force (stream-drop s 4))))
- (test-equal 1
- (car (force (stream-drop s 4))))))
- ;=========================================================================
- ; Reentrancy test 1: from R5RS
- (letrec ((count 0)
- (p (delay (begin (set! count (+ count 1))
- (if (> count x)
- count
- (force p)))))
- (x 5))
- (test-equal 6 (force p))
- (set! x 10)
- (test-equal 6 (force p)))
- ;=========================================================================
- ; Reentrancy test 2: from SRFI 40
- (letrec ((f (let ((first? #t))
- (delay
- (if first?
- (begin
- (set! first? #f)
- (force f))
- 'second)))))
- (test-equal 'second (force f)))
- ;=========================================================================
- ; Reentrancy test 3: due to John Shutt
- (let* ((q (let ((count 5))
- (define (get-count) count)
- (define p (delay (if (<= count 0)
- count
- (begin (set! count (- count 1))
- (force p)
- (set! count (+ count 2))
- count))))
- (list get-count p)))
- (get-count (car q))
- (p (cadr q)))
- (test-equal 5 (get-count))
- (test-equal 0 (force p))
- (test-equal 10 (get-count)))
- ;=========================================================================
- ; Test leaks: All the leak tests should run in bounded space.
- ;=========================================================================
- ; Leak test 1: Infinite loop in bounded space.
- (define (loop) (lazy (loop)))
- (test-leak (force (loop))) ;==> bounded space
- ;=========================================================================
- ; Leak test 2: Pending memos should not accumulate
- ; in shared structures.
- (let ()
- (define s (loop))
- (test-leak (force s))) ;==> bounded space
- ;=========================================================================
- ; Leak test 3: Safely traversing infinite stream.
- (define (from n)
- (delay (cons n (from (+ n 1)))))
- (define (traverse s)
- (lazy (traverse (cdr (force s)))))
- (test-leak (force (traverse (from 0)))) ;==> bounded space
- ;=========================================================================
- ; Leak test 4: Safely traversing infinite stream
- ; while pointer to head of result exists.
- (let ()
- (define s (traverse (from 0)))
- (test-leak (force s))) ;==> bounded space
- ;=========================================================================
- ; Convenient list deconstructor used below.
- (define-syntax match
- (syntax-rules ()
- ((match exp
- (() exp1)
- ((h . t) exp2))
- (let ((lst exp))
- (cond ((null? lst) exp1)
- ((pair? lst) (let ((h (car lst))
- (t (cdr lst)))
- exp2))
- (else 'match-error))))))
- ;========================================================================
- ; Leak test 5: Naive stream-filter should run in bounded space.
- ; Simplest case.
- (define (stream-filter p? s)
- (lazy (match (force s)
- (() (delay '()))
- ((h . t) (if (p? h)
- (delay (cons h (stream-filter p? t)))
- (stream-filter p? t))))))
- (test-leak
- (force (stream-filter (lambda (n) (= n 10000000000))
- (from 0)))) ;==> bounded space
- ;========================================================================
- ; Leak test 6: Another long traversal should run in bounded space.
- ; The stream-ref procedure below does not strictly need to be lazy.
- ; It is defined lazy for the purpose of testing safe compostion of
- ; lazy procedures in the times3 benchmark below (previous
- ; candidate solutions had failed this).
- (define (stream-ref s index)
- (lazy
- (match (force s)
- (() 'error)
- ((h . t) (if (zero? index)
- (delay h)
- (stream-ref t (- index 1)))))))
- ; Check that evenness is correctly implemented - should terminate:
- (test-equal 0
- (force (stream-ref (stream-filter zero? (from 0))
- 0)))
- ;; Commented out since it takes too long
- #;
- (let ()
- (define s (stream-ref (from 0) 100000000))
- (test-equal 100000000 (force s))) ;==> bounded space
- ;======================================================================
- ; Leak test 7: Infamous example from SRFI 40.
- (define (times3 n)
- (stream-ref (stream-filter
- (lambda (x) (zero? (modulo x n)))
- (from 0))
- 3))
- (test-equal 21 (force (times3 7)))
- ;; Commented out since it takes too long
- #;
- (test-equal 300000000 (force (times3 100000000))) ;==> bounded space
- ;======================================================================
- ; Test promise? predicate (non-standard Guile extension)
- (pass-if "promise? predicate"
- (promise? (delay 1)))
|