1;; Filename : test-dyn-extent.scm 2;; About : unit test for dynamic extent 3;; 4;; Copyright (C) 2005-2006 YAMAMOTO Kengo <yamaken AT bp.iij4u.or.jp> 5;; Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com> 6;; 7;; All rights reserved. 8;; 9;; Redistribution and use in source and binary forms, with or without 10;; modification, are permitted provided that the following conditions 11;; are met: 12;; 13;; 1. Redistributions of source code must retain the above copyright 14;; notice, this list of conditions and the following disclaimer. 15;; 2. Redistributions in binary form must reproduce the above copyright 16;; notice, this list of conditions and the following disclaimer in the 17;; documentation and/or other materials provided with the distribution. 18;; 3. Neither the name of authors nor the names of its contributors 19;; may be used to endorse or promote products derived from this software 20;; without specific prior written permission. 21;; 22;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS 23;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 24;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 25;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR 26;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 27;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 28;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 29;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 30;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 31;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 32;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 33 34(require-extension (unittest)) 35 36(if (not (symbol-bound? 'dynamic-wind)) 37 (test-skip "R5RS dynamic-wind is not enabled")) 38 39(define *test-track-progress* #f) 40(define tn test-name) 41 42;; 43;; dynamic-wind 44;; 45 46(define dynwind-res '()) 47(define append-sym! 48 (lambda (sym) 49 (set! dynwind-res (append dynwind-res (list sym))))) 50 51(tn "dynamic-wind: without escape") 52;; no escape with depth 1 53(set! dynwind-res '()) 54(assert-equal? (tn) 55 '(before thunk after) 56 (begin 57 (dynamic-wind 58 (lambda () 59 (append-sym! 'before)) 60 (lambda () 61 (append-sym! 'thunk)) 62 (lambda () 63 (append-sym! 'after))) 64 dynwind-res)) 65 66;; no escape with depth 2 67(set! dynwind-res '()) 68(assert-equal? (tn) 69 '(before1 thunk1 before2 thunk2 after2 after1) 70 (begin 71 (dynamic-wind 72 (lambda () 73 (append-sym! 'before1)) 74 (lambda () 75 (append-sym! 'thunk1) 76 (dynamic-wind 77 (lambda () 78 (append-sym! 'before2)) 79 (lambda () 80 (append-sym! 'thunk2)) 81 (lambda () 82 (append-sym! 'after2)))) 83 (lambda () 84 (append-sym! 'after1))) 85 dynwind-res)) 86 87;; no escape with depth 3 88(set! dynwind-res '()) 89(assert-equal? (tn) 90 '(before1 thunk1 before2 thunk2 before3 thunk3 91 after3 after2 after1) 92 (begin 93 (dynamic-wind 94 (lambda () 95 (append-sym! 'before1)) 96 (lambda () 97 (append-sym! 'thunk1) 98 (dynamic-wind 99 (lambda () 100 (append-sym! 'before2)) 101 (lambda () 102 (append-sym! 'thunk2) 103 (dynamic-wind 104 (lambda () 105 (append-sym! 'before3)) 106 (lambda () 107 (append-sym! 'thunk3)) 108 (lambda () 109 (append-sym! 'after3)))) 110 (lambda () 111 (append-sym! 'after2)))) 112 (lambda () 113 (append-sym! 'after1))) 114 dynwind-res)) 115 116(tn "dynamic-wind: escape from deeper thunk") 117;; escape from thunk1 118(set! dynwind-res '()) 119(assert-equal? (tn) 120 '(before thunk after) 121 (begin 122 (call/cc 123 (lambda (k) 124 (dynamic-wind 125 (lambda () 126 (append-sym! 'before)) 127 (lambda () 128 (append-sym! 'thunk) 129 (k #f)) 130 (lambda () 131 (append-sym! 'after))))) 132 dynwind-res)) 133 134;; escape from thunk2 135(set! dynwind-res '()) 136(assert-equal? (tn) 137 '(before1 thunk1 before2 thunk2 after2 after1) 138 (begin 139 (call/cc 140 (lambda (k) 141 (dynamic-wind 142 (lambda () 143 (append-sym! 'before1)) 144 (lambda () 145 (append-sym! 'thunk1) 146 (dynamic-wind 147 (lambda () 148 (append-sym! 'before2)) 149 (lambda () 150 (append-sym! 'thunk2) 151 (k #f)) 152 (lambda () 153 (append-sym! 'after2)))) 154 (lambda () 155 (append-sym! 'after1))))) 156 dynwind-res)) 157 158;; escape from thunk3 159(set! dynwind-res '()) 160(assert-equal? (tn) 161 '(before1 thunk1 before2 thunk2 before3 thunk3 162 after3 after2 after1) 163 (begin 164 (call/cc 165 (lambda (k) 166 (dynamic-wind 167 (lambda () 168 (append-sym! 'before1)) 169 (lambda () 170 (append-sym! 'thunk1) 171 (dynamic-wind 172 (lambda () 173 (append-sym! 'before2)) 174 (lambda () 175 (append-sym! 'thunk2) 176 (dynamic-wind 177 (lambda () 178 (append-sym! 'before3)) 179 (lambda () 180 (append-sym! 'thunk3) 181 (k #f)) 182 (lambda () 183 (append-sym! 'after3)))) 184 (lambda () 185 (append-sym! 'after2)))) 186 (lambda () 187 (append-sym! 'after1))))) 188 dynwind-res)) 189 190;; escape from thunk3 to thunk1 191(set! dynwind-res '()) 192(assert-equal? (tn) 193 '(before1 thunk1 before2 thunk2 before3 thunk3 194 after3 after2 after1) 195 (begin 196 (dynamic-wind 197 (lambda () 198 (append-sym! 'before1)) 199 (lambda () 200 (append-sym! 'thunk1) 201 (call/cc 202 (lambda (k) 203 (dynamic-wind 204 (lambda () 205 (append-sym! 'before2)) 206 (lambda () 207 (append-sym! 'thunk2) 208 (dynamic-wind 209 (lambda () 210 (append-sym! 'before3)) 211 (lambda () 212 (append-sym! 'thunk3) 213 (k #f)) 214 (lambda () 215 (append-sym! 'after3)))) 216 (lambda () 217 (append-sym! 'after2)))))) 218 (lambda () 219 (append-sym! 'after1))) 220 dynwind-res)) 221 222;; escape from thunk3 to thunk2 223(set! dynwind-res '()) 224(assert-equal? (tn) 225 '(before1 thunk1 before2 thunk2 before3 thunk3 226 after3 after2 after1) 227 (begin 228 (dynamic-wind 229 (lambda () 230 (append-sym! 'before1)) 231 (lambda () 232 (append-sym! 'thunk1) 233 (dynamic-wind 234 (lambda () 235 (append-sym! 'before2)) 236 (lambda () 237 (append-sym! 'thunk2) 238 (call/cc 239 (lambda (k) 240 (dynamic-wind 241 (lambda () 242 (append-sym! 'before3)) 243 (lambda () 244 (append-sym! 'thunk3) 245 (k #f)) 246 (lambda () 247 (append-sym! 'after3)))))) 248 (lambda () 249 (append-sym! 'after2)))) 250 (lambda () 251 (append-sym! 'after1))) 252 dynwind-res)) 253 254;; escape from thunk3 to thunk3 255(set! dynwind-res '()) 256(assert-equal? (tn) 257 '(before1 thunk1 before2 thunk2 before3 thunk3 258 after3 after2 after1) 259 (begin 260 (dynamic-wind 261 (lambda () 262 (append-sym! 'before1)) 263 (lambda () 264 (append-sym! 'thunk1) 265 (dynamic-wind 266 (lambda () 267 (append-sym! 'before2)) 268 (lambda () 269 (append-sym! 'thunk2) 270 (dynamic-wind 271 (lambda () 272 (append-sym! 'before3)) 273 (lambda () 274 (call/cc 275 (lambda (k) 276 (append-sym! 'thunk3) 277 (k #f)))) 278 (lambda () 279 (append-sym! 'after3)))) 280 (lambda () 281 (append-sym! 'after2)))) 282 (lambda () 283 (append-sym! 'after1))) 284 dynwind-res)) 285 286(tn "dynamic-wind: SigScheme-specific escape behavior") 287;; R5RS: 6.4 Control features 288;; > The effect of using a captured continuation to enter or exit the dynamic 289;; > extent of a call to before or after is undefined. 290 291;; escape from before3 to thunk1 292(set! dynwind-res '()) 293(if (provided? "sigscheme") 294 (assert-equal? (tn) 295 '(before1 thunk1 before2 thunk2 before3 after2 after1) 296 (begin 297 (dynamic-wind 298 (lambda () 299 (append-sym! 'before1)) 300 (lambda () 301 (append-sym! 'thunk1) 302 (call/cc 303 (lambda (k) 304 (dynamic-wind 305 (lambda () 306 (append-sym! 'before2)) 307 (lambda () 308 (append-sym! 'thunk2) 309 (dynamic-wind 310 (lambda () 311 (append-sym! 'before3) 312 (k #f)) 313 (lambda () 314 (append-sym! 'thunk3)) 315 (lambda () 316 (append-sym! 'after3)))) 317 (lambda () 318 (append-sym! 'after2)))))) 319 (lambda () 320 (append-sym! 'after1))) 321 dynwind-res))) 322 323;; escape from after3 to thunk1 324(set! dynwind-res '()) 325(if (provided? "sigscheme") 326 (assert-equal? (tn) 327 '(before1 thunk1 before2 thunk2 before3 thunk3 328 after3 after2 after1) 329 (begin 330 (dynamic-wind 331 (lambda () 332 (append-sym! 'before1)) 333 (lambda () 334 (append-sym! 'thunk1) 335 (call/cc 336 (lambda (k) 337 (dynamic-wind 338 (lambda () 339 (append-sym! 'before2)) 340 (lambda () 341 (append-sym! 'thunk2) 342 (dynamic-wind 343 (lambda () 344 (append-sym! 'before3)) 345 (lambda () 346 (append-sym! 'thunk3)) 347 (lambda () 348 (append-sym! 'after3) 349 (k #f)))) 350 (lambda () 351 (append-sym! 'after2)))))) 352 (lambda () 353 (append-sym! 'after1))) 354 dynwind-res))) 355 356;; thunk3 -> after3 -> thunk1 357(set! dynwind-res '()) 358(if (provided? "sigscheme") 359 (assert-equal? (tn) 360 '(before1 thunk1 before2 thunk2 before3 thunk3 361 after3 after2 after1) 362 (begin 363 (dynamic-wind 364 (lambda () 365 (append-sym! 'before1)) 366 (lambda () 367 (append-sym! 'thunk1) 368 (call/cc 369 (lambda (k) 370 (dynamic-wind 371 (lambda () 372 (append-sym! 'before2)) 373 (lambda () 374 (append-sym! 'thunk2) 375 (call/cc 376 (lambda (j) 377 (dynamic-wind 378 (lambda () 379 (append-sym! 'before3)) 380 (lambda () 381 (append-sym! 'thunk3) 382 (j #f)) 383 (lambda () 384 (append-sym! 'after3) 385 (k #f)))))) 386 (lambda () 387 (append-sym! 'after2)))))) 388 (lambda () 389 (append-sym! 'after1))) 390 dynwind-res))) 391 392 393(total-report) 394