From 12136c7148485e1a32cc1c59797289f46706fd45 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Thu, 20 Aug 2009 12:48:11 +0200
Subject: [PATCH] define @bind using syntax-case

* module/ice-9/boot-9.scm (@bind): Define a VM-compatible syntax
  definition for this old evaluator primitive.

* test-suite/tests/dynamic-scope.test: Change the expected error
  messages.
---
 module/ice-9/boot-9.scm             | 32 +++++++++++++++++++++++++++++
 test-suite/tests/dynamic-scope.test | 16 +++++++--------
 2 files changed, 39 insertions(+), 9 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 574cb2b1a..a3a1e0384 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -308,6 +308,38 @@
   (syntax-rules ()
     ((_ exp) (make-promise (lambda () exp)))))
 
+;;; @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/test-suite/tests/dynamic-scope.test b/test-suite/tests/dynamic-scope.test
index 77be3b480..08cf1c4e1 100644
--- a/test-suite/tests/dynamic-scope.test
+++ b/test-suite/tests/dynamic-scope.test
@@ -1,7 +1,7 @@
 ;;;;                                                          -*- scheme -*-
 ;;;; dynamic-scop.test --- test suite for dynamic scoping constructs
 ;;;;
-;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;; 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
@@ -21,12 +21,10 @@
   :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:syntax-error
+  (cons 'syntax-error "failed to match"))
 (define exception:duplicate-binding
-  (cons 'syntax-error "Duplicate binding"))
+  (cons 'syntax-error "duplicate"))
 
 (define global-a 0)
 (define (fetch-global-a) global-a)
@@ -48,17 +46,17 @@
 	  (interaction-environment)))
 
   (pass-if-exception "@bind missing expression"
-    exception:missing-expr
+    exception:syntax-error
     (eval '(@bind ((global-a 1)))
 	  (interaction-environment)))
 
   (pass-if-exception "@bind bad bindings"
-    exception:bad-binding
+    exception:syntax-error
     (eval '(@bind (a) #f)
 	  (interaction-environment)))
 
   (pass-if-exception "@bind bad bindings"
-    exception:bad-binding
+    exception:syntax-error
     (eval '(@bind ((a)) #f)
 	  (interaction-environment)))