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

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 5fbf25630894e99c1247caed46c8d6795c02307e..328ffde9eee91d8492925c852b8d574f3755fc1b 100644 (file)
--- 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 a3ddc5176edbac972f929d6f7c902123c03d4901..e3a02903ca103af23e414e2b6f10b3f4fc97f4a1 100644 (file)
--- 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 da30ad5fb29eeaf5b964699b223ee74786328846..4fdc2b44ddcb53970ca60f3499750a9e1e6a2b58 100644 (file)
--- 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.
 \f
 (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 92435cc4eafc397464bf29a3799f2fa755d0ad4f..d80fe95832dfdce7161cc1eb58e281464d0696e3 100644 (file)
--- 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)))