summaryrefslogtreecommitdiff
path: root/test-suite/tests/fluids.test
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests/fluids.test')
-rw-r--r--test-suite/tests/fluids.test269
1 files changed, 269 insertions, 0 deletions
diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test
new file mode 100644
index 000000000..a5ca8857e
--- /dev/null
+++ b/test-suite/tests/fluids.test
@@ -0,0 +1,269 @@
+;;;; -*- scheme -*-
+;;;; fluids.test --- test suite for fluid values
+;;;;
+;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-fluids)
+ #:use-module (ice-9 threads)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile))
+
+
+(define exception:syntax-error
+ (cons 'syntax-error "failed to match"))
+(define exception:duplicate-binding
+ (cons 'syntax-error "duplicate"))
+
+(define a (make-fluid))
+(define b (make-fluid))
+(define c #f)
+
+(with-test-prefix "syntax"
+ (pass-if-exception "with-fluids missing expression"
+ exception:syntax-error
+ (eval '(with-fluids ((a 1)))
+ (interaction-environment)))
+
+ (pass-if-exception "with-fluids bad bindings"
+ exception:syntax-error
+ (eval '(with-fluids (a) #f)
+ (interaction-environment)))
+
+ (pass-if-exception "with-fluids bad bindings"
+ exception:syntax-error
+ (eval '(with-fluids ((a)) #f)
+ (interaction-environment))))
+
+(with-test-prefix "initial fluid values"
+ (pass-if "fluid-ref uninitialized fluid is #f"
+ (not (fluid-ref a)))
+
+ (pass-if "initial value is inherited from parent thread"
+ (if (provided? 'threads)
+ (let ((f (make-fluid)))
+ (fluid-set! f 'initial)
+ (let ((child (call-with-new-thread
+ (lambda ()
+ (let ((init (fluid-ref f)))
+ (fluid-set! f 'new)
+ (list init (fluid-ref f)))))))
+ (equal? '(initial new) (join-thread child))))
+ (throw 'unresolved))))
+
+(with-test-prefix "with-fluids with non-fluid"
+ (pass-if-exception "exception raised if nonfluid passed to with-fluids"
+ exception:wrong-type-arg
+ (with-fluids ((c #t))
+ c))
+
+ (pass-if "fluids not modified if nonfluid passed to with-fluids"
+ (catch 'wrong-type-arg
+ (lambda ()
+ (with-fluids ((a #t)
+ (c #t))
+ #f))
+ (lambda _
+ (not (fluid-ref a))))))
+
+(with-test-prefix "with-fluids with duplicate fluid"
+ ;; These tests must be compiled, because the evaluator
+ ;; effectively transforms (with-fluids ((a 1) (b 2)) ...)
+ ;; into (with-fluids ((a 1)) (with-fluids ((b 2)) ...))
+
+ (pass-if "last value wins"
+ (compile '(with-fluids ((a 1)
+ (a 2)
+ (a 3))
+ (eqv? (fluid-ref a) 3))
+ #:env (current-module)))
+
+ (pass-if "remove the duplicate, not the last binding"
+ (compile '(with-fluids ((a 1)
+ (a 2)
+ (a 3)
+ (b 4))
+ (eqv? (fluid-ref b) 4))
+ #:env (current-module)))
+
+ (pass-if "original value restored"
+ (compile '(and (with-fluids ((a 1)
+ (a 2))
+ (eqv? (fluid-ref a) 2))
+ (eqv? (fluid-ref a) #f))
+ #:env (current-module))))
+
+(pass-if "fluid values are thread-local"
+ (if (provided? 'threads)
+ (let ((f (make-fluid)))
+ (fluid-set! f 'parent)
+ (let ((child (call-with-new-thread
+ (lambda ()
+ (fluid-set! f 'child)
+ (fluid-ref f)))))
+ (and (eq? (join-thread child) 'child)
+ (eq? (fluid-ref f) 'parent))))
+ (throw 'unresolved)))
+
+(pass-if "fluids are GC'd"
+
+ (let ((g (make-guardian)))
+ (g (make-fluid))
+ (let loop ((i 1000))
+ (and (> i 0)
+ (begin
+ (make-fluid)
+ (loop (1- i)))))
+ (gc)
+ (fluid? (g))))
+
+(with-test-prefix "with-fluids"
+
+ (pass-if "with-fluids binds"
+ (= (with-fluids ((a 1)) (fluid-ref a)) 1))
+
+ (pass-if "with-fluids unbinds"
+ (begin
+ (fluid-set! a 0)
+ (with-fluids ((a 1)) (fluid-ref a))
+ (= (fluid-ref a) 0)))
+
+ (pass-if "with-fluids and dynamic-wind"
+ (letrec ((co-routine #f)
+ (spawn (lambda (proc)
+ (set! co-routine proc)))
+ (yield (lambda (val)
+ (call-with-current-continuation
+ (lambda (k)
+ (let ((next co-routine))
+ (set! co-routine k)
+ (next val)))))))
+
+ (spawn (lambda (val)
+ (with-fluids ((a 'inside))
+ (yield (fluid-ref a))
+ (yield (fluid-ref a)))))
+
+ (fluid-set! a 'outside)
+ (let ((inside-a (yield #f)))
+ (let ((outside-a (fluid-ref a)))
+ (let ((inside-a2 (yield #f)))
+ (and (eq? inside-a 'inside)
+ (eq? outside-a 'outside)
+ (eq? inside-a2 'inside))))))))
+
+(with-test-prefix "unbound fluids"
+ (pass-if "fluid-ref of unbound fluid"
+ (catch #t
+ (lambda () (fluid-ref (make-unbound-fluid)))
+ (lambda (key . args) #t)))
+ (pass-if "fluid-bound? of bound fluid"
+ (fluid-bound? (make-fluid)))
+ (pass-if "fluid-bound? of unbound fluid"
+ (not (fluid-bound? (make-unbound-fluid))))
+ (pass-if "unbound fluids can be set"
+ (let ((fluid (make-unbound-fluid)))
+ (fluid-set! fluid #t)
+ (fluid-ref fluid)))
+ (pass-if "bound fluids can be unset"
+ (let ((fluid (make-fluid)))
+ (fluid-unset! fluid)
+ (catch #t
+ (lambda () (fluid-ref fluid))
+ (lambda (key . args) #t)))))
+
+(with-test-prefix "dynamic states"
+ (pass-if "basics"
+ (dynamic-state? (current-dynamic-state)))
+
+ (pass-if "with a fluid (basic)"
+ (let ((fluid (make-fluid #f))
+ (state (current-dynamic-state)))
+ (with-dynamic-state
+ state
+ (lambda ()
+ (eqv? (fluid-ref fluid) #f)))))
+
+ (pass-if "with a fluid (set outer)"
+ (let ((fluid (make-fluid #f))
+ (state (current-dynamic-state)))
+ (fluid-set! fluid #t)
+ (and (with-dynamic-state
+ state
+ (lambda ()
+ (eqv? (fluid-ref fluid) #f)))
+ (eqv? (fluid-ref fluid) #t))))
+
+ (pass-if "with a fluid (set inner)"
+ (let ((fluid (make-fluid #f))
+ (state (current-dynamic-state)))
+ (and (with-dynamic-state
+ state
+ (lambda ()
+ (fluid-set! fluid #t)
+ (eqv? (fluid-ref fluid) #t)))
+ (eqv? (fluid-ref fluid) #f))))
+
+ (pass-if "dynstate captured (1)"
+ (let ((fluid (make-fluid #f))
+ (state (current-dynamic-state))
+ (tag (make-prompt-tag "hey")))
+ (let ((k (call-with-prompt tag
+ (lambda ()
+ (with-dynamic-state
+ state
+ (lambda ()
+ (abort-to-prompt tag)
+ (fluid-ref fluid))))
+ (lambda (k) k))))
+ (eqv? (k) #f))))
+
+ (pass-if "dynstate captured (2)"
+ (let ((fluid (make-fluid #f))
+ (state (current-dynamic-state))
+ (tag (make-prompt-tag "hey")))
+ (let ((k (call-with-prompt tag
+ (lambda ()
+ (with-dynamic-state
+ state
+ (lambda ()
+ (abort-to-prompt tag)
+ (fluid-ref fluid))))
+ (lambda (k) k))))
+ (fluid-set! fluid #t)
+ (eqv? (k) #f))))
+
+ (pass-if "dynstate captured (3)"
+ (let ((fluid (make-fluid #f))
+ (state (current-dynamic-state))
+ (tag (make-prompt-tag "hey")))
+ (let ((k (call-with-prompt tag
+ (lambda ()
+ (with-dynamic-state
+ state
+ (lambda ()
+ (fluid-set! fluid #t)
+ (abort-to-prompt tag)
+ (fluid-ref fluid))))
+ (lambda (k) k))))
+ (and (eqv? (fluid-ref fluid) #f)
+ (eqv? (k) #t)))))
+
+ (pass-if "exception handler not captured"
+ (let ((state (catch #t (lambda () (current-dynamic-state)) error)))
+ (catch #t
+ (lambda () (with-dynamic-state state (lambda () (/ 1 0))))
+ (lambda _ #t)))))