Simplify interface to syntax renaming.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 2264f47d2c67aee7735300944ee0c47fc4809361..96a2a3ded74c7b9b37899be739a26e217443935b 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4507,13 +4507,9 @@ USA.
   (files "syntax-rename")
   (parent (runtime syntax))
   (export (runtime syntax)
-         *rename-database*
-         initial-rename-database
-         make-name-generator
-         make-rename-id
-         output/post-process-expression
-         rename-identifier
-         rename-top-level-identifier))
+         make-local-identifier-renamer
+         rename-top-level-identifier
+         with-identifier-renaming))
 
 (define-package (runtime syntax output)
   (files "syntax-output")

diff --git a/src/runtime/syntax-environment.scm b/src/runtime/syntax-environment.scm
index fff0b8075797737b2088aaa7d41ac70d2c625491..89b63ef0b35975e9b032acb4ed65585247e750fd 100644 (file)
--- a/src/runtime/syntax-environment.scm
+++ b/src/runtime/syntax-environment.scm
@@ -181,7 +181,7 @@ USA.
   (let ((bound '())
        (free '())
        (get-runtime (senv-get-runtime parent))
-       (rename (make-name-generator)))
+       (rename (make-local-identifier-renamer)))
 
     (define (get-type)
       'internal)

diff --git a/src/runtime/syntax-rename.scm b/src/runtime/syntax-rename.scm
index f750054c0c1adf9c22a5d77706d7005fd163e4c7..61eb325c1657152e138bab1ca2e138350ad2a646 100644 (file)
--- a/src/runtime/syntax-rename.scm
+++ b/src/runtime/syntax-rename.scm
@@ -48,12 +48,16 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (make-name-generator)
+(define (make-local-identifier-renamer)
   (let ((id (make-rename-id)))
     (lambda (identifier)
       (rename-identifier identifier id))))
 
-(define-deferred *rename-database*
+(define (with-identifier-renaming thunk)
+  (parameterize* (list (cons rename-db (initial-rename-database)))
+                (lambda () (post-process-output (thunk)))))
+
+(define-deferred rename-db
   (make-unsettable-parameter 'unbound))
 
 (define-structure (rename-database (constructor initial-rename-database ())
@@ -65,14 +69,14 @@ USA.
 
 (define (make-rename-id)
   (delay
-    (let* ((renames (*rename-database*))
+    (let* ((renames (rename-db))
           (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))
-       (renames (*rename-database*)))
+       (renames (rename-db)))
     (let ((mapping-table (rename-database/mapping-table renames)))
       (or (hash-table/get mapping-table key #f)
          (let ((mapped-identifier
@@ -104,7 +108,7 @@ USA.
 (define (rename->original identifier)
   (let ((entry
         (hash-table/get (rename-database/unmapping-table
-                         (*rename-database*))
+                         (rename-db))
                         identifier
                         #f)))
     (if entry
@@ -116,7 +120,7 @@ USA.
 \f
 ;;;; Post processing
 
-(define (output/post-process-expression expression)
+(define (post-process-output expression)
   (let ((safe-set (make-strong-eq-hash-table)))
     (compute-substitution expression
                          (lambda (rename original)
@@ -144,7 +148,7 @@ USA.
 (define (finalize-mapped-identifier identifier)
   (let ((entry
         (hash-table/get (rename-database/unmapping-table
-                         (*rename-database*))
+                         (rename-db))
                         identifier
                         #f)))
     (if entry
@@ -163,7 +167,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 (rename-db)))
        (symbol (identifier->symbol identifier)))
     (let ((alist (hash-table/get table symbol '())))
       (let ((entry (assv frame-number alist)))

diff --git a/src/runtime/syntax-rules.scm b/src/runtime/syntax-rules.scm
index 4728c04a8017e553cc20231c28987774617c62c3..954ce9a280a227cb8fc525c57556616579429f29 100644 (file)
--- a/src/runtime/syntax-rules.scm
+++ b/src/runtime/syntax-rules.scm
@@ -83,7 +83,7 @@ USA.
          ((and (or (zero-or-more? pattern rename compare)
                    (at-least-one? pattern rename compare))
                (null? (cddr pattern)))
-          (let ((variable ((make-name-generator) 'CONTROL)))
+          (let ((variable ((make-local-identifier-renamer) 'CONTROL)))
             (loop (car pattern)
                   variable
                   sids

diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index 1d85a91f7568a0d67fa715a044a7b6399fe587b3..dbe842c296de9b5ef9d5554c9a992a94a7b066fe 100644 (file)
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -47,15 +47,14 @@ USA.
   (syntax* (list form) environment))
 
 (define (syntax* forms environment)
-  (guarantee list? forms 'SYNTAX*)
-  (let ((senv (->syntactic-environment environment 'SYNTAX*)))
-    (parameterize* (list (cons *rename-database* (initial-rename-database)))
-      (lambda ()
-       (output/post-process-expression
-        (if (syntactic-environment/top-level? senv)
-            (compile-body-item/top-level
-             (classify/body forms (make-top-level-syntactic-environment senv)))
-            (output/sequence (compile/expressions forms senv))))))))
+  (guarantee list? forms 'syntax*)
+  (let ((senv (->syntactic-environment environment 'syntax*)))
+    (with-identifier-renaming
+     (lambda ()
+       (if (syntactic-environment/top-level? senv)
+          (compile-body-item/top-level
+           (classify/body forms (make-top-level-syntactic-environment senv)))
+          (output/sequence (compile/expressions forms senv)))))))
 
 (define (compile/expression expression environment)
   (compile-item/expression (classify/expression expression environment)))