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