From 3d6b7545a98d3e53834979deb64a5a9dbae72aa0 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 25 Jan 2018 22:06:00 -0800 Subject: [PATCH] Split renaming mechanism out of syntax-output. --- src/runtime/make.scm | 2 +- src/runtime/runtime.pkg | 22 +- src/runtime/syntax-output.scm | 373 +----------------------------- src/runtime/syntax-rename.scm | 420 ++++++++++++++++++++++++++++++++++ 4 files changed, 435 insertions(+), 382 deletions(-) create mode 100644 src/runtime/syntax-rename.scm diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 943ccbd23..16fc336ba 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -531,7 +531,7 @@ USA. (RUNTIME PRETTY-PRINTER) (RUNTIME EXTENDED-SCODE-EVAL) (RUNTIME SYNTAX DEFINITIONS) - (RUNTIME SYNTAX OUTPUT) + (runtime syntax rename) ;; REP Loops (RUNTIME INTERRUPT-HANDLER) (RUNTIME GC-STATISTICS) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index f10a39505..2264f47d2 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4503,6 +4503,18 @@ USA. compile-item/expression define-item-compiler)) +(define-package (runtime syntax rename) + (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)) + (define-package (runtime syntax output) (files "syntax-output") (parent (runtime syntax)) @@ -4511,10 +4523,6 @@ USA. lambda-tag:let lambda-tag:unnamed) (export (runtime syntax) - *rename-database* - initial-rename-database - make-name-generator - make-rename-id output/access-assignment output/access-reference output/assignment @@ -4529,7 +4537,6 @@ USA. output/let output/letrec output/named-lambda - output/post-process-expression output/runtime-reference output/sequence output/the-environment @@ -4540,10 +4547,7 @@ USA. output/unassigned-test output/unspecific output/variable - rename-identifier - rename-top-level-identifier - transformer-eval) - (initialization (initialize-package!))) + transformer-eval)) (define-package (runtime syntax declaration) (files "syntax-declaration") diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm index 5c175af00..0cf48c549 100644 --- a/src/runtime/syntax-output.scm +++ b/src/runtime/syntax-output.scm @@ -155,375 +155,4 @@ USA. (define lambda-tag:unnamed '|#[unnamed-procedure]|) (define lambda-tag:let '|#[let-procedure]|) -(define lambda-tag:fluid-let '|#[fluid-let-procedure]|) - -;;;; Post processing - -(define (output/post-process-expression expression) - (let ((safe-set (make-strong-eq-hash-table))) - (compute-substitution expression - (lambda (rename original) - (hash-table/put! safe-set rename original))) - (alpha-substitute (unmapping->substitution safe-set) expression))) - -(define ((unmapping->substitution safe-set) rename) - (or (hash-table/get safe-set rename #f) - (finalize-mapped-identifier rename))) - -(define (mark-local-bindings bound body mark-safe!) - (let ((free - (lset-difference eq? - (compute-substitution body mark-safe!) - bound))) - (for-each (lambda (rename) - (let ((original (rename->original rename))) - (if (not (any (lambda (rename*) - (eq? original (rename->original rename*))) - free)) - (mark-safe! rename original)))) - bound) - free)) - -;;;; Compute substitution - -(define compute-substitution) -(add-boot-init! - (lambda () - (define (define-cs-handler predicate handler) - (define-predicate-dispatch-handler compute-substitution - (list predicate any-object?) - handler)) - - (define (simple-subexpression get-subexpression) - (lambda (expression mark-safe!) - (compute-substitution (get-subexpression expression) mark-safe!))) - - (define (simple-subexpressions get-subexpressions) - (lambda (expression mark-safe!) - (reduce (lambda (s1 s2) - (lset-union eq? s1 s2)) - '() - (map (lambda (expression) - (compute-substitution expression mark-safe!)) - (get-subexpressions expression))))) - - (set! compute-substitution - (standard-predicate-dispatcher 'compute-substitution 2)) - - (define-predicate-dispatch-default-handler compute-substitution - (lambda (expression mark-safe!) - (declare (ignore expression mark-safe!)) - '())) - - (define-cs-handler scode-variable? - (lambda (expression mark-safe!) - (declare (ignore mark-safe!)) - (list (scode-variable-name expression)))) - - (define-cs-handler scode-assignment? - (lambda (expression mark-safe!) - (lset-adjoin eq? - (compute-substitution (scode-assignment-value expression) - mark-safe!) - (scode-assignment-name expression)))) - - (define-cs-handler scode-unassigned?? - (lambda (expression mark-safe!) - (declare (ignore mark-safe!)) - (list (scode-unassigned?-name expression)))) - - (define-cs-handler scode-lambda? - (lambda (expression mark-safe!) - (lambda-components** expression - (lambda (pattern bound body) - (declare (ignore pattern)) - (mark-local-bindings bound body mark-safe!))))) - - (define-cs-handler scode-open-block? - (lambda (expression mark-safe!) - (mark-local-bindings (scode-open-block-names expression) - (scode-open-block-actions expression) - mark-safe!))) - - (define-cs-handler scode-access? - (simple-subexpression scode-access-environment)) - - (define-cs-handler scode-combination? - (simple-subexpressions - (lambda (expr) - (cons (scode-combination-operator expr) - (scode-combination-operands expr))))) - - (define-cs-handler scode-comment? - (simple-subexpression scode-comment-expression)) - - (define-cs-handler scode-conditional? - (simple-subexpressions - (lambda (expr) - (list (scode-conditional-predicate expr) - (scode-conditional-consequent expr) - (scode-conditional-alternative expr))))) - - (define-cs-handler scode-definition? - (simple-subexpression scode-definition-value)) - - (define-cs-handler scode-delay? - (simple-subexpression scode-delay-expression)) - - (define-cs-handler scode-disjunction? - (simple-subexpressions - (lambda (expr) - (list (scode-disjunction-predicate expr) - (scode-disjunction-alternative expr))))) - - (define-cs-handler scode-sequence? - (simple-subexpressions scode-sequence-actions)) - - )) - -;;;; Alpha substitution - -(define alpha-substitute) -(add-boot-init! - (lambda () - - (define (define-as-handler predicate handler) - (define-predicate-dispatch-handler alpha-substitute - (list any-object? predicate) - handler)) - - (define (simple-substitution reconstruct . parts) - (lambda (substitution expression) - (apply reconstruct - (map (lambda (part) - (alpha-substitute substitution (part expression))) - parts)))) - - (define (partial-substitution selector reconstruct . parts) - (lambda (substitution expression) - (apply reconstruct - (map (lambda (substitute? part) - (if substitute? - (alpha-substitute substitution (part expression)) - (part expression))) - selector - parts)))) - - (define (combinator-substitution reconstruct get-subexpressions) - (lambda (substitution expression) - (reconstruct - (map (lambda (expression) - (alpha-substitute substitution expression)) - (get-subexpressions expression))))) - - (set! alpha-substitute - (standard-predicate-dispatcher 'alpha-substitute 2)) - - (define-predicate-dispatch-default-handler alpha-substitute - (lambda (substitution expression) - (declare (ignore substitution)) - expression)) - - (define-as-handler scode-variable? - (lambda (substitution expression) - (make-scode-variable (substitution (scode-variable-name expression))))) - - (define-as-handler scode-assignment? - (lambda (substitution expression) - (make-scode-assignment - (substitution (scode-assignment-name expression)) - (alpha-substitute substitution (scode-assignment-value expression))))) - - (define-as-handler scode-unassigned?? - (lambda (substitution expression) - (make-scode-unassigned? - (substitution (scode-unassigned?-name expression))))) - - (define-as-handler scode-lambda? - (lambda (substitution expression) - (lambda-components** expression - (lambda (pattern bound body) - (make-lambda** pattern - (map substitution bound) - (alpha-substitute substitution body)))))) - - (define-as-handler scode-open-block? - (lambda (substitution expression) - (make-scode-open-block - (map substitution (scode-open-block-names expression)) - (map (lambda (declaration) - (map-declaration-identifiers substitution declaration)) - (scode-open-block-declarations expression)) - (alpha-substitute substitution (scode-open-block-actions expression))))) - - (define-as-handler scode-declaration? - (lambda (substitution expression) - (make-scode-declaration - (map (lambda (declaration) - (map-declaration-identifiers substitution declaration)) - (scode-declaration-text expression)) - (alpha-substitute substitution - (scode-declaration-expression expression))))) - - (define-as-handler scode-access? - (partial-substitution '(#t #f) - make-scode-access - scode-access-environment - scode-access-name)) - - (define-as-handler scode-combination? - (combinator-substitution - (lambda (subexpressions) - (make-scode-combination (car subexpressions) (cdr subexpressions))) - (lambda (expression) - (cons (scode-combination-operator expression) - (scode-combination-operands expression))))) - - (define-as-handler scode-comment? - (partial-substitution '(#f #t) - make-scode-comment - scode-comment-text - scode-comment-expression)) - - (define-as-handler scode-conditional? - (simple-substitution make-scode-conditional - scode-conditional-predicate - scode-conditional-consequent - scode-conditional-alternative)) - - (define-as-handler scode-definition? - (partial-substitution '(#f #t) - make-scode-definition - scode-definition-name - scode-definition-value)) - - (define-as-handler scode-delay? - (simple-substitution make-scode-delay - scode-delay-expression)) - - (define-as-handler scode-disjunction? - (simple-substitution make-scode-disjunction - scode-disjunction-predicate - scode-disjunction-alternative)) - - (define-as-handler scode-sequence? - (combinator-substitution make-scode-sequence scode-sequence-actions)) - - )) - -;;;; Identifiers - -(define-deferred *rename-database* - (make-unsettable-parameter 'UNBOUND)) - -(define-structure (rename-database (constructor initial-rename-database ()) - (conc-name rename-database/)) - (frame-number 0) - (mapping-table (make-equal-hash-table) read-only #t) - (unmapping-table (make-strong-eq-hash-table) read-only #t) - (id-table (make-strong-eq-hash-table) read-only #t)) - -(define (make-rename-id) - (delay - (let* ((renames (*rename-database*)) - (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*))) - (let ((mapping-table (rename-database/mapping-table renames))) - (or (hash-table/get mapping-table key #f) - (let ((mapped-identifier - (string->uninterned-symbol - (symbol->string (identifier->symbol identifier))))) - (hash-table/put! mapping-table key mapped-identifier) - (hash-table/put! (rename-database/unmapping-table renames) - mapped-identifier - key) - mapped-identifier))))) - -(define (rename-top-level-identifier identifier) - (if (symbol? identifier) - identifier - ;; Generate an uninterned symbol here and now, rather than - ;; storing anything in the rename database, because we are - ;; creating a top-level binding for a synthetic name, which must - ;; be globally unique. Using the rename database causes the - ;; substitution logic above to try to use an interned symbol - ;; with a nicer name. The decorations on this name are just - ;; that -- decorations, for human legibility. It is the use of - ;; an uninterned symbol that guarantees uniqueness. - (string->uninterned-symbol - (string-append "." - (symbol->string (identifier->symbol identifier)) - "." - (number->string (force (make-rename-id))))))) - -(define (make-name-generator) - (let ((id (make-rename-id))) - (lambda (identifier) - (rename-identifier identifier id)))) - -(define (rename->original identifier) - (let ((entry - (hash-table/get (rename-database/unmapping-table - (*rename-database*)) - identifier - #f))) - (if entry - (identifier->symbol (car entry)) - (begin - (if (not (symbol? identifier)) - (error:bad-range-argument identifier 'RENAME->ORIGINAL)) - identifier)))) - -(define (finalize-mapped-identifier identifier) - (let ((entry - (hash-table/get (rename-database/unmapping-table - (*rename-database*)) - identifier - #f))) - (if entry - (let ((identifier (car entry)) - (frame-number (force (cdr entry)))) - (if (interned-symbol? identifier) - (map-interned-symbol identifier frame-number) - (map-uninterned-identifier identifier frame-number))) - (begin - (if (not (symbol? identifier)) - (error:bad-range-argument identifier - 'FINALIZE-MAPPED-IDENTIFIER)) - identifier)))) - -(define (map-interned-symbol symbol-to-map frame-number) - (symbol "." symbol-to-map "." frame-number)) - -(define (map-uninterned-identifier identifier frame-number) - (let ((table (rename-database/id-table (*rename-database*))) - (symbol (identifier->symbol identifier))) - (let ((alist (hash-table/get table symbol '()))) - (let ((entry (assv frame-number alist))) - (if entry - (let ((entry* (assq identifier (cdr entry)))) - (if entry* - (cdr entry*) - (let ((mapped-symbol - (map-indexed-symbol symbol - frame-number - (length (cdr entry))))) - (set-cdr! entry - (cons (cons identifier mapped-symbol) - (cdr entry))) - mapped-symbol))) - (let ((mapped-symbol (map-indexed-symbol symbol frame-number 0))) - (hash-table/put! table - symbol - (cons (list frame-number - (cons identifier mapped-symbol)) - alist)) - mapped-symbol)))))) - -(define (map-indexed-symbol symbol-to-map frame-number index-number) - (symbol "." symbol-to-map "." frame-number "-" index-number)) \ No newline at end of file +(define lambda-tag:fluid-let '|#[fluid-let-procedure]|) \ No newline at end of file diff --git a/src/runtime/syntax-rename.scm b/src/runtime/syntax-rename.scm new file mode 100644 index 000000000..64df110b9 --- /dev/null +++ b/src/runtime/syntax-rename.scm @@ -0,0 +1,420 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Syntaxer variable renaming +;;; package: (runtime syntax rename) + +;;; The classifier replaces each locally-bound identifier with a +;;; freshly-generated rename, and binds the identifier to a variable item whose +;;; name is the rename. Since each syntactic environment has its own renamer, +;;; this means that an identifier's rename is governed by what environment it is +;;; closed in. +;;; +;;; Top-level identifiers are never renamed. +;;; +;;; After code generation, in which the program's local-variable identifiers +;;; have all been renamed, there is a post-pass that looks at each of the +;;; locally-bound identifiers to determine whether it is safe to restore it to +;;; its original name. For each bound identifier in a given frame, we determine +;;; whether it can be restored to its original name by looking for name +;;; collisions. A name collision occurs when one of the bound identifiers has +;;; an original name that is the same as the original name of one of the free +;;; identifiers. If there are no name collisions, then it is safe to restore +;;; the original name. Otherwise the bound identifier is replaced by an +;;; interned symbol with a computed name that's designed to be unique. + +(declare (usual-integrations)) + +;;;; Post processing + +(define (output/post-process-expression expression) + (let ((safe-set (make-strong-eq-hash-table))) + (compute-substitution expression + (lambda (rename original) + (hash-table/put! safe-set rename original))) + (alpha-substitute (unmapping->substitution safe-set) expression))) + +(define ((unmapping->substitution safe-set) rename) + (or (hash-table/get safe-set rename #f) + (finalize-mapped-identifier rename))) + +(define (mark-local-bindings bound body mark-safe!) + (let ((free + (lset-difference eq? + (compute-substitution body mark-safe!) + bound))) + (for-each (lambda (rename) + (let ((original (rename->original rename))) + (if (not (any (lambda (rename*) + (eq? original (rename->original rename*))) + free)) + (mark-safe! rename original)))) + bound) + free)) + +;;;; Compute substitution + +(define compute-substitution) +(add-boot-init! + (lambda () + (define (define-cs-handler predicate handler) + (define-predicate-dispatch-handler compute-substitution + (list predicate any-object?) + handler)) + + (define (simple-subexpression get-subexpression) + (lambda (expression mark-safe!) + (compute-substitution (get-subexpression expression) mark-safe!))) + + (define (simple-subexpressions get-subexpressions) + (lambda (expression mark-safe!) + (reduce (lambda (s1 s2) + (lset-union eq? s1 s2)) + '() + (map (lambda (expression) + (compute-substitution expression mark-safe!)) + (get-subexpressions expression))))) + + (set! compute-substitution + (standard-predicate-dispatcher 'compute-substitution 2)) + + (define-predicate-dispatch-default-handler compute-substitution + (lambda (expression mark-safe!) + (declare (ignore expression mark-safe!)) + '())) + + (define-cs-handler scode-variable? + (lambda (expression mark-safe!) + (declare (ignore mark-safe!)) + (list (scode-variable-name expression)))) + + (define-cs-handler scode-assignment? + (lambda (expression mark-safe!) + (lset-adjoin eq? + (compute-substitution (scode-assignment-value expression) + mark-safe!) + (scode-assignment-name expression)))) + + (define-cs-handler scode-unassigned?? + (lambda (expression mark-safe!) + (declare (ignore mark-safe!)) + (list (scode-unassigned?-name expression)))) + + (define-cs-handler scode-lambda? + (lambda (expression mark-safe!) + (lambda-components** expression + (lambda (pattern bound body) + (declare (ignore pattern)) + (mark-local-bindings bound body mark-safe!))))) + + (define-cs-handler scode-open-block? + (lambda (expression mark-safe!) + (mark-local-bindings (scode-open-block-names expression) + (scode-open-block-actions expression) + mark-safe!))) + + (define-cs-handler scode-access? + (simple-subexpression scode-access-environment)) + + (define-cs-handler scode-combination? + (simple-subexpressions + (lambda (expr) + (cons (scode-combination-operator expr) + (scode-combination-operands expr))))) + + (define-cs-handler scode-comment? + (simple-subexpression scode-comment-expression)) + + (define-cs-handler scode-conditional? + (simple-subexpressions + (lambda (expr) + (list (scode-conditional-predicate expr) + (scode-conditional-consequent expr) + (scode-conditional-alternative expr))))) + + (define-cs-handler scode-definition? + (simple-subexpression scode-definition-value)) + + (define-cs-handler scode-delay? + (simple-subexpression scode-delay-expression)) + + (define-cs-handler scode-disjunction? + (simple-subexpressions + (lambda (expr) + (list (scode-disjunction-predicate expr) + (scode-disjunction-alternative expr))))) + + (define-cs-handler scode-sequence? + (simple-subexpressions scode-sequence-actions)) + + )) + +;;;; Alpha substitution + +(define alpha-substitute) +(add-boot-init! + (lambda () + + (define (define-as-handler predicate handler) + (define-predicate-dispatch-handler alpha-substitute + (list any-object? predicate) + handler)) + + (define (simple-substitution reconstruct . parts) + (lambda (substitution expression) + (apply reconstruct + (map (lambda (part) + (alpha-substitute substitution (part expression))) + parts)))) + + (define (partial-substitution selector reconstruct . parts) + (lambda (substitution expression) + (apply reconstruct + (map (lambda (substitute? part) + (if substitute? + (alpha-substitute substitution (part expression)) + (part expression))) + selector + parts)))) + + (define (combinator-substitution reconstruct get-subexpressions) + (lambda (substitution expression) + (reconstruct + (map (lambda (expression) + (alpha-substitute substitution expression)) + (get-subexpressions expression))))) + + (set! alpha-substitute + (standard-predicate-dispatcher 'alpha-substitute 2)) + + (define-predicate-dispatch-default-handler alpha-substitute + (lambda (substitution expression) + (declare (ignore substitution)) + expression)) + + (define-as-handler scode-variable? + (lambda (substitution expression) + (make-scode-variable (substitution (scode-variable-name expression))))) + + (define-as-handler scode-assignment? + (lambda (substitution expression) + (make-scode-assignment + (substitution (scode-assignment-name expression)) + (alpha-substitute substitution (scode-assignment-value expression))))) + + (define-as-handler scode-unassigned?? + (lambda (substitution expression) + (make-scode-unassigned? + (substitution (scode-unassigned?-name expression))))) + + (define-as-handler scode-lambda? + (lambda (substitution expression) + (lambda-components** expression + (lambda (pattern bound body) + (make-lambda** pattern + (map substitution bound) + (alpha-substitute substitution body)))))) + + (define-as-handler scode-open-block? + (lambda (substitution expression) + (make-scode-open-block + (map substitution (scode-open-block-names expression)) + (map (lambda (declaration) + (map-declaration-identifiers substitution declaration)) + (scode-open-block-declarations expression)) + (alpha-substitute substitution (scode-open-block-actions expression))))) + + (define-as-handler scode-declaration? + (lambda (substitution expression) + (make-scode-declaration + (map (lambda (declaration) + (map-declaration-identifiers substitution declaration)) + (scode-declaration-text expression)) + (alpha-substitute substitution + (scode-declaration-expression expression))))) + + (define-as-handler scode-access? + (partial-substitution '(#t #f) + make-scode-access + scode-access-environment + scode-access-name)) + + (define-as-handler scode-combination? + (combinator-substitution + (lambda (subexpressions) + (make-scode-combination (car subexpressions) (cdr subexpressions))) + (lambda (expression) + (cons (scode-combination-operator expression) + (scode-combination-operands expression))))) + + (define-as-handler scode-comment? + (partial-substitution '(#f #t) + make-scode-comment + scode-comment-text + scode-comment-expression)) + + (define-as-handler scode-conditional? + (simple-substitution make-scode-conditional + scode-conditional-predicate + scode-conditional-consequent + scode-conditional-alternative)) + + (define-as-handler scode-definition? + (partial-substitution '(#f #t) + make-scode-definition + scode-definition-name + scode-definition-value)) + + (define-as-handler scode-delay? + (simple-substitution make-scode-delay + scode-delay-expression)) + + (define-as-handler scode-disjunction? + (simple-substitution make-scode-disjunction + scode-disjunction-predicate + scode-disjunction-alternative)) + + (define-as-handler scode-sequence? + (combinator-substitution make-scode-sequence scode-sequence-actions)) + + )) + +;;;; Identifiers + +(define-deferred *rename-database* + (make-unsettable-parameter 'UNBOUND)) + +(define-structure (rename-database (constructor initial-rename-database ()) + (conc-name rename-database/)) + (frame-number 0) + (mapping-table (make-equal-hash-table) read-only #t) + (unmapping-table (make-strong-eq-hash-table) read-only #t) + (id-table (make-strong-eq-hash-table) read-only #t)) + +(define (make-rename-id) + (delay + (let* ((renames (*rename-database*)) + (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*))) + (let ((mapping-table (rename-database/mapping-table renames))) + (or (hash-table/get mapping-table key #f) + (let ((mapped-identifier + (string->uninterned-symbol + (symbol->string (identifier->symbol identifier))))) + (hash-table/put! mapping-table key mapped-identifier) + (hash-table/put! (rename-database/unmapping-table renames) + mapped-identifier + key) + mapped-identifier))))) + +(define (rename-top-level-identifier identifier) + (if (symbol? identifier) + identifier + ;; Generate an uninterned symbol here and now, rather than + ;; storing anything in the rename database, because we are + ;; creating a top-level binding for a synthetic name, which must + ;; be globally unique. Using the rename database causes the + ;; substitution logic above to try to use an interned symbol + ;; with a nicer name. The decorations on this name are just + ;; that -- decorations, for human legibility. It is the use of + ;; an uninterned symbol that guarantees uniqueness. + (string->uninterned-symbol + (string-append "." + (symbol->string (identifier->symbol identifier)) + "." + (number->string (force (make-rename-id))))))) + +(define (make-name-generator) + (let ((id (make-rename-id))) + (lambda (identifier) + (rename-identifier identifier id)))) + +(define (rename->original identifier) + (let ((entry + (hash-table/get (rename-database/unmapping-table + (*rename-database*)) + identifier + #f))) + (if entry + (identifier->symbol (car entry)) + (begin + (if (not (symbol? identifier)) + (error:bad-range-argument identifier 'RENAME->ORIGINAL)) + identifier)))) + +(define (finalize-mapped-identifier identifier) + (let ((entry + (hash-table/get (rename-database/unmapping-table + (*rename-database*)) + identifier + #f))) + (if entry + (let ((identifier (car entry)) + (frame-number (force (cdr entry)))) + (if (interned-symbol? identifier) + (map-interned-symbol identifier frame-number) + (map-uninterned-identifier identifier frame-number))) + (begin + (if (not (symbol? identifier)) + (error:bad-range-argument identifier + 'FINALIZE-MAPPED-IDENTIFIER)) + identifier)))) + +(define (map-interned-symbol symbol-to-map frame-number) + (symbol "." symbol-to-map "." frame-number)) + +(define (map-uninterned-identifier identifier frame-number) + (let ((table (rename-database/id-table (*rename-database*))) + (symbol (identifier->symbol identifier))) + (let ((alist (hash-table/get table symbol '()))) + (let ((entry (assv frame-number alist))) + (if entry + (let ((entry* (assq identifier (cdr entry)))) + (if entry* + (cdr entry*) + (let ((mapped-symbol + (map-indexed-symbol symbol + frame-number + (length (cdr entry))))) + (set-cdr! entry + (cons (cons identifier mapped-symbol) + (cdr entry))) + mapped-symbol))) + (let ((mapped-symbol (map-indexed-symbol symbol frame-number 0))) + (hash-table/put! table + symbol + (cons (list frame-number + (cons identifier mapped-symbol)) + alist)) + mapped-symbol)))))) + +(define (map-indexed-symbol symbol-to-map frame-number index-number) + (symbol "." symbol-to-map "." frame-number "-" index-number)) \ No newline at end of file -- 2.25.1