From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 26 Jan 2018 06:16:26 +0000 (-0800)
Subject: Simplify interface to syntax renaming.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~300
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=466ad57d9f1885a60e52f4bbe8bf974dec9fc505;p=mit-scheme.git

Simplify interface to syntax renaming.
---

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 2264f47d2..96a2a3ded 100644
--- 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 fff0b8075..89b63ef0b 100644
--- 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 f750054c0..61eb325c1 100644
--- a/src/runtime/syntax-rename.scm
+++ b/src/runtime/syntax-rename.scm
@@ -48,12 +48,16 @@ USA.
 
 (declare (usual-integrations))
 
-(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.
 
 ;;;; 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 4728c04a8..954ce9a28 100644
--- 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 1d85a91f7..dbe842c29 100644
--- 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)))