From 60a937dc22d7a99fcb41e18fbc62b09534f6c7cf Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 29 Dec 2001 04:16:32 +0000 Subject: [PATCH] Oops... last revision deleted a little too much. --- v7/src/runtime/syntax.scm | 32 ++++++++++++++++++++++++++++++-- 1 file changed, 30 insertions(+), 2 deletions(-) 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) -- 2.25.1