From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 29 Dec 2001 04:16:32 +0000 (+0000)
Subject: Oops... last revision deleted a little too much.
X-Git-Tag: 20090517-FFI~2307
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=60a937dc22d7a99fcb41e18fbc62b09534f6c7cf;p=mit-scheme.git

Oops... last revision deleted a little too much.
---

diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm
index f3a651771..b605921ed 100644
--- a/v7/src/runtime/syntax.scm
+++ b/v7/src/runtime/syntax.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: syntax.scm,v 14.51 2001/12/24 04:21:50 cph Exp $
+$Id: syntax.scm,v 14.52 2001/12/29 04:16:32 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -452,7 +452,35 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	     (make-thunk (make-scode-sequence transfers-in))
 	     (make-thunk (syntax-subsequence body))
 	     (make-thunk (make-scode-sequence transfers-out))))))))
-
+
+(define (syntax-fluid-bindings/shallow bindings receiver)
+  (if (pair? bindings)
+      (syntax-fluid-bindings/shallow (cdr bindings)
+	(lambda (names values transfers-in transfers-out)
+	  (let ((binding (car bindings)))
+	    (if (pair? binding)
+		(let ((transfer
+		       (let ((reference (syntax-subexpression (car binding))))
+			 (let ((assignment (invert-expression reference)))
+			   (lambda (target source)
+			     (make-assignment
+			      target
+			      (assignment (make-assignment source)))))))
+		      (value (expand-binding-value (cdr binding)))
+		      (inside-name
+		       (string->uninterned-symbol "INSIDE-PLACEHOLDER"))
+		      (outside-name
+		       (string->uninterned-symbol "OUTSIDE-PLACEHOLDER")))
+		  (receiver (cons* inside-name outside-name names)
+			    (cons* value (make-unassigned-reference-trap)
+				   values)
+			    (cons (transfer outside-name inside-name)
+				  transfers-in)
+			    (cons (transfer inside-name outside-name)
+				  transfers-out)))
+		(syntax-error "binding not a pair" binding)))))
+      (receiver '() '() '() '())))
+
 ;;;; Extended Assignment Syntax
 
 (define (invert-expression target)