From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 21 May 1987 16:41:30 +0000 (+0000)
Subject: Undo FLUID-LET changes from last version.
X-Git-Tag: 20090517-FFI~13489
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e2195054ed8b721f62e37a8878f5ba72180225fd;p=mit-scheme.git

Undo FLUID-LET changes from last version.
---

diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm
index d37bed313..8ac22960f 100644
--- a/v7/src/runtime/syntax.scm
+++ b/v7/src/runtime/syntax.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 13.45 1987/05/19 13:38:56 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 13.46 1987/05/21 16:40:59 cph Exp $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -559,7 +559,7 @@
 
     (define (syntax-fluid-bindings bindings receiver)
       (if (null? bindings)
-	  (receiver '() '() (list false) (list false))
+	  (receiver '() '() '() '())
 	  (syntax-fluid-bindings (cdr bindings)
 	    (lambda (names values transfers-in transfers-out)
 	      (let ((binding (car bindings)))
@@ -568,11 +568,11 @@
 			   (let ((reference (syntax-expression (car binding))))
 			     (let ((assignment (invert-expression reference)))
 			       (lambda (target source)
-				 (make-sequence*
-				  (make-assignment target reference)
-				  (assignment (make-variable source))
-				  (make-assignment source
-						   unassigned-object))))))
+				 (make-assignment
+				  target
+				  (assignment
+				   (make-assignment source
+						    unassigned-object)))))))
 			  (value (expand-binding-value (cdr binding)))
 			  (inside-name
 			   (string->uninterned-symbol "INSIDE-PLACEHOLDER"))
diff --git a/v7/src/runtime/unsyn.scm b/v7/src/runtime/unsyn.scm
index 29b518dea..4c4e0494b 100644
--- a/v7/src/runtime/unsyn.scm
+++ b/v7/src/runtime/unsyn.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 13.43 1987/05/19 13:38:31 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 13.44 1987/05/21 16:41:30 cph Exp $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -331,8 +331,7 @@
   (combination-components body
     (lambda (operator operands)
       `(FLUID-LET ,(unsyntax-let-bindings
-		    (extract-transfer-variables
-		     (sequence-actions (lambda-body (car operands))))
+		    (map extract-transfer-var (lambda-body (car operands)))
 		    (let every-other ((values values))
 		      (if (null? values)
 			  '()
@@ -341,11 +340,21 @@
 	     (lambda (name required optional rest body)
 	       (unsyntax-sequence body)))))))
 
-(define (extract-transfer-variables actions)
-  (if (assignment? (car actions))
-      (cons (unsyntax-object (assignment-value (car actions)))
-	    (extract-transfer-variables (cdddr actions)))
-      '()))
+(define (extract-transfer-var assignment)
+  (assignment-components assignment
+    (lambda (name value)
+      (cond ((assignment? value)
+	     (assignment-components value (lambda (name value) name)))
+	    ((combination? value)
+	     (combination-components value
+	       (lambda (operator operands)
+		 (cond ((eq? operator lexical-assignment)
+			`(ACCESS ,(cadr operands)
+				 ,@(unexpand-access (car operands))))
+		       (else
+			(error "FLUID-LET: Unknown SCODE form" assignment))))))
+	    (else
+	     (error "FLUID-LET: Unknown SCODE form" assignment))))))
 
 (define ((unsyntax-deep-or-common-FLUID-LET name prim)
 	 ignored-required ignored-operands body)