From 59c9d234e9f90bb211d6ef06993cba1753f95470 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 25 Jan 2018 20:56:45 -0800 Subject: [PATCH] Refactor the syntax-output codewalkers to use predicate dispatchers. --- src/runtime/syntax-output.scm | 546 ++++++++++++++++------------------ 1 file changed, 252 insertions(+), 294 deletions(-) diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm index b06c90e0b..fdb91cd19 100644 --- a/src/runtime/syntax-output.scm +++ b/src/runtime/syntax-output.scm @@ -159,275 +159,264 @@ USA. ;;;; 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-strong-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))) + (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 expression unmapping) - ((scode-walk compute-substitution-walker expression) expression unmapping)) - -(define (compute-substitution/variable expression unmapping) - unmapping - (singleton-reference-set (scode-variable-name expression))) - -(define (compute-substitution/assignment expression unmapping) - (add-to-reference-set - (scode-assignment-name expression) - (compute-substitution (scode-assignment-value expression) - unmapping))) - -(define (compute-substitution/unassigned? expression unmapping) - unmapping - (singleton-reference-set (scode-unassigned?-name expression))) - -(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)))) - (let loop - ((identifiers bound) - (unmapped (map unmap-identifier bound))) - (if (pair? identifiers) - (begin - (if (not (or (unmapping-collision? (car identifiers) - (car unmapped) - free-references) - (memq (car unmapped) (cdr unmapped)))) - (store-unmapping-entry! (car identifiers) - (car unmapped) - unmapping)) - (loop (cdr identifiers) (cdr unmapped))))) - free-references)) - -(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 scode-access-environment)) - -(define compute-substitution/combination - (compute-substitution/subexpressions - (lambda (expr) - (cons (scode-combination-operator expr) - (scode-combination-operands expr))))) - -(define compute-substitution/comment - (compute-substitution/subexpression scode-comment-expression)) - -(define compute-substitution/conditional - (compute-substitution/subexpressions - (lambda (expr) - (list (scode-conditional-predicate expr) - (scode-conditional-consequent expr) - (scode-conditional-alternative expr))))) - -(define compute-substitution/definition - (compute-substitution/subexpression scode-definition-value)) - -(define compute-substitution/delay - (compute-substitution/subexpression scode-delay-expression)) - -(define compute-substitution/disjunction - (compute-substitution/subexpressions - (lambda (expr) - (list (scode-disjunction-predicate expr) - (scode-disjunction-alternative expr))))) - -(define compute-substitution/sequence - (compute-substitution/subexpressions scode-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) - (UNASSIGNED? ,compute-substitution/unassigned?) - (VARIABLE ,compute-substitution/variable)))) +(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 open-block? + (lambda (expression mark-safe!) + (open-block-components expression + (lambda (bound declarations body) + (declare (ignore declarations)) + (mark-local-bindings bound body 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 substitution expression) - ((scode-walk alpha-substitute-walker expression) substitution expression)) - -(define (alpha-substitute/variable substitution expression) - (make-scode-variable (substitution (scode-variable-name expression)))) - -(define (alpha-substitute/assignment substitution expression) - (make-scode-assignment - (substitution (scode-assignment-name expression)) - (alpha-substitute substitution (scode-assignment-value expression)))) - -(define (alpha-substitute/unassigned? substitution expression) - (make-scode-unassigned? (substitution (scode-unassigned?-name 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-scode-declaration - (substitute-in-declarations substitution (scode-declaration-text expression)) - (alpha-substitute substitution (scode-declaration-expression expression)))) - -(define (substitute-in-declarations substitution declarations) - (map (lambda (declaration) - (map-declaration-identifiers substitution declaration)) - declarations)) - -(define (alpha-substitute/default substitution expression) - substitution - expression) - -(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))))) - -(define alpha-substitute/access - (partial-substitution '(#t #f) - make-scode-access - scode-access-environment - scode-access-name)) - -(define alpha-substitute/combination - (combinator-substitution (lambda (subexpressions) - (make-scode-combination (car subexpressions) - (cdr subexpressions))) - (lambda (expression) - (cons (scode-combination-operator expression) - (scode-combination-operands expression))))) - -(define alpha-substitute/comment - (partial-substitution '(#f #t) - make-scode-comment - scode-comment-text - scode-comment-expression)) - -(define alpha-substitute/conditional - (simple-substitution make-scode-conditional - scode-conditional-predicate - scode-conditional-consequent - scode-conditional-alternative)) - -(define alpha-substitute/definition - (partial-substitution '(#f #t) - make-scode-definition - scode-definition-name - scode-definition-value)) - -(define alpha-substitute/delay - (simple-substitution make-scode-delay - scode-delay-expression)) - -(define alpha-substitute/disjunction - (simple-substitution make-scode-disjunction - scode-disjunction-predicate - scode-disjunction-alternative)) - -(define alpha-substitute/sequence - (combinator-substitution make-scode-sequence scode-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) - (UNASSIGNED? ,alpha-substitute/unassigned?) - (VARIABLE ,alpha-substitute/variable)))) +(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 open-block? + (lambda (substitution expression) + (open-block-components expression + (lambda (bound declarations body) + (make-open-block (map substitution bound) + (map (lambda (declaration) + (map-declaration-identifiers substitution + declaration)) + declarations) + (alpha-substitute substitution body)))))) + + (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 *rename-database*) - -(define (initialize-package!) - (set! *rename-database* (make-unsettable-parameter 'UNBOUND))) +(define-deferred *rename-database* + (make-unsettable-parameter 'UNBOUND)) (define-structure (rename-database (constructor initial-rename-database ()) (conc-name rename-database/)) @@ -479,7 +468,7 @@ USA. (lambda (identifier) (rename-identifier identifier id)))) -(define (unmap-identifier identifier) +(define (rename->original identifier) (let ((entry (hash-table/get (rename-database/unmapping-table (*rename-database*)) @@ -489,7 +478,7 @@ USA. (identifier->symbol (car entry)) (begin (if (not (symbol? identifier)) - (error:bad-range-argument identifier 'UNMAP-IDENTIFIER)) + (error:bad-range-argument identifier 'RENAME->ORIGINAL)) identifier)))) (define (finalize-mapped-identifier identifier) @@ -539,35 +528,4 @@ USA. mapped-symbol)))))) (define (map-indexed-symbol symbol-to-map frame-number index-number) - (symbol "." symbol-to-map "." frame-number "-" index-number)) - -;;;; 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))))))) \ No newline at end of file + (symbol "." symbol-to-map "." frame-number "-" index-number)) \ No newline at end of file -- 2.25.1