~ chicken-core (chicken-5) /tests/srfi-45-tests.scm

 1;;; Tests adapted from SRFI 45 (for "lazy" -> "delay-force").
 2;;; That SRFI Copyright (C) André van Tonder (2003).
 3
 4(import (only chicken.format printf)
 5        (only chicken.port with-output-to-string))
 6
 7(define *errors* 0)
 8
 9(define-syntax test
10  (syntax-rules ()
11    ((_ name expect form)
12     (let ((ok (equal? expect form)))
13       (printf "(~a) ~a~n" (if ok "PASS" "FAIL") name)
14       (when (not ok) (set! *errors* (add1 *errors*)))))))
15
16(define-syntax output
17  (syntax-rules ()
18    ((_ . body) (with-output-to-string (lambda () . body)))))
19
20(test "Memoization test 1"
21      "hello"
22      (output (define s (delay (begin (display 'hello) 1)))
23	      (force s)
24	      (force s)))
25
26(test "Memoization test 2"
27      "bonjour"
28      (output (let ((s (delay (begin (display 'bonjour) 2))))
29		(+ (force s) (force s)))))
30
31(test "Memoization test 3"
32      "hi"
33      (output (define r (delay (begin (display 'hi) 1)))
34	      (define s (delay-force r))
35	      (define t (delay-force s))
36	      (force t)
37	      (force r)))
38
39(test "Memoization test 4"
40      "hohohohoho"
41      (output (define (stream-drop s index)
42		(delay-force
43		 (if (zero? index)
44		     s
45		     (stream-drop (cdr (force s)) (- index 1)))))
46	      (define (ones)
47		(delay (begin
48			 (display 'ho)
49			 (cons 1 (ones)))))
50	      (define s (ones))
51	      (car (force (stream-drop s 4)))
52	      (car (force (stream-drop s 4)))))
53
54(let ()
55  (define count 0)
56  (define p
57    (delay (begin (set! count (+ count 1))
58		  (if (> count x)
59		      count
60		      (force p)))))
61  (define x 5)
62  (test "Reentrancy test 1 (1)" 6 (force p))
63  (set! x 10)
64  (test "Reentrancy test 1 (2)" 6 (force p)))
65
66(let ()
67  (define f
68    (let ((first? #t))
69      (delay
70       (if first?
71	   (begin
72	     (set! first? #f)
73	     (force f))
74	   'second))))
75  (test "Reentrancy test 2" 'second (force f)))
76
77(let ()
78  (define q
79    (let ((count 5))
80      (define (get-count) count)
81      (define p (delay (if (<= count 0)
82			   count
83			   (begin (set! count (- count 1))
84				  (force p)
85				  (set! count (+ count 2))
86				  count))))
87      (list get-count p)))
88  (define get-count (car q))
89  (define p (cadr q))
90  (test "Reentrancy test 3 (1)" 5 (get-count))
91  (test "Reentrancy test 3 (2)" 0 (force p))
92  (test "Reentrancy test 3 (3)" 10 (get-count)))
93
94(exit *errors*)