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.

diff --git a/v7/src/runtime/syntactic-closures.scm b/v7/src/runtime/syntactic-closures.scm
index c9c77cb26486a0cc8f51ec8e4668d0313a4b4415..a1550a49e273332f966e187e74c161d1c1623328 100644 (file)
--- 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))))))
-\f
+
 (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 4741f860e051f43331ee67a6e886354eb118dfd9..25d5bbcf7f130b7853f4f2e481868b3fbb546f17 100644 (file)
--- 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)))))
+\f
+;;;; 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))))
+\f
+(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)))
+\f
+;;;; 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)))))))
+\f
+(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))))
+\f
+;;;; 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)))))
+\f
+(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