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