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)
21  #:use-module (ice-9 threads)
22  #:use-module (test-suite lib)
23  #:use-module (system base compile))
24
25
26(define exception:syntax-error
27  (cons 'syntax-error "failed to match"))
28(define exception:duplicate-binding
29  (cons 'syntax-error "duplicate"))
30
31(define a (make-fluid))
32(define b (make-fluid))
33(define c #f)
34
35(with-test-prefix "syntax"
36  (pass-if-exception "with-fluids missing expression"
37    exception:syntax-error
38    (eval '(with-fluids ((a 1)))
39	  (interaction-environment)))
40
41  (pass-if-exception "with-fluids bad bindings"
42    exception:syntax-error
43    (eval '(with-fluids (a) #f)
44	  (interaction-environment)))
45
46  (pass-if-exception "with-fluids bad bindings"
47    exception:syntax-error
48    (eval '(with-fluids ((a)) #f)
49	  (interaction-environment))))
50
51(with-test-prefix "initial fluid values"
52
53  (pass-if "fluid-ref returns #f for uninitialized fluid"
54    (eq? #f (fluid-ref (make-fluid))))
55
56  (pass-if "fluid-ref returns #f for uninitialized thread local fluid"
57    (eq? #f (fluid-ref (make-thread-local-fluid))))
58
59  (pass-if "fluid-ref returns default"
60    (eq? #t (fluid-ref (make-fluid #t))))
61
62  (pass-if "fluid-ref returns thread local default"
63    (eq? #t (fluid-ref (make-thread-local-fluid #t))))
64
65  (pass-if "initial value is inherited from parent thread"
66    (if (provided? 'threads)
67        (let ((f (make-fluid)))
68          (fluid-set! f 'initial)
69          (let ((child (call-with-new-thread
70                        (lambda ()
71                          (let ((init (fluid-ref f)))
72                            (fluid-set! f 'new)
73                            (list init (fluid-ref f)))))))
74            (equal? '(initial new) (join-thread child))))
75        (throw 'unresolved))))
76
77(with-test-prefix "with-fluids with non-fluid"
78  (pass-if-exception "exception raised if nonfluid passed to with-fluids"
79                     exception:wrong-type-arg
80    (with-fluids ((c #t))
81      c))
82
83  (pass-if "fluids not modified if nonfluid passed to with-fluids"
84    (catch 'wrong-type-arg
85      (lambda ()
86        (with-fluids ((a #t)
87                      (c #t))
88          #f))
89      (lambda _
90        (not (fluid-ref a))))))
91
92(with-test-prefix "with-fluids with duplicate fluid"
93  ;; These tests must be compiled, because the evaluator
94  ;; effectively transforms (with-fluids ((a 1) (b 2)) ...)
95  ;; into (with-fluids ((a 1)) (with-fluids ((b 2)) ...))
96
97  (pass-if "last value wins"
98    (compile '(with-fluids ((a 1)
99                            (a 2)
100                            (a 3))
101                (eqv? (fluid-ref a) 3))
102             #:env (current-module)))
103
104  (pass-if "remove the duplicate, not the last binding"
105    (compile '(with-fluids ((a 1)
106                            (a 2)
107                            (a 3)
108                            (b 4))
109                (eqv? (fluid-ref b) 4))
110             #:env (current-module)))
111
112  (pass-if "original value restored"
113    (compile '(and (with-fluids ((a 1)
114                                 (a 2))
115                     (eqv? (fluid-ref a) 2))
116                   (eqv? (fluid-ref a) #f))
117             #:env (current-module))))
118
119(pass-if "fluid values are thread-local"
120  (if (provided? 'threads)
121      (let ((f (make-fluid)))
122        (fluid-set! f 'parent)
123        (let ((child (call-with-new-thread
124                      (lambda ()
125                        (fluid-set! f 'child)
126                        (fluid-ref f)))))
127          (and (eq? (join-thread child) 'child)
128               (eq? (fluid-ref f) 'parent))))
129      (throw 'unresolved)))
130
131(pass-if "fluids are GC'd"
132
133  (let ((g (make-guardian)))
134    (g (make-fluid))
135    (let loop ((i 1000))
136      (and (> i 0)
137           (begin
138             (make-fluid)
139             (loop (1- i)))))
140    (gc)
141    (fluid? (g))))
142
143(with-test-prefix "with-fluids"
144
145  (pass-if "with-fluids binds"
146    (= (with-fluids ((a 1)) (fluid-ref a)) 1))
147
148  (pass-if "with-fluids unbinds"
149    (begin
150      (fluid-set! a 0)
151      (with-fluids ((a 1)) (fluid-ref a))
152      (= (fluid-ref a) 0)))
153
154  (pass-if "with-fluids and dynamic-wind"
155    (letrec ((co-routine #f)
156	     (spawn (lambda (proc)
157		      (set! co-routine proc)))
158	     (yield (lambda (val)
159		      (call-with-current-continuation
160		       (lambda (k)
161			 (let ((next co-routine))
162			   (set! co-routine k)
163			   (next val)))))))
164
165      (spawn (lambda (val)
166	       (with-fluids ((a 'inside))
167	         (yield (fluid-ref a))
168		 (yield (fluid-ref a)))))
169
170      (fluid-set! a 'outside)
171      (let ((inside-a (yield #f)))
172	(let ((outside-a (fluid-ref a)))
173	  (let ((inside-a2 (yield #f)))
174	    (and (eq? inside-a 'inside)
175		 (eq? outside-a 'outside)
176		 (eq? inside-a2 'inside))))))))
177
178(with-test-prefix "unbound fluids"
179  (pass-if "fluid-ref of unbound fluid"
180    (catch #t
181           (lambda () (fluid-ref (make-unbound-fluid)))
182           (lambda (key . args) #t)))
183  (pass-if "fluid-bound? of bound fluid"
184    (fluid-bound? (make-fluid)))
185  (pass-if "fluid-bound? of unbound fluid"
186    (not (fluid-bound? (make-unbound-fluid))))
187  (pass-if "unbound fluids can be set"
188    (let ((fluid (make-unbound-fluid)))
189      (fluid-set! fluid #t)
190      (fluid-ref fluid)))
191  (pass-if "bound fluids can be unset"
192    (let ((fluid (make-fluid)))
193      (fluid-unset! fluid)
194      (catch #t
195             (lambda () (fluid-ref fluid))
196             (lambda (key . args) #t)))))
197
198(with-test-prefix "dynamic states"
199  (pass-if "basics"
200    (dynamic-state? (current-dynamic-state)))
201
202  (pass-if "with a fluid (basic)"
203    (let ((fluid (make-fluid #f))
204          (state (current-dynamic-state)))
205      (with-dynamic-state
206       state
207       (lambda ()
208         (eqv? (fluid-ref fluid) #f)))))
209
210  (pass-if "with a fluid (set outer)"
211    (let ((fluid (make-fluid #f))
212          (state (current-dynamic-state)))
213      (fluid-set! fluid #t)
214      (and (with-dynamic-state
215            state
216            (lambda ()
217              (eqv? (fluid-ref fluid) #f)))
218           (eqv? (fluid-ref fluid) #t))))
219
220  (pass-if "with a fluid (set inner)"
221    (let ((fluid (make-fluid #f))
222          (state (current-dynamic-state)))
223      (and (with-dynamic-state
224            state
225            (lambda ()
226              (fluid-set! fluid #t)
227              (eqv? (fluid-ref fluid) #t)))
228           (eqv? (fluid-ref fluid) #f))))
229
230  (pass-if "dynstate captured (1)"
231    (let ((fluid (make-fluid #f))
232          (state (current-dynamic-state))
233          (tag (make-prompt-tag "hey")))
234      (let ((k (call-with-prompt tag
235                 (lambda ()
236                   (with-dynamic-state
237                    state
238                    (lambda ()
239                      (abort-to-prompt tag)
240                      (fluid-ref fluid))))
241                 (lambda (k) k))))
242        (eqv? (k) #f))))
243
244  (pass-if "dynstate captured (2)"
245    (let ((fluid (make-fluid #f))
246          (state (current-dynamic-state))
247          (tag (make-prompt-tag "hey")))
248      (let ((k (call-with-prompt tag
249                 (lambda ()
250                   (with-dynamic-state
251                    state
252                    (lambda ()
253                      (abort-to-prompt tag)
254                      (fluid-ref fluid))))
255                 (lambda (k) k))))
256        (fluid-set! fluid #t)
257        (eqv? (k) #f))))
258
259  (pass-if "dynstate captured (3)"
260    (let ((fluid (make-fluid #f))
261          (state (current-dynamic-state))
262          (tag (make-prompt-tag "hey")))
263      (let ((k (call-with-prompt tag
264                 (lambda ()
265                   (with-dynamic-state
266                    state
267                    (lambda ()
268                      (fluid-set! fluid #t)
269                      (abort-to-prompt tag)
270                      (fluid-ref fluid))))
271                 (lambda (k) k))))
272        (and (eqv? (fluid-ref fluid) #f)
273             (eqv? (k) #t)))))
274
275  (pass-if "exception handler not captured"
276    (let ((state (catch #t (lambda () (current-dynamic-state)) error)))
277      (catch #t
278        (lambda () (with-dynamic-state state (lambda () (/ 1 0))))
279        (lambda _ #t)))))
280