summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/ice-9/boot-9.scm32
-rw-r--r--module/ice-9/deprecated.scm38
-rw-r--r--test-suite/tests/dynamic-scope.test88
-rw-r--r--test-suite/tests/fluids.test56
4 files changed, 93 insertions, 121 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index ffd1f6876..4beec1e64 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -470,38 +470,6 @@ If there is no handler at all, Guile prints an error and then exits."
(include-from-path "ice-9/quasisyntax")
-;;; @bind is used by the old elisp code as a dynamic scoping mechanism.
-;;; Please let the Guile developers know if you are using this macro.
-;;;
-(define-syntax @bind
- (lambda (x)
- (define (bound-member id ids)
- (cond ((null? ids) #f)
- ((bound-identifier=? id (car ids)) #t)
- ((bound-member (car ids) (cdr ids)))))
-
- (syntax-case x ()
- ((_ () b0 b1 ...)
- #'(let () b0 b1 ...))
- ((_ ((id val) ...) b0 b1 ...)
- (and-map identifier? #'(id ...))
- (if (let lp ((ids #'(id ...)))
- (cond ((null? ids) #f)
- ((bound-member (car ids) (cdr ids)) #t)
- (else (lp (cdr ids)))))
- (syntax-violation '@bind "duplicate bound identifier" x)
- (with-syntax (((old-v ...) (generate-temporaries #'(id ...)))
- ((v ...) (generate-temporaries #'(id ...))))
- #'(let ((old-v id) ...
- (v val) ...)
- (dynamic-wind
- (lambda ()
- (set! id v) ...)
- (lambda () b0 b1 ...)
- (lambda ()
- (set! id old-v) ...)))))))))
-
-
;;; {Defmacros}
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index 081f3f853..02ba5376f 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -36,7 +36,9 @@
$sinh
$cosh
$tanh
- closure?))
+ closure?
+ %nil
+ @bind))
;;;; Deprecated definitions.
@@ -260,3 +262,37 @@
(procedure? x))
(define %nil #nil)
+
+;;; @bind is used by the old elisp code as a dynamic scoping mechanism.
+;;; Please let the Guile developers know if you are using this macro.
+;;;
+(define-syntax @bind
+ (lambda (x)
+ (define (bound-member id ids)
+ (cond ((null? ids) #f)
+ ((bound-identifier=? id (car ids)) #t)
+ ((bound-member (car ids) (cdr ids)))))
+
+ (issue-deprecation-warning
+ "`@bind' is deprecated. Use `with-fluids' instead.")
+
+ (syntax-case x ()
+ ((_ () b0 b1 ...)
+ #'(let () b0 b1 ...))
+ ((_ ((id val) ...) b0 b1 ...)
+ (and-map identifier? #'(id ...))
+ (if (let lp ((ids #'(id ...)))
+ (cond ((null? ids) #f)
+ ((bound-member (car ids) (cdr ids)) #t)
+ (else (lp (cdr ids)))))
+ (syntax-violation '@bind "duplicate bound identifier" x)
+ (with-syntax (((old-v ...) (generate-temporaries #'(id ...)))
+ ((v ...) (generate-temporaries #'(id ...))))
+ #'(let ((old-v id) ...
+ (v val) ...)
+ (dynamic-wind
+ (lambda ()
+ (set! id v) ...)
+ (lambda () b0 b1 ...)
+ (lambda ()
+ (set! id old-v) ...)))))))))
diff --git a/test-suite/tests/dynamic-scope.test b/test-suite/tests/dynamic-scope.test
deleted file mode 100644
index 08cf1c4e1..000000000
--- a/test-suite/tests/dynamic-scope.test
+++ /dev/null
@@ -1,88 +0,0 @@
-;;;; -*- 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))))))))
-
-
-
diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test
index 3784e548b..8604dcbb2 100644
--- a/test-suite/tests/fluids.test
+++ b/test-suite/tests/fluids.test
@@ -21,10 +21,31 @@
:use-module (test-suite lib))
+(define exception:syntax-error
+ (cons 'syntax-error "failed to match"))
+(define exception:duplicate-binding
+ (cons 'syntax-error "duplicate"))
+
(define a (make-fluid))
(define b (make-fluid))
(define c #f)
+(with-test-prefix "syntax"
+ (pass-if-exception "with-fluids missing expression"
+ exception:syntax-error
+ (eval '(with-fluids ((a 1)))
+ (interaction-environment)))
+
+ (pass-if-exception "with-fluids bad bindings"
+ exception:syntax-error
+ (eval '(with-fluids (a) #f)
+ (interaction-environment)))
+
+ (pass-if-exception "with-fluids bad bindings"
+ exception:syntax-error
+ (eval '(with-fluids ((a)) #f)
+ (interaction-environment))))
+
(with-test-prefix "initial fluid values"
(pass-if "fluid-ref uninitialized fluid is #f"
(not (fluid-ref a)))
@@ -91,3 +112,38 @@
(loop (1- i)))))
(gc)
(fluid? (g))))
+
+(with-test-prefix "with-fluids"
+
+ (pass-if "with-fluids binds"
+ (= (with-fluids ((a 1)) (fluid-ref a)) 1))
+
+ (pass-if "with-fluids unbinds"
+ (begin
+ (fluid-set! a 0)
+ (with-fluids ((a 1)) (fluid-ref a))
+ (= (fluid-ref a) 0)))
+
+ (pass-if "with-fluids 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)
+ (with-fluids ((a 'inside))
+ (yield (fluid-ref a))
+ (yield (fluid-ref a)))))
+
+ (fluid-set! a 'outside)
+ (let ((inside-a (yield #f)))
+ (let ((outside-a (fluid-ref a)))
+ (let ((inside-a2 (yield #f)))
+ (and (eq? inside-a 'inside)
+ (eq? outside-a 'outside)
+ (eq? inside-a2 'inside))))))))