From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Tue, 4 Feb 2014 21:09:29 +0000 (-0700)
Subject: Fluidize (runtime program-copier) internal *copy-constants*?,...
X-Git-Tag: mit-scheme-pucked-9.2.12~401^2~17
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=dc8fe06cf0ed71cbf0673b1e86dc2c06ae1f78a6;p=mit-scheme.git

Fluidize (runtime program-copier) internal *copy-constants*?,...

...and *object-copies*.
---

diff --git a/src/runtime/prgcop.scm b/src/runtime/prgcop.scm
index 3b1ed04e5..b065b7b92 100644
--- a/src/runtime/prgcop.scm
+++ b/src/runtime/prgcop.scm
@@ -33,6 +33,8 @@ USA.
   (object-new-type primitive-object-new-type 2))
 
 (define (initialize-package!)
+  (set! *copy-constants?* (make-fluid 'UNBOUND))
+  (set! *object-copies* (make-fluid 'UNBOUND))
   (set! copier/scode-walker
 	(make-scode-walker
 	 copy-constant
@@ -64,10 +66,10 @@ USA.
   (list '*OBJECT-COPIES*))
 
 (define-integrable (object-association object)
-  (assq object (cdr *object-copies*)))
+  (assq object (cdr (fluid *object-copies*))))
 
 (define (add-association! object other)
-  (let* ((table *object-copies*)
+  (let* ((table (fluid *object-copies*))
 	 (place (assq object (cdr table))))
     (cond ((not place)
 	   (set-cdr! table (cons (cons object other) (cdr table))))
@@ -81,13 +83,14 @@ USA.
   ;; do not have enough information to determine what the
   ;; variable name was.  The original block can be used for
   ;; this, but it may as well be copied then.
-  (fluid-let ((*copy-constants?*
-	       (if (default-object? copy-constants?)
-		   *default/copy-constants?*
-		   copy-constants?))
-	      (*object-copies*
-	       (make-object-association-table)))
-    (copy-object exp)))
+  (let-fluids *copy-constants?*
+	      (if (default-object? copy-constants?)
+		  *default/copy-constants?*
+		  copy-constants?)
+	      *object-copies*
+	      (make-object-association-table)
+    (lambda ()
+      (copy-object exp))))
 
 (define (copy-object obj)
   (let ((association (object-association obj)))
@@ -100,7 +103,7 @@ USA.
 	 (%copy-compiled-code-address obj))
 	((compiled-code-block? obj)
 	 (%copy-compiled-code-block obj))
-	((not *copy-constants?*)
+	((not (fluid *copy-constants?*))
 	 obj)
 	(else
 	 (%copy-constant obj))))