blob: d7a06a411a555788248520143ab3dcc77dffbdf7 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
|
;;;; -*- scheme -*-
;;;; dynamic-scop.test --- test suite for dynamic scoping constructs
;;;;
;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program 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 General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
(define-module (test-suite test-dynamic-scope)
:use-module (test-suite lib))
(define exception:missing-expr
(cons 'syntax-error "Missing expression"))
(define exception:bad-binding
(cons 'syntax-error "Bad binding"))
(define exception:duplicate-binding
(cons 'syntax-error "Duplicate binding"))
(define global-a 0)
(define (fetch-global-a) global-a)
(with-test-prefix "dynamic scope"
(pass-if "@bind binds"
(= (@bind ((global-a 1)) (fetch-global-a)) 1))
(pass-if "@bind unbinds"
(begin
(set! global-a 0)
(@bind ((global-a 1)) (fetch-global-a))
(= global-a 0)))
(pass-if-exception "duplicate @binds"
exception:duplicate-binding
(eval '(@bind ((a 1) (a 2)) (+ a a))
(interaction-environment)))
(pass-if-exception "@bind missing expression"
exception:missing-expr
(eval '(@bind ((global-a 1)))
(interaction-environment)))
(pass-if-exception "@bind bad bindings"
exception:bad-binding
(eval '(@bind (a) #f)
(interaction-environment)))
(pass-if-exception "@bind bad bindings"
exception:bad-binding
(eval '(@bind ((a)) #f)
(interaction-environment)))
(pass-if "@bind 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)
(@bind ((global-a 'inside))
(yield global-a)
(yield global-a))))
(set! global-a 'outside)
(let ((inside-a (yield #f)))
(let ((outside-a global-a))
(let ((inside-a2 (yield #f)))
(and (eq? inside-a 'inside)
(eq? outside-a 'outside)
(eq? inside-a2 'inside))))))))
|
