guile/test-suite/tests/dynamic-scope.test

;;;;                                                          -*- 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))))))))