mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
d291d7990d
* module/srfi/srfi-45.scm (promise?): Export. * doc/ref/srfi-modules.texi (SRFI-45): Update docs. * test-suite/tests/srfi-45.test: Add test. Add FSF copyright for 2010 and 2013. Add missing year to André van Tonder's copyright notice.
268 lines
8.4 KiB
Scheme
268 lines
8.4 KiB
Scheme
;;; -*- 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)))
|