From: Taylor R Campbell <campbell@mumble.net>
Date: Mon, 13 Sep 2010 15:34:17 +0000 (+0000)
Subject: Simplify idiom for implementing dynamic binding.
X-Git-Tag: 20101212-Gtk~56
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=dfeb2c8df33a306b6111e91be305f199b9a5dff7;p=mit-scheme.git

Simplify idiom for implementing dynamic binding.
---

diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index 03538fd53..599a086c0 100644
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -124,36 +124,16 @@ USA.
 (define (limit-interrupts! limit-mask)
   (set-interrupt-enables! (fix:and limit-mask (get-interrupt-enables))))
 
-(define (object-component-binder get-component set-component!)
-  (lambda (object new-value thunk)
-    (let ((old-value))
-      (shallow-fluid-bind
-       (lambda ()
-	 (set! old-value (get-component object))
-	 (set-component! object new-value)
-	 (set! new-value #f)
-	 unspecific)
-       thunk
-       (lambda ()
-	 (set! new-value (get-component object))
-	 (set-component! object old-value)
-	 (set! old-value #f)
-	 unspecific)))))
-
-(define (bind-cell-contents! cell new-value thunk)
-  (let ((old-value))
-    (shallow-fluid-bind
-     (lambda ()
-       (set! old-value (cell-contents cell))
-       (set-cell-contents! cell new-value)
-       (set! new-value)
-       unspecific)
-     thunk
-     (lambda ()
-       (set! new-value (cell-contents cell))
-       (set-cell-contents! cell old-value)
-       (set! old-value)
-       unspecific))))
+(define-integrable (object-component-binder get-component set-component!)
+  (lambda (object value thunk)
+    (define (swap!)
+      (let ((value* value))
+	(set! value (get-component object))
+	(set-component! object value*)))
+    (shallow-fluid-bind swap! thunk swap!)))
+
+(define bind-cell-contents!
+  (object-component-binder cell-contents set-cell-contents!))
 
 (define (values . objects)
   (lambda (receiver)
diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 98deb9031..c181de728 100644
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -529,36 +529,27 @@ USA.
      compare
      (syntax-check '(KEYWORD (* (FORM ? EXPRESSION)) + FORM) form)
      (let ((names (map car (cadr form)))
-	   (r-let (rename 'LET))
+	   (expressions (map cadr (cadr form)))
+	   (r-define (rename 'DEFINE))
 	   (r-lambda (rename 'LAMBDA))
-	   (r-set! (rename 'SET!)))
-       (let ((out-temps
-	      (map (lambda (name)
-		     name
-		     (make-synthetic-identifier 'OUT-TEMP))
-		   names))
-	     (in-temps
-	      (map (lambda (name)
-		     name
-		     (make-synthetic-identifier 'IN-TEMP))
-		   names))
-	     (swap
-	      (lambda (tos names froms)
-		`(,r-lambda ()
-			    ,@(map (lambda (to name from)
-				     `(,r-set! ,to
-					       (,r-set! ,name
-							(,r-set! ,from))))
-				   tos
-				   names
-				   froms)
-			    ,(unspecific-expression)))))
-	 `(,r-let (,@(map cons in-temps (map cdr (cadr form)))
-		   ,@(map list out-temps))
-		  (,(rename 'SHALLOW-FLUID-BIND)
-		   ,(swap out-temps names in-temps)
-		   (,r-lambda () ,@(cddr form))
-		   ,(swap in-temps names out-temps))))))))
+	   (r-let (rename 'LET))
+	   (r-set! (rename 'SET!))
+	   (r-shallow-fluid-bind (rename 'SHALLOW-FLUID-BIND))
+	   (r-unspecific (rename 'UNSPECIFIC)))
+       (let ((temporaries (map make-synthetic-identifier names))
+	     (swap! (make-synthetic-identifier 'SWAP!))
+	     (body `(,r-lambda () ,@(cddr form))))
+	 `(,r-let ,(map list temporaries expressions)
+	    (,r-define (,swap!)
+	      ,@(map (lambda (name temporary)
+		       (let ((temporary* (make-synthetic-identifier 'TEMP)))
+			 `(,r-let ((,temporary* ,temporary))
+			    (,r-set! ,temporary ,name)
+			    (,r-set! ,name ,temporary*))))
+		     names
+		     temporaries)
+	      ,r-unspecific)
+	    (,r-shallow-fluid-bind ,swap! ,body ,swap!)))))))
 
 (define (unspecific-expression)
   `(,keyword:unspecific))