2 ;;;; fluids.test --- test suite for fluid values
4 ;;;; Copyright (C) 2010 Free Software Foundation, Inc.
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.
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.
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
20 (define-module (test-suite test-fluids)
21 :use-module (test-suite lib)
22 :use-module (system base compile))
25 (define exception:syntax-error
26 (cons 'syntax-error "failed to match"))
27 (define exception:duplicate-binding
28 (cons 'syntax-error "duplicate"))
30 (define a (make-fluid))
31 (define b (make-fluid))
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)))
40 (pass-if-exception "with-fluids bad bindings"
41 exception:syntax-error
42 (eval '(with-fluids (a) #f)
43 (interaction-environment)))
45 (pass-if-exception "with-fluids bad bindings"
46 exception:syntax-error
47 (eval '(with-fluids ((a)) #f)
48 (interaction-environment))))
50 (with-test-prefix "initial fluid values"
51 (pass-if "fluid-ref uninitialized fluid is #f"
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
60 (let ((init (fluid-ref f)))
62 (list init (fluid-ref f)))))))
63 (equal? '(initial new) (join-thread child))))
64 (throw 'unresolved))))
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
72 (pass-if "fluids not modified if nonfluid passed to with-fluids"
73 (catch 'wrong-type-arg
79 (not (fluid-ref a))))))
81 (with-test-prefix "with-fluids with duplicate fluid"
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)) ...))
86 (pass-if "last value wins"
87 (compile '(with-fluids ((a 1)
90 (eqv? (fluid-ref a) 3))
91 #:env (current-module)))
93 (pass-if "remove the duplicate, not the last binding"
94 (compile '(with-fluids ((a 1)
98 (eqv? (fluid-ref b) 4))
99 #:env (current-module)))
101 (pass-if "original value restored"
102 (compile '(and (with-fluids ((a 1)
104 (eqv? (fluid-ref a) 2))
105 (eqv? (fluid-ref a) #f))
106 #:env (current-module))))
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
114 (fluid-set! f 'child)
116 (and (eq? (join-thread child) 'child)
117 (eq? (fluid-ref f) 'parent))))
118 (throw 'unresolved)))
120 (pass-if "fluids are GC'd"
122 (let ((g (make-guardian)))
132 (with-test-prefix "with-fluids"
134 (pass-if "with-fluids binds"
135 (= (with-fluids ((a 1)) (fluid-ref a)) 1))
137 (pass-if "with-fluids unbinds"
140 (with-fluids ((a 1)) (fluid-ref a))
141 (= (fluid-ref a) 0)))
143 (pass-if "with-fluids and dynamic-wind"
144 (letrec ((co-routine #f)
145 (spawn (lambda (proc)
146 (set! co-routine proc)))
148 (call-with-current-continuation
150 (let ((next co-routine))
155 (with-fluids ((a 'inside))
156 (yield (fluid-ref a))
157 (yield (fluid-ref a)))))
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))))))))
167 (with-test-prefix "unbound fluids"
168 (pass-if "fluid-ref of unbound fluid"
170 (lambda () (fluid-ref (make-unbound-fluid)))
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"
175 (not (fluid-bound? (make-unbound-fluid))))
176 (pass-if "unbound fluids can be set"
177 (let ((fluid (make-unbound-fluid)))
178 (fluid-set! fluid #t)
180 (pass-if "bound fluids can be unset"
181 (let ((fluid (make-fluid)))
184 (lambda () (fluid-ref fluid))
185 (lambda (key . args) #t)))))