Simplify idiom for implementing dynamic binding.

diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index 03538fd533058fc64db525596f6f07c66dad68b4..599a086c0ff86cb643c653a01535f1feef75a356 100644 (file)
--- 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 98deb9031a20b259a142f0a77bd2b9fb598b1155..c181de728c364a4130f9c471eaac1f938a920b39 100644 (file)
--- 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))