From: Chris Hanson Date: Fri, 1 Mar 2002 05:43:26 +0000 (+0000) Subject: Rewrite renaming code to allocate temporary uninterned symbols during X-Git-Tag: 20090517-FFI~2211 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=69809844c4d83ff6cef5208d17c7a8f6e98bec8e;p=mit-scheme.git 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 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