summaryrefslogtreecommitdiff
path: root/test-suite/tests/dynamic-scope.test
blob: 08cf1c4e1355641af030bfcb3f713347e57795e0 (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
;;;;                                                          -*- scheme -*-
;;;; dynamic-scop.test --- test suite for dynamic scoping constructs
;;;;
;;;; Copyright (C) 2001, 2006, 2009 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-dynamic-scope)
  :use-module (test-suite lib))


(define exception:syntax-error
  (cons 'syntax-error "failed to match"))
(define exception:duplicate-binding
  (cons 'syntax-error "duplicate"))

(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:syntax-error
    (eval '(@bind ((global-a 1)))
	  (interaction-environment)))

  (pass-if-exception "@bind bad bindings"
    exception:syntax-error
    (eval '(@bind (a) #f)
	  (interaction-environment)))

  (pass-if-exception "@bind bad bindings"
    exception:syntax-error
    (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))))))))