test-suite/tests/dynamic-scope.test

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