diff options
-rw-r--r-- | module/ice-9/boot-9.scm | 32 | ||||
-rw-r--r-- | module/ice-9/deprecated.scm | 38 | ||||
-rw-r--r-- | test-suite/tests/dynamic-scope.test | 88 | ||||
-rw-r--r-- | test-suite/tests/fluids.test | 56 |
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)))))))) |