Commit | Line | Data |
---|---|---|
11503928 MV |
1 | ;;;; -*- scheme -*- |
2 | ;;;; dynamic-scop.test --- test suite for dynamic scoping constructs | |
3 | ;;;; | |
6e7d5622 | 4 | ;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. |
11503928 | 5 | ;;;; |
53befeb7 NJ |
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. | |
11503928 | 10 | ;;;; |
53befeb7 | 11 | ;;;; This library is distributed in the hope that it will be useful, |
11503928 | 12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
53befeb7 NJ |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
14 | ;;;; Lesser General Public License for more details. | |
11503928 | 15 | ;;;; |
53befeb7 NJ |
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 | |
11503928 | 19 | |
d6e04e7c DH |
20 | (define-module (test-suite test-dynamic-scope) |
21 | :use-module (test-suite lib)) | |
22 | ||
23 | ||
82b3e2c6 DH |
24 | (define exception:missing-expr |
25 | (cons 'syntax-error "Missing expression")) | |
d6e04e7c | 26 | (define exception:bad-binding |
82b3e2c6 DH |
27 | (cons 'syntax-error "Bad binding")) |
28 | (define exception:duplicate-binding | |
29 | (cons 'syntax-error "Duplicate binding")) | |
11503928 MV |
30 | |
31 | (define global-a 0) | |
32 | (define (fetch-global-a) global-a) | |
33 | ||
34 | (with-test-prefix "dynamic scope" | |
35 | ||
36 | (pass-if "@bind binds" | |
37 | (= (@bind ((global-a 1)) (fetch-global-a)) 1)) | |
38 | ||
39 | (pass-if "@bind unbinds" | |
40 | (begin | |
41 | (set! global-a 0) | |
42 | (@bind ((global-a 1)) (fetch-global-a)) | |
43 | (= global-a 0))) | |
44 | ||
45 | (pass-if-exception "duplicate @binds" | |
d6e04e7c DH |
46 | exception:duplicate-binding |
47 | (eval '(@bind ((a 1) (a 2)) (+ a a)) | |
48 | (interaction-environment))) | |
11503928 MV |
49 | |
50 | (pass-if-exception "@bind missing expression" | |
82b3e2c6 | 51 | exception:missing-expr |
d6e04e7c DH |
52 | (eval '(@bind ((global-a 1))) |
53 | (interaction-environment))) | |
11503928 MV |
54 | |
55 | (pass-if-exception "@bind bad bindings" | |
d6e04e7c DH |
56 | exception:bad-binding |
57 | (eval '(@bind (a) #f) | |
58 | (interaction-environment))) | |
11503928 MV |
59 | |
60 | (pass-if-exception "@bind bad bindings" | |
d6e04e7c DH |
61 | exception:bad-binding |
62 | (eval '(@bind ((a)) #f) | |
63 | (interaction-environment))) | |
11503928 MV |
64 | |
65 | (pass-if "@bind and dynamic-wind" | |
66 | (letrec ((co-routine #f) | |
67 | (spawn (lambda (proc) | |
68 | (set! co-routine proc))) | |
69 | (yield (lambda (val) | |
70 | (call-with-current-continuation | |
71 | (lambda (k) | |
72 | (let ((next co-routine)) | |
73 | (set! co-routine k) | |
74 | (next val))))))) | |
75 | ||
76 | (spawn (lambda (val) | |
77 | (@bind ((global-a 'inside)) | |
78 | (yield global-a) | |
79 | (yield global-a)))) | |
80 | ||
81 | (set! global-a 'outside) | |
82 | (let ((inside-a (yield #f))) | |
83 | (let ((outside-a global-a)) | |
84 | (let ((inside-a2 (yield #f))) | |
85 | (and (eq? inside-a 'inside) | |
86 | (eq? outside-a 'outside) | |
87 | (eq? inside-a2 'inside)))))))) | |
88 | ||
89 | ||
90 |