Commit | Line | Data |
---|---|---|
27bd1dec AW |
1 | ;;;; -*- scheme -*- |
2 | ;;;; fluids.test --- test suite for fluid values | |
3 | ;;;; | |
4 | ;;;; Copyright (C) 2010 Free Software Foundation, Inc. | |
5 | ;;;; | |
6 | ;;;; This library is free software; you can redistribute it and/or | |
7 | ;;;; modify it under the terms of the GNU Lesser General Public | |
8 | ;;;; License as published by the Free Software Foundation; either | |
9 | ;;;; version 3 of the License, or (at your option) any later version. | |
10 | ;;;; | |
11 | ;;;; This library is distributed in the hope that it will be useful, | |
12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
14 | ;;;; Lesser General Public License for more details. | |
15 | ;;;; | |
16 | ;;;; You should have received a copy of the GNU Lesser General Public | |
17 | ;;;; License along with this library; if not, write to the Free Software | |
18 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
19 | ||
20 | (define-module (test-suite test-fluids) | |
b8d8f8b9 MW |
21 | :use-module (test-suite lib) |
22 | :use-module (system base compile)) | |
27bd1dec AW |
23 | |
24 | ||
0abc2109 AW |
25 | (define exception:syntax-error |
26 | (cons 'syntax-error "failed to match")) | |
27 | (define exception:duplicate-binding | |
28 | (cons 'syntax-error "duplicate")) | |
29 | ||
27bd1dec AW |
30 | (define a (make-fluid)) |
31 | (define b (make-fluid)) | |
32 | (define c #f) | |
33 | ||
0abc2109 AW |
34 | (with-test-prefix "syntax" |
35 | (pass-if-exception "with-fluids missing expression" | |
36 | exception:syntax-error | |
37 | (eval '(with-fluids ((a 1))) | |
38 | (interaction-environment))) | |
39 | ||
40 | (pass-if-exception "with-fluids bad bindings" | |
41 | exception:syntax-error | |
42 | (eval '(with-fluids (a) #f) | |
43 | (interaction-environment))) | |
44 | ||
45 | (pass-if-exception "with-fluids bad bindings" | |
46 | exception:syntax-error | |
47 | (eval '(with-fluids ((a)) #f) | |
48 | (interaction-environment)))) | |
49 | ||
27bd1dec AW |
50 | (with-test-prefix "initial fluid values" |
51 | (pass-if "fluid-ref uninitialized fluid is #f" | |
c02924d0 LC |
52 | (not (fluid-ref a))) |
53 | ||
54 | (pass-if "initial value is inherited from parent thread" | |
55 | (if (provided? 'threads) | |
56 | (let ((f (make-fluid))) | |
57 | (fluid-set! f 'initial) | |
58 | (let ((child (call-with-new-thread | |
59 | (lambda () | |
60 | (let ((init (fluid-ref f))) | |
61 | (fluid-set! f 'new) | |
62 | (list init (fluid-ref f))))))) | |
63 | (equal? '(initial new) (join-thread child)))) | |
64 | (throw 'unresolved)))) | |
27bd1dec AW |
65 | |
66 | (with-test-prefix "with-fluids with non-fluid" | |
67 | (pass-if-exception "exception raised if nonfluid passed to with-fluids" | |
68 | exception:wrong-type-arg | |
69 | (with-fluids ((c #t)) | |
70 | c)) | |
71 | ||
bb0229b5 | 72 | (pass-if "fluids not modified if nonfluid passed to with-fluids" |
27bd1dec AW |
73 | (catch 'wrong-type-arg |
74 | (lambda () | |
75 | (with-fluids ((a #t) | |
76 | (c #t)) | |
77 | #f)) | |
78 | (lambda _ | |
79 | (not (fluid-ref a)))))) | |
80 | ||
81 | (with-test-prefix "with-fluids with duplicate fluid" | |
b8d8f8b9 MW |
82 | ;; These tests must be compiled, because the evaluator |
83 | ;; effectively transforms (with-fluids ((a 1) (b 2)) ...) | |
84 | ;; into (with-fluids ((a 1)) (with-fluids ((b 2)) ...)) | |
85 | ||
27bd1dec | 86 | (pass-if "last value wins" |
b8d8f8b9 | 87 | (compile '(with-fluids ((a 1) |
8dd01861 MW |
88 | (a 2) |
89 | (a 3)) | |
90 | (eqv? (fluid-ref a) 3)) | |
b8d8f8b9 | 91 | #:env (current-module))) |
27bd1dec | 92 | |
b8d8f8b9 MW |
93 | (pass-if "remove the duplicate, not the last binding" |
94 | (compile '(with-fluids ((a 1) | |
95 | (a 2) | |
8dd01861 MW |
96 | (a 3) |
97 | (b 4)) | |
98 | (eqv? (fluid-ref b) 4)) | |
b8d8f8b9 MW |
99 | #:env (current-module))) |
100 | ||
27bd1dec | 101 | (pass-if "original value restored" |
b8d8f8b9 MW |
102 | (compile '(and (with-fluids ((a 1) |
103 | (a 2)) | |
104 | (eqv? (fluid-ref a) 2)) | |
105 | (eqv? (fluid-ref a) #f)) | |
106 | #:env (current-module)))) | |
3278efd3 | 107 | |
c02924d0 LC |
108 | (pass-if "fluid values are thread-local" |
109 | (if (provided? 'threads) | |
110 | (let ((f (make-fluid))) | |
111 | (fluid-set! f 'parent) | |
112 | (let ((child (call-with-new-thread | |
113 | (lambda () | |
114 | (fluid-set! f 'child) | |
115 | (fluid-ref f))))) | |
116 | (and (eq? (join-thread child) 'child) | |
117 | (eq? (fluid-ref f) 'parent)))) | |
118 | (throw 'unresolved))) | |
119 | ||
3278efd3 LC |
120 | (pass-if "fluids are GC'd" |
121 | ||
122 | (let ((g (make-guardian))) | |
123 | (g (make-fluid)) | |
124 | (let loop ((i 1000)) | |
125 | (and (> i 0) | |
126 | (begin | |
127 | (make-fluid) | |
128 | (loop (1- i))))) | |
129 | (gc) | |
130 | (fluid? (g)))) | |
0abc2109 AW |
131 | |
132 | (with-test-prefix "with-fluids" | |
133 | ||
134 | (pass-if "with-fluids binds" | |
135 | (= (with-fluids ((a 1)) (fluid-ref a)) 1)) | |
136 | ||
137 | (pass-if "with-fluids unbinds" | |
138 | (begin | |
139 | (fluid-set! a 0) | |
140 | (with-fluids ((a 1)) (fluid-ref a)) | |
141 | (= (fluid-ref a) 0))) | |
142 | ||
143 | (pass-if "with-fluids and dynamic-wind" | |
144 | (letrec ((co-routine #f) | |
145 | (spawn (lambda (proc) | |
146 | (set! co-routine proc))) | |
147 | (yield (lambda (val) | |
148 | (call-with-current-continuation | |
149 | (lambda (k) | |
150 | (let ((next co-routine)) | |
151 | (set! co-routine k) | |
152 | (next val))))))) | |
153 | ||
154 | (spawn (lambda (val) | |
155 | (with-fluids ((a 'inside)) | |
156 | (yield (fluid-ref a)) | |
157 | (yield (fluid-ref a))))) | |
158 | ||
159 | (fluid-set! a 'outside) | |
160 | (let ((inside-a (yield #f))) | |
161 | (let ((outside-a (fluid-ref a))) | |
162 | (let ((inside-a2 (yield #f))) | |
163 | (and (eq? inside-a 'inside) | |
164 | (eq? outside-a 'outside) | |
165 | (eq? inside-a2 'inside)))))))) | |
ef94624e BT |
166 | |
167 | (with-test-prefix "unbound fluids" | |
168 | (pass-if "fluid-ref of unbound fluid" | |
169 | (catch #t | |
133ef660 | 170 | (lambda () (fluid-ref (make-unbound-fluid))) |
ef94624e BT |
171 | (lambda (key . args) #t))) |
172 | (pass-if "fluid-bound? of bound fluid" | |
173 | (fluid-bound? (make-fluid))) | |
174 | (pass-if "fluid-bound? of unbound fluid" | |
133ef660 | 175 | (not (fluid-bound? (make-unbound-fluid)))) |
ef94624e | 176 | (pass-if "unbound fluids can be set" |
133ef660 | 177 | (let ((fluid (make-unbound-fluid))) |
ef94624e BT |
178 | (fluid-set! fluid #t) |
179 | (fluid-ref fluid))) | |
180 | (pass-if "bound fluids can be unset" | |
181 | (let ((fluid (make-fluid))) | |
182 | (fluid-unset! fluid) | |
183 | (catch #t | |
184 | (lambda () (fluid-ref fluid)) | |
185 | (lambda (key . args) #t))))) |