mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

more robust alpha-renaming

Browse source 
* 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}#.
This commit is contained in:
Andy Wingo 2011-09-21 08:44:19 +02:00
parent 4f33b47591
commit 5d5e4f399a
1 changed files with 11 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

14
module/language/tree-il/optimize.scm
View file

@ -46,6 +46,10 @@
;;; Partial evaluation. ;;; Partial evaluation.
;;; ;;;
(define (fresh-gensyms syms)
(map (lambda (x) (gensym (string-append (symbol->string x) " ")))
syms))
(define (alpha-rename exp) (define (alpha-rename exp)
"Alpha-rename EXP. For any lambda in EXP, generate new symbols and "Alpha-rename EXP. For any lambda in EXP, generate new symbols and
replace all lexical references to the former symbols with lexical replace all lexical references to the former symbols with lexical
@ -57,7 +61,11 @@ references to the new symbols."
(($ <lambda-case> src req opt rest kw inits gensyms body alt) (($ <lambda-case> src req opt rest kw inits gensyms body alt)
;; Create new symbols to replace GENSYMS and propagate them down ;; Create new symbols to replace GENSYMS and propagate them down
;; in BODY and ALT. ;; 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))) (mapping (fold vhash-consq mapping gensyms new)))
(make-lambda-case src req opt rest kw inits new (make-lambda-case src req opt rest kw inits new
(loop body mapping) (loop body mapping)
@ -72,14 +80,14 @@ references to the new symbols."
(make-lambda src meta (loop body mapping))) (make-lambda src meta (loop body mapping)))
(($ <let> src names gensyms vals body) (($ <let> src names gensyms vals body)
;; As for `lambda-case' rename GENSYMS to avoid any collision. ;; 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)) (mapping (fold vhash-consq mapping gensyms new))
(vals (map (cut loop <> mapping) vals)) (vals (map (cut loop <> mapping) vals))
(body (loop body mapping))) (body (loop body mapping)))
(make-let src names new vals body))) (make-let src names new vals body)))
(($ <letrec> src in-order? names gensyms vals body) (($ <letrec> src in-order? names gensyms vals body)
;; Likewise. ;; Likewise.
(let* ((new (map (compose gensym symbol->string) gensyms)) (let* ((new (fresh-gensyms names))
(mapping (fold vhash-consq mapping gensyms new)) (mapping (fold vhash-consq mapping gensyms new))
(vals (map (cut loop <> mapping) vals)) (vals (map (cut loop <> mapping) vals))
(body (loop body mapping))) (body (loop body mapping)))