From 69809844c4d83ff6cef5208d17c7a8f6e98bec8e Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 1 Mar 2002 05:43:26 +0000
Subject: [PATCH] Rewrite renaming code to allocate temporary uninterned
 symbols during expansion, then map them to interned symbols in a post pass. 
 Mapping algorithm avoids renaming where possible, keeping original names of
 identifiers in outermost frames in cases of conflict.

---
 v7/src/runtime/syntactic-closures.scm |  70 ++---
 v7/src/runtime/syntax-output.scm      | 386 +++++++++++++++++++++++++-
 2 files changed, 401 insertions(+), 55 deletions(-)

diff --git a/v7/src/runtime/syntactic-closures.scm b/v7/src/runtime/syntactic-closures.scm
index c9c77cb26..a1550a49e 100644
--- a/v7/src/runtime/syntactic-closures.scm
+++ b/v7/src/runtime/syntactic-closures.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: syntactic-closures.scm,v 14.7 2002/02/22 01:35:12 cph Exp $
+;;; $Id: syntactic-closures.scm,v 14.8 2002/03/01 05:43:21 cph Exp $
 ;;;
 ;;; Copyright (c) 1989-1991, 2001, 2002 Massachusetts Institute of Technology
 ;;;
@@ -45,19 +45,21 @@
   (if (not (list? forms))
       (error:wrong-type-argument forms "list" 'SYNTAX*))
   (guarantee-syntactic-environment environment 'SYNTAX*)
-  (fluid-let ((*rename-suffix* 0))
-    (if (syntactic-environment/top-level? environment)
-	(let ((environment (make-top-level-syntactic-environment environment)))
-	  (compile-body-items/top-level
-	   (classify/body-forms forms
-				environment
-				environment
-				(make-top-level-history forms environment)
-				select-object)))
-	(output/sequence
-	 (compile/expressions forms
-			      environment
-			      (make-top-level-history forms environment))))))
+  (fluid-let ((*rename-database* (initial-rename-database)))
+    (output/post-process-expression
+     (if (syntactic-environment/top-level? environment)
+	 (let ((environment
+		(make-top-level-syntactic-environment environment)))
+	   (compile-body-items/top-level
+	    (classify/body-forms forms
+				 environment
+				 environment
+				 (make-top-level-history forms environment)
+				 select-object)))
+	 (output/sequence
+	  (compile/expressions forms
+			       environment
+			       (make-top-level-history forms environment)))))))
 
 (define (compile-item/top-level item)
   (if (binding-item? item)
@@ -1152,7 +1154,7 @@
      (expander
       (lambda rest
 	(apply syntax-error history rest))))))
-
+
 (define (flatten-body-items items)
   (append-map item->list items))
 
@@ -1161,44 +1163,6 @@
       (flatten-body-items (body-item/components item))
       (list item)))
 
-(define *rename-suffix*)
-
-(define (make-rename-state)
-  (delay
-    (let ((n (+ *rename-suffix* 1)))
-      (set! *rename-suffix* n)
-      (number->string n))))
-
-(define (rename-identifier identifier state)
-  (if (interned-symbol? identifier)
-      (string->symbol
-       (string-append "."
-		      (symbol->string identifier)
-		      "."
-		      (force state)))
-      (intern
-       (string-append "."
-		      (symbol->string (identifier->symbol identifier))
-		      "."
-		      (number->string (hash identifier))
-		      "-"
-		      (force state)))))
-
-(define (make-name-generator)
-  (let ((state (make-rename-state)))
-    (lambda (identifier)
-      (rename-identifier identifier state))))
-
-(define (rename-top-level-identifier identifier)
-  (if (symbol? identifier)
-      identifier
-      (intern
-       (string-append "."
-		      (symbol->string (identifier->symbol identifier))
-		      "."
-		      (number->string (hash identifier))
-		      "-0"))))
-
 (define (reverse-syntactic-environments environment procedure)
   (capture-syntactic-environment
    (lambda (closing-environment)
diff --git a/v7/src/runtime/syntax-output.scm b/v7/src/runtime/syntax-output.scm
index 4741f860e..25d5bbcf7 100644
--- a/v7/src/runtime/syntax-output.scm
+++ b/v7/src/runtime/syntax-output.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: syntax-output.scm,v 14.2 2002/03/01 03:09:58 cph Exp $
+;;; $Id: syntax-output.scm,v 14.3 2002/03/01 05:43:26 cph Exp $
 ;;;
 ;;; Copyright (c) 1989-1991, 2001, 2002 Massachusetts Institute of Technology
 ;;;
@@ -282,4 +282,386 @@
 		     (cddr rule)
 		     (selector/add-cddr selector))))
 	   (cdr declaration)
-	   (selector/add-cdr selector)))))
\ No newline at end of file
+	   (selector/add-cdr selector)))))
+
+;;;; Identifiers
+
+(define *rename-database*)
+
+(define-structure (rename-database (constructor initial-rename-database ())
+				   (conc-name rename-database/))
+  (frame-number 0)
+  (mapping-table (make-eq-hash-table) read-only #t)
+  (unmapping-table (make-eq-hash-table) read-only #t)
+  (id-number 0)
+  (id-table (make-eq-hash-table) read-only #t))
+
+(define (make-rename-state)
+  (delay
+    (let ((n (+ (rename-database/frame-number *rename-database*) 1)))
+      (set-rename-database/frame-number! *rename-database* n)
+      n)))
+
+(define (rename-identifier identifier state)
+  (let ((mapped-identifier
+	 (string->uninterned-symbol
+	  (symbol-name (identifier->symbol identifier)))))
+    (hash-table/put! (rename-database/mapping-table *rename-database*)
+		     identifier
+		     mapped-identifier)
+    (hash-table/put! (rename-database/unmapping-table *rename-database*)
+		     mapped-identifier
+		     (cons identifier state))
+    mapped-identifier))
+
+(define (rename-top-level-identifier identifier)
+  (if (symbol? identifier)
+      identifier
+      (rename-identifier identifier (delay 0))))
+
+(define (make-name-generator)
+  (let ((state (make-rename-state)))
+    (lambda (identifier)
+      (rename-identifier identifier state))))
+
+;;; Post processing
+
+(define (output/post-process-expression expression)
+  (let ((unmapping (empty-unmapping)))
+    (compute-substitution expression unmapping)
+    (alpha-substitute (unmapping->substitution unmapping) expression)))
+
+(define (empty-unmapping)
+  (make-eq-hash-table))
+
+(define (store-unmapping-entry! identifier unmapped-identifier unmapping)
+  (hash-table/put! unmapping identifier unmapped-identifier))
+
+(define ((unmapping->substitution unmapping) identifier)
+  (or (hash-table/get unmapping identifier #f)
+      (finalize-mapped-identifier identifier)))
+
+(define (unmap-identifier identifier)
+  (let ((entry
+	 (hash-table/get (rename-database/unmapping-table *rename-database*)
+			 identifier
+			 #f)))
+    (if entry
+	(car entry)
+	(begin
+	  (if (not (symbol? identifier))
+	      (error:bad-range-argument identifier 'UNMAP-IDENTIFIER))
+	  identifier))))
+
+(define (finalize-mapped-identifier identifier)
+  (let ((entry
+	 (hash-table/get (rename-database/unmapping-table *rename-database*)
+			 identifier
+			 #f)))
+    (if entry
+	(finalize-mapped-identifier-1 (car entry) (force (cdr entry)))
+	(begin
+	  (if (not (symbol? identifier))
+	      (error:bad-range-argument identifier
+					'FINALIZE-MAPPED-IDENTIFIER))
+	  identifier))))
+
+(define (finalize-mapped-identifier-1 identifier frame-number)
+  (let ((table (rename-database/id-table *rename-database*)))
+    (let ((alist (hash-table/get table identifier '())))
+      (let ((entry (assv frame-number alist)))
+	(if entry
+	    (cdr entry)
+	    (let ((final-identifier
+		   (finalize-mapped-identifier-2 identifier frame-number)))
+	      (hash-table/put! table
+			       identifier
+			       (cons (cons frame-number final-identifier)
+				     alist))
+	      final-identifier))))))
+
+(define (finalize-mapped-identifier-2 identifier frame-number)
+  (if (interned-symbol? identifier)
+      (string->symbol
+       (string-append "."
+		      (symbol-name identifier)
+		      "."
+		      (number->string frame-number)))
+      (intern
+       (string-append "."
+		      (symbol-name (identifier->symbol identifier))
+		      "."
+		      (number->string (allocate-id-number))))))
+
+(define (allocate-id-number)
+  (let ((n (+ (rename-database/id-number *rename-database*) 1)))
+    (set-rename-database/id-number! *rename-database* n)
+    n))
+
+;;; Combinator deconstruction
+
+(define (combination-subexpressions expression)
+  (cons (combination-operator expression)
+	(combination-operands expression)))
+
+(define (conditional-subexpressions expression)
+  (list (conditional-predicate expression)
+	(conditional-consequent expression)
+	(conditional-alternative expression)))
+
+(define (disjunction-subexpressions expression)
+  (list (disjunction-predicate expression)
+	(disjunction-alternative expression)))
+
+;;;; Compute substitution
+
+(define (compute-substitution expression unmapping)
+  ((scode-walk compute-substitution-walker expression) expression unmapping))
+
+(define (compute-substitution/variable expression unmapping)
+  unmapping
+  (singleton-reference-set (variable-name expression)))
+
+(define (compute-substitution/assignment expression unmapping)
+  (add-to-reference-set (assignment-name expression)
+			(compute-substitution (assignment-value expression)
+					      unmapping)))
+
+(define (compute-substitution/lambda expression unmapping)
+  (lambda-components** expression
+    (lambda (pattern bound body)
+      pattern
+      (compute-substitution/binder bound body unmapping))))
+
+(define (compute-substitution/open-block expression unmapping)
+  (open-block-components expression
+    (lambda (bound declarations body)
+      declarations
+      (compute-substitution/binder bound body unmapping))))
+
+(define (compute-substitution/binder bound body unmapping)
+  (let ((free-references
+	 (remove-from-reference-set bound
+				    (compute-substitution body unmapping))))
+    (for-each (lambda (identifier)
+		(let ((unmapped-identifier (unmap-identifier identifier)))
+		  (if (not (unmapping-collision? identifier
+						 unmapped-identifier
+						 free-references))
+		      (store-unmapping-entry! identifier
+					      unmapped-identifier
+					      unmapping))))
+	      bound)
+    free-references))
+
+;;; Reference Set
+
+(define (null-reference-set)
+  '())
+
+(define (singleton-reference-set identifier)
+  (list (cons identifier (unmap-identifier identifier))))
+
+(define (reference-set-union s1 s2)
+  (if (pair? s1)
+      (if (assq (caar s1) s2)
+	  (reference-set-union (cdr s1) s2)
+	  (cons (car s1) (reference-set-union (cdr s1) s2)))
+      s2))
+
+(define (add-to-reference-set identifier reference-set)
+  (if (assq identifier reference-set)
+      reference-set
+      (cons (cons identifier (unmap-identifier identifier)) reference-set)))
+
+(define (remove-from-reference-set identifiers reference-set)
+  (delete-matching-items reference-set
+    (lambda (item)
+      (memq (car item) identifiers))))
+
+(define (unmapping-collision? identifier unmapped-identifier reference-set)
+  (find-matching-item reference-set
+    (lambda (item)
+      (and (eq? unmapped-identifier (cdr item))
+	   (not (eq? identifier (car item)))))))
+
+(define (compute-substitution/subexpression get-subexpression)
+  (lambda (expression unmapping)
+    (compute-substitution (get-subexpression expression) unmapping)))
+
+(define (compute-substitution/subexpressions get-subexpressions)
+  (lambda (expression unmapping)
+    (let ((expressions (get-subexpressions expression)))
+      (if (pair? expressions)
+	  (let loop ((expressions expressions))
+	    (if (pair? (cdr expressions))
+		(reference-set-union (compute-substitution (car expressions)
+							   unmapping)
+				     (loop (cdr expressions)))
+		(compute-substitution (car expressions) unmapping)))
+	  (null-reference-set)))))
+
+(define compute-substitution/access
+  (compute-substitution/subexpression access-environment))
+
+(define compute-substitution/combination
+  (compute-substitution/subexpressions combination-subexpressions))
+
+(define compute-substitution/comment
+  (compute-substitution/subexpression comment-expression))
+
+(define compute-substitution/conditional
+  (compute-substitution/subexpressions conditional-subexpressions))
+
+(define compute-substitution/definition
+  (compute-substitution/subexpression definition-value))
+
+(define compute-substitution/delay
+  (compute-substitution/subexpression delay-expression))
+
+(define compute-substitution/disjunction
+  (compute-substitution/subexpressions disjunction-subexpressions))
+
+(define compute-substitution/sequence
+  (compute-substitution/subexpressions sequence-actions))
+
+(define (compute-substitution/default expression unmapping)
+  expression unmapping
+  (null-reference-set))
+
+(define compute-substitution-walker
+  (make-scode-walker compute-substitution/default
+		     `((ACCESS ,compute-substitution/access)
+		       (ASSIGNMENT ,compute-substitution/assignment)
+		       (COMBINATION ,compute-substitution/combination)
+		       (COMMENT ,compute-substitution/comment)
+		       (CONDITIONAL ,compute-substitution/conditional)
+		       (DEFINITION ,compute-substitution/definition)
+		       (DELAY ,compute-substitution/delay)
+		       (DISJUNCTION ,compute-substitution/disjunction)
+		       (LAMBDA ,compute-substitution/lambda)
+		       (OPEN-BLOCK ,compute-substitution/open-block)
+		       (SEQUENCE ,compute-substitution/sequence)
+		       (VARIABLE ,compute-substitution/variable))))
+
+;;;; Alpha substitution
+
+(define (alpha-substitute substitution expression)
+  ((scode-walk alpha-substitute-walker expression) substitution expression))
+
+(define (alpha-substitute/variable substitution expression)
+  (make-variable (substitution (variable-name expression))))
+
+(define (alpha-substitute/assignment substitution expression)
+  (make-assignment (substitution (assignment-name expression))
+		   (alpha-substitute substitution
+				     (assignment-value expression))))
+
+(define (alpha-substitute/lambda substitution expression)
+  (lambda-components** expression
+    (lambda (pattern bound body)
+      (make-lambda** pattern
+		     (map substitution bound)
+		     (alpha-substitute substitution body)))))
+
+(define (alpha-substitute/open-block substitution expression)
+  (open-block-components expression
+    (lambda (bound declarations body)
+      (make-open-block (map substitution bound)
+		       (substitute-in-declarations substitution declarations)
+		       (alpha-substitute substitution body)))))
+
+(define (alpha-substitute/declaration substitution expression)
+  (make-declaration (substitute-in-declarations substitution
+						(declaration-text expression))
+		    (alpha-substitute substitution
+				      (declaration-expression expression))))
+
+(define (substitute-in-declarations substitution declarations)
+  (map (lambda (declaration)
+	 (process-declaration declaration select-object
+			      (lambda (identifier selector)
+				selector
+				(substitution identifier))
+			      (lambda (declaration selector)
+				selector
+				(error "Ill-formed declaration:"
+				       declaration))))
+       declarations))
+
+(define (alpha-substitute/default substitution expression)
+  substitution
+  expression)
+
+(define (simple-substitution reconstruct get-subexpression)
+  (lambda (substitution expression)
+    (reconstruct expression
+		 (alpha-substitute substitution
+				   (get-subexpression expression)))))
+
+(define (combinator-substitution reconstruct get-subexpressions)
+  (lambda (substitution expression)
+    (reconstruct
+     (map (lambda (expression)
+	    (alpha-substitute substitution expression))
+	  (get-subexpressions expression)))))
+
+(define alpha-substitute/access
+  (simple-substitution (lambda (expression environment)
+			 (make-access environment (access-name expression)))
+		       access-environment))
+
+(define alpha-substitute/combination
+  (combinator-substitution (lambda (subexpressions)
+			     (make-combination (car subexpressions)
+					       (cdr subexpressions)))
+			   combination-subexpressions))
+
+(define alpha-substitute/comment
+  (simple-substitution (lambda (expression subexpression)
+			 (make-comment (comment-text expression)
+				       subexpression))
+		       comment-expression))
+
+(define alpha-substitute/conditional
+  (combinator-substitution (lambda (subexpressions)
+			     (make-conditional (car subexpressions)
+					       (cadr subexpressions)
+					       (caddr subexpressions)))
+			   conditional-subexpressions))
+
+(define alpha-substitute/definition
+  (simple-substitution (lambda (expression value)
+			 (make-definition (definition-name expression) value))
+		       definition-value))
+
+(define alpha-substitute/delay
+  (simple-substitution (lambda (expression subexpression)
+			 expression
+			 (make-delay subexpression))
+		       delay-expression))
+
+(define alpha-substitute/disjunction
+  (combinator-substitution (lambda (subexpressions)
+			     (make-disjunction (car subexpressions)
+					       (cadr subexpressions)))
+			   disjunction-subexpressions))
+
+(define alpha-substitute/sequence
+  (combinator-substitution make-sequence sequence-actions))
+
+(define alpha-substitute-walker
+  (make-scode-walker alpha-substitute/default
+		     `((ACCESS ,alpha-substitute/access)
+		       (ASSIGNMENT ,alpha-substitute/assignment)
+		       (COMBINATION ,alpha-substitute/combination)
+		       (COMMENT ,alpha-substitute/comment)
+		       (CONDITIONAL ,alpha-substitute/conditional)
+		       (DECLARATION ,alpha-substitute/declaration)
+		       (DEFINITION ,alpha-substitute/definition)
+		       (DELAY ,alpha-substitute/delay)
+		       (DISJUNCTION ,alpha-substitute/disjunction)
+		       (LAMBDA ,alpha-substitute/lambda)
+		       (OPEN-BLOCK ,alpha-substitute/open-block)
+		       (SEQUENCE ,alpha-substitute/sequence)
+		       (VARIABLE ,alpha-substitute/variable))))
\ No newline at end of file
-- 
2.25.1