From 5d5e4f399a38e530a5f0081d6fdec80d3eb4736a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 21 Sep 2011 08:44:19 +0200 Subject: [PATCH] more robust alpha-renaming * module/language/tree-il/optimize.scm (fresh-gensyms): New helper. (alpha-rename): Name the new gensyms using the old names as templates, not the old gensyms. This prevents accidental collisions between gensyms, if #{x 1}# becomes #{x 12}# instead of #{x 2}#. --- module/language/tree-il/optimize.scm | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 43cea5e76..3c3cb01ca 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -46,6 +46,10 @@ ;;; Partial evaluation. ;;; +(define (fresh-gensyms syms) + (map (lambda (x) (gensym (string-append (symbol->string x) " "))) + syms)) + (define (alpha-rename exp) "Alpha-rename EXP. For any lambda in EXP, generate new symbols and replace all lexical references to the former symbols with lexical @@ -57,7 +61,11 @@ references to the new symbols." (($ src req opt rest kw inits gensyms body alt) ;; Create new symbols to replace GENSYMS and propagate them down ;; in BODY and ALT. - (let* ((new (map (compose gensym symbol->string) gensyms)) + (let* ((new (fresh-gensyms + (append req + (or opt '()) + (if rest (list rest) '()) + (if kw (map cadr (cdr kw)) '())))) (mapping (fold vhash-consq mapping gensyms new))) (make-lambda-case src req opt rest kw inits new (loop body mapping) @@ -72,14 +80,14 @@ references to the new symbols." (make-lambda src meta (loop body mapping))) (($ src names gensyms vals body) ;; As for `lambda-case' rename GENSYMS to avoid any collision. - (let* ((new (map (compose gensym symbol->string) gensyms)) + (let* ((new (fresh-gensyms names)) (mapping (fold vhash-consq mapping gensyms new)) (vals (map (cut loop <> mapping) vals)) (body (loop body mapping))) (make-let src names new vals body))) (($ src in-order? names gensyms vals body) ;; Likewise. - (let* ((new (map (compose gensym symbol->string) gensyms)) + (let* ((new (fresh-gensyms names)) (mapping (fold vhash-consq mapping gensyms new)) (vals (map (cut loop <> mapping) vals)) (body (loop body mapping)))