From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Tue, 4 Feb 2014 22:24:52 +0000 (-0700)
Subject: Fluidize (runtime syntax) internal variable *rename-database*.
X-Git-Tag: mit-scheme-pucked-9.2.12~401^2~14
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=df816a882ab082687682182b01481eb24247cb4f;p=mit-scheme.git

Fluidize (runtime syntax) internal variable *rename-database*.
---

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 5fbf25630..328ffde9e 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -510,6 +510,7 @@ USA.
    (RUNTIME PRETTY-PRINTER)
    (RUNTIME EXTENDED-SCODE-EVAL)
    (RUNTIME SYNTAX DEFINITIONS)
+   (RUNTIME SYNTAX OUTPUT)
    ;; REP Loops
    (RUNTIME INTERRUPT-HANDLER)
    (RUNTIME GC-STATISTICS)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index a3ddc5176..e3a02903c 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4764,7 +4764,8 @@ USA.
 	  output/variable
 	  rename-identifier
 	  rename-top-level-identifier
-	  transformer-eval))
+	  transformer-eval)
+  (initialization (initialize-package!)))
 
 (define-package (runtime syntax declaration)
   (files "syntax-declaration")
diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm
index da30ad5fb..4fdc2b44d 100644
--- a/src/runtime/syntax-output.scm
+++ b/src/runtime/syntax-output.scm
@@ -403,6 +403,9 @@ USA.
 
 (define *rename-database*)
 
+(define (initialize-package!)
+  (set! *rename-database* (make-fluid 'UNBOUND)))
+
 (define-structure (rename-database (constructor initial-rename-database ())
 				   (conc-name rename-database/))
   (frame-number 0)
@@ -412,22 +415,24 @@ USA.
 
 (define (make-rename-id)
   (delay
-    (let ((n (+ (rename-database/frame-number *rename-database*) 1)))
-      (set-rename-database/frame-number! *rename-database* n)
+    (let* ((renames (fluid *rename-database*))
+	   (n (+ (rename-database/frame-number renames) 1)))
+      (set-rename-database/frame-number! renames n)
       n)))
 
 (define (rename-identifier identifier rename-id)
   (let ((key (cons identifier rename-id))
-	(mapping-table (rename-database/mapping-table *rename-database*)))
-    (or (hash-table/get mapping-table key #f)
-	(let ((mapped-identifier
-	       (utf8-string->uninterned-symbol
-		(symbol-name (identifier->symbol identifier)))))
-	  (hash-table/put! mapping-table key mapped-identifier)
-	  (hash-table/put! (rename-database/unmapping-table *rename-database*)
-			   mapped-identifier
-			   key)
-	  mapped-identifier))))
+	(renames (fluid *rename-database*)))
+    (let ((mapping-table (rename-database/mapping-table renames)))
+      (or (hash-table/get mapping-table key #f)
+	  (let ((mapped-identifier
+		 (utf8-string->uninterned-symbol
+		  (symbol-name (identifier->symbol identifier)))))
+	    (hash-table/put! mapping-table key mapped-identifier)
+	    (hash-table/put! (rename-database/unmapping-table renames)
+			     mapped-identifier
+			     key)
+	    mapped-identifier)))))
 
 (define (rename-top-level-identifier identifier)
   (if (symbol? identifier)
@@ -453,7 +458,8 @@ USA.
 
 (define (unmap-identifier identifier)
   (let ((entry
-	 (hash-table/get (rename-database/unmapping-table *rename-database*)
+	 (hash-table/get (rename-database/unmapping-table
+			  (fluid *rename-database*))
 			 identifier
 			 #f)))
     (if entry
@@ -465,7 +471,8 @@ USA.
 
 (define (finalize-mapped-identifier identifier)
   (let ((entry
-	 (hash-table/get (rename-database/unmapping-table *rename-database*)
+	 (hash-table/get (rename-database/unmapping-table
+			  (fluid *rename-database*))
 			 identifier
 			 #f)))
     (if entry
@@ -484,7 +491,7 @@ USA.
   (symbol "." symbol-to-map "." frame-number))
 
 (define (map-uninterned-identifier identifier frame-number)
-  (let ((table (rename-database/id-table *rename-database*))
+  (let ((table (rename-database/id-table (fluid *rename-database*)))
 	(symbol (identifier->symbol identifier)))
     (let ((alist (hash-table/get table symbol '())))
       (let ((entry (assv frame-number alist)))
diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index 92435cc4e..d80fe9583 100644
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -49,13 +49,14 @@ USA.
 (define (syntax* forms environment)
   (guarantee-list forms 'SYNTAX*)
   (let ((senv (->syntactic-environment environment 'SYNTAX*)))
-    (fluid-let ((*rename-database* (initial-rename-database)))
-      (output/post-process-expression
-       (if (syntactic-environment/top-level? senv)
-	   (compile-body-item/top-level
-	    (let ((senv (make-top-level-syntactic-environment senv)))
-	      (classify/body forms senv senv)))
-	   (output/sequence (compile/expressions forms senv)))))))
+    (let-fluid *rename-database* (initial-rename-database)
+      (lambda ()
+	(output/post-process-expression
+	 (if (syntactic-environment/top-level? senv)
+	     (compile-body-item/top-level
+	      (let ((senv (make-top-level-syntactic-environment senv)))
+		(classify/body forms senv senv)))
+	     (output/sequence (compile/expressions forms senv))))))))
 
 (define (compile/expression expression environment)
   (compile-item/expression (classify/expression expression environment)))