mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 19:50:24 +02:00
deprecate @bind
* module/ice-9/boot-9.scm: * module/ice-9/deprecated.scm (@bind): Deprecate @bind, which was a thread-unsafe dynamic scoping mechanism, used in the old elisp support. Fluids are more correct, and are probably faster, given the VM support for with-fluids. * test-suite/tests/dynamic-scope.test: Remove. * test-suite/tests/fluids.test: Move relevant tests from dynamic-scope.test here, recast in terms of with-fluids.
This commit is contained in:
Andy Wingo
parent
b9e67767ae
commit
0abc210944
4 changed files with 93 additions and 121 deletions
|
|
@ -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}
|
||||
|
|
|
|||
|
|
@ -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) ...)))))))))
|
||||
|
|
|
|||
|
|
@ -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))))))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -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))))))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue