summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-05-02 11:22:23 +0200
committerAndy Wingo <wingo@pobox.com>2010-05-02 11:22:23 +0200
commit93f63467e6e9d2f0203fd1c54a98539f5fefeba0 (patch)
tree759c50cfebaf6a64f48167e2ad7bd7f11e730c44
parent915aca30baccaf646752d84f11d4e461ca24391a (diff)
downloadguile-93f63467e6e9d2f0203fd1c54a98539f5fefeba0.tar.gz
rename `vars' field in tree-il binding constructs to `gensyms'
* module/language/tree-il.scm (<tree-il>): Rename `vars' fields of <let>, <letrec>, <fix>, and <lambda-case> to `gensyms'. For clarity, and to match <lexical-ref>. * module/language/tree-il.scm: * module/language/tree-il/analyze.scm: * module/language/tree-il/compile-glil.scm: * module/language/tree-il/fix-letrec.scm: * module/language/tree-il/inline.scm: Update all callers.
-rw-r--r--module/language/tree-il.scm74
-rw-r--r--module/language/tree-il/analyze.scm150
-rw-r--r--module/language/tree-il/compile-glil.scm92
-rw-r--r--module/language/tree-il/fix-letrec.scm80
-rw-r--r--module/language/tree-il/inline.scm36
5 files changed, 216 insertions, 216 deletions
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 8daf49a19..bec3bec92 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -39,11 +39,11 @@
<lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
<lambda-case> lambda-case? make-lambda-case lambda-case-src
lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw
- lambda-case-inits lambda-case-vars
+ lambda-case-inits lambda-case-gensyms
lambda-case-body lambda-case-alternate
- <let> let? make-let let-src let-names let-vars let-vals let-body
- <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body
- <fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body
+ <let> let? make-let let-src let-names let-gensyms let-vals let-body
+ <letrec> letrec? make-letrec letrec-src letrec-names letrec-gensyms letrec-vals letrec-body
+ <fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
<let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
<dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder
<dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
@@ -76,10 +76,10 @@
(<application> proc args)
(<sequence> exps)
(<lambda> meta body)
- (<lambda-case> req opt rest kw inits vars body alternate)
- (<let> names vars vals body)
- (<letrec> names vars vals body)
- (<fix> names vars vals body)
+ (<lambda-case> req opt rest kw inits gensyms body alternate)
+ (<let> names gensyms vals body)
+ (<letrec> names gensyms vals body)
+ (<fix> names gensyms vals body)
(<let-values> exp body)
(<dynwind> winder body unwinder)
(<dynlet> fluids vals body)
@@ -147,15 +147,15 @@
((lambda ,meta ,body)
(make-lambda loc meta (retrans body)))
- ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body) ,alternate)
+ ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body) ,alternate)
(make-lambda-case loc req opt rest kw
- (map retrans inits) vars
+ (map retrans inits) gensyms
(retrans body)
(and=> alternate retrans)))
- ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body))
+ ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body))
(make-lambda-case loc req opt rest kw
- (map retrans inits) vars
+ (map retrans inits) gensyms
(retrans body)
#f))
@@ -165,14 +165,14 @@
((begin . ,exps)
(make-sequence loc (map retrans exps)))
- ((let ,names ,vars ,vals ,body)
- (make-let loc names vars (map retrans vals) (retrans body)))
+ ((let ,names ,gensyms ,vals ,body)
+ (make-let loc names gensyms (map retrans vals) (retrans body)))
- ((letrec ,names ,vars ,vals ,body)
- (make-letrec loc names vars (map retrans vals) (retrans body)))
+ ((letrec ,names ,gensyms ,vals ,body)
+ (make-letrec loc names gensyms (map retrans vals) (retrans body)))
- ((fix ,names ,vars ,vals ,body)
- (make-fix loc names vars (map retrans vals) (retrans body)))
+ ((fix ,names ,gensyms ,vals ,body)
+ (make-fix loc names gensyms (map retrans vals) (retrans body)))
((let-values ,exp ,body)
(make-let-values loc (retrans exp) (retrans body)))
@@ -236,8 +236,8 @@
((<lambda> meta body)
`(lambda ,meta ,(unparse-tree-il body)))
- ((<lambda-case> req opt rest kw inits vars body alternate)
- `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,vars)
+ ((<lambda-case> req opt rest kw inits gensyms body alternate)
+ `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms)
,(unparse-tree-il body))
. ,(if alternate (list (unparse-tree-il alternate)) '())))
@@ -247,14 +247,14 @@
((<sequence> exps)
`(begin ,@(map unparse-tree-il exps)))
- ((<let> names vars vals body)
- `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+ ((<let> names gensyms vals body)
+ `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
- ((<letrec> names vars vals body)
- `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+ ((<letrec> names gensyms vals body)
+ `(letrec ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
- ((<fix> names vars vals body)
- `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+ ((<fix> names gensyms vals body)
+ `(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
((<let-values> exp body)
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
@@ -324,9 +324,9 @@
`(lambda ,@(car (tree-il->scheme body)))
`(case-lambda ,@(tree-il->scheme body))))
- ((<lambda-case> req opt rest kw inits vars body alternate)
+ ((<lambda-case> req opt rest kw inits gensyms body alternate)
;; FIXME! use parse-lambda-case?
- `((,(if rest (apply cons* vars) vars)
+ `((,(if rest (apply cons* gensyms) gensyms)
,(tree-il->scheme body))
,@(if alternate (tree-il->scheme alternate) '())))
@@ -338,15 +338,15 @@
((<sequence> exps)
`(begin ,@(map tree-il->scheme exps)))
- ((<let> vars vals body)
- `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
+ ((<let> gensyms vals body)
+ `(let ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
- ((<letrec> vars vals body)
- `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
+ ((<letrec> gensyms vals body)
+ `(letrec ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
- ((<fix> vars vals body)
+ ((<fix> gensyms vals body)
;; not a typo, we really do translate back to letrec
- `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
+ `(letrec ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
((<let-values> exp body)
`(call-with-values (lambda () ,(tree-il->scheme exp))
@@ -564,15 +564,15 @@ This is an implementation of `foldts' as described by Andy Wingo in
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
- ((<let> vars vals body)
+ ((<let> gensyms vals body)
(set! (let-vals x) (map lp vals))
(set! (let-body x) (lp body)))
- ((<letrec> vars vals body)
+ ((<letrec> gensyms vals body)
(set! (letrec-vals x) (map lp vals))
(set! (letrec-body x) (lp body)))
- ((<fix> vars vals body)
+ ((<fix> gensyms vals body)
(set! (fix-vals x) (map lp vals))
(set! (fix-body x) (lp body)))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index bc56a7d77..0bf6b9c75 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -235,39 +235,39 @@
(hashq-set! free-vars x free)
free))
- ((<lambda-case> opt kw inits vars body alternate)
+ ((<lambda-case> opt kw inits gensyms body alternate)
(hashq-set! bound-vars proc
- (append (reverse vars) (hashq-ref bound-vars proc)))
+ (append (reverse gensyms) (hashq-ref bound-vars proc)))
(lset-union
eq?
(lset-difference eq?
(lset-union eq?
(apply lset-union eq? (map step inits))
(step-tail body))
- vars)
+ gensyms)
(if alternate (step-tail alternate) '())))
- ((<let> vars vals body)
+ ((<let> gensyms vals body)
(hashq-set! bound-vars proc
- (append (reverse vars) (hashq-ref bound-vars proc)))
+ (append (reverse gensyms) (hashq-ref bound-vars proc)))
(lset-difference eq?
(apply lset-union eq? (step-tail body) (map step vals))
- vars))
+ gensyms))
- ((<letrec> vars vals body)
+ ((<letrec> gensyms vals body)
(hashq-set! bound-vars proc
- (append (reverse vars) (hashq-ref bound-vars proc)))
- (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars)
+ (append (reverse gensyms) (hashq-ref bound-vars proc)))
+ (for-each (lambda (sym) (hashq-set! assigned sym #t)) gensyms)
(lset-difference eq?
(apply lset-union eq? (step-tail body) (map step vals))
- vars))
+ gensyms))
- ((<fix> vars vals body)
+ ((<fix> gensyms vals body)
;; Try to allocate these procedures as labels.
(for-each (lambda (sym val) (hashq-set! labels sym val))
- vars vals)
+ gensyms vals)
(hashq-set! bound-vars proc
- (append (reverse vars) (hashq-ref bound-vars proc)))
+ (append (reverse gensyms) (hashq-ref bound-vars proc)))
;; Step into subexpressions.
(let* ((var-refs
(map
@@ -282,13 +282,13 @@
;; just like the closure case, except here we use
;; recur/labels instead of recur
(hashq-set! bound-vars x '())
- (let ((free (recur/labels body x vars)))
+ (let ((free (recur/labels body x gensyms)))
(hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
(hashq-set! free-vars x free)
free))))
vals))
- (vars-with-refs (map cons vars var-refs))
- (body-refs (recur/labels body proc vars)))
+ (vars-with-refs (map cons gensyms var-refs))
+ (body-refs (recur/labels body proc gensyms)))
(define (delabel-dependents! sym)
(let ((refs (assq-ref vars-with-refs sym)))
(if refs
@@ -314,7 +314,7 @@
(for-each (lambda (sym)
(if (not (hashq-ref labels sym))
(delabel-dependents! sym)))
- vars)
+ gensyms)
;; Now lift bound variables with label-allocated lambdas to the
;; parent procedure.
(for-each
@@ -328,10 +328,10 @@
(hashq-ref bound-vars proc)))
(hashq-remove! bound-vars val)
(hashq-remove! free-vars val))))
- vars vals)
+ gensyms vals)
(lset-difference eq?
(apply lset-union eq? body-refs var-refs)
- vars)))
+ gensyms)))
((<let-values> exp body)
(lset-union eq? (step exp) (step body)))
@@ -407,10 +407,10 @@
(hashq-set! allocation x (cons labels free-addresses)))
n)
- ((<lambda-case> opt kw inits vars body alternate)
+ ((<lambda-case> opt kw inits gensyms body alternate)
(max
- (let lp ((vars vars) (n n))
- (if (null? vars)
+ (let lp ((gensyms gensyms) (n n))
+ (if (null? gensyms)
(let ((nlocs (apply
max
(allocate! body proc n)
@@ -421,72 +421,72 @@
(hashq-set! allocation x (cons (gensym ":LCASE") nlocs))
nlocs)
(begin
- (hashq-set! allocation (car vars)
+ (hashq-set! allocation (car gensyms)
(make-hashq
- proc `(#t ,(hashq-ref assigned (car vars)) . ,n)))
- (lp (cdr vars) (1+ n)))))
+ proc `(#t ,(hashq-ref assigned (car gensyms)) . ,n)))
+ (lp (cdr gensyms) (1+ n)))))
(if alternate (allocate! alternate proc n) n)))
- ((<let> vars vals body)
+ ((<let> gensyms vals body)
(let ((nmax (apply max (map recur vals))))
(cond
;; the `or' hack
((and (conditional? body)
- (= (length vars) 1)
- (let ((v (car vars)))
+ (= (length gensyms) 1)
+ (let ((v (car gensyms)))
(and (not (hashq-ref assigned v))
(= (hashq-ref refcounts v 0) 2)
(lexical-ref? (conditional-test body))
(eq? (lexical-ref-gensym (conditional-test body)) v)
(lexical-ref? (conditional-consequent body))
(eq? (lexical-ref-gensym (conditional-consequent body)) v))))
- (hashq-set! allocation (car vars)
+ (hashq-set! allocation (car gensyms)
(make-hashq proc `(#t #f . ,n)))
;; the 1+ for this var
(max nmax (1+ n) (allocate! (conditional-alternate body) proc n)))
(else
- (let lp ((vars vars) (n n))
- (if (null? vars)
+ (let lp ((gensyms gensyms) (n n))
+ (if (null? gensyms)
(max nmax (allocate! body proc n))
- (let ((v (car vars)))
+ (let ((v (car gensyms)))
(hashq-set!
allocation v
(make-hashq proc
`(#t ,(hashq-ref assigned v) . ,n)))
- (lp (cdr vars) (1+ n)))))))))
+ (lp (cdr gensyms) (1+ n)))))))))
- ((<letrec> vars vals body)
- (let lp ((vars vars) (n n))
- (if (null? vars)
+ ((<letrec> gensyms vals body)
+ (let lp ((gensyms gensyms) (n n))
+ (if (null? gensyms)
(let ((nmax (apply max
(map (lambda (x)
(allocate! x proc n))
vals))))
(max nmax (allocate! body proc n)))
- (let ((v (car vars)))
+ (let ((v (car gensyms)))
(hashq-set!
allocation v
(make-hashq proc
`(#t ,(hashq-ref assigned v) . ,n)))
- (lp (cdr vars) (1+ n))))))
+ (lp (cdr gensyms) (1+ n))))))
- ((<fix> vars vals body)
- (let lp ((in vars) (n n))
+ ((<fix> gensyms vals body)
+ (let lp ((in gensyms) (n n))
(if (null? in)
- (let lp ((vars vars) (vals vals) (nmax n))
+ (let lp ((gensyms gensyms) (vals vals) (nmax n))
(cond
- ((null? vars)
+ ((null? gensyms)
(max nmax (allocate! body proc n)))
- ((hashq-ref labels (car vars))
+ ((hashq-ref labels (car gensyms))
;; allocate lambda body inline to proc
- (lp (cdr vars)
+ (lp (cdr gensyms)
(cdr vals)
(record-case (car vals)
((<lambda> body)
(max nmax (allocate! body proc n))))))
(else
;; allocate closure
- (lp (cdr vars)
+ (lp (cdr gensyms)
(cdr vals)
(max nmax (allocate! (car vals) proc n))))))
@@ -519,8 +519,8 @@
((<prompt> tag body handler)
(let ((cont-var (and (lambda-case? handler)
- (pair? (lambda-case-vars handler))
- (car (lambda-case-vars handler)))))
+ (pair? (lambda-case-gensyms handler))
+ (car (lambda-case-gensyms handler)))))
(hashq-set! allocation x
(and cont-var (zero? (hashq-ref refcounts cont-var 0))))
(max (recur tag) (recur body) (recur handler))))
@@ -629,18 +629,18 @@ accurate information is missing from a given `tree-il' element."
(record-case x
((<lexical-set> gensym)
(make-binding-info vars (vhash-consq gensym #t refs)))
- ((<lambda-case> req opt inits rest kw vars)
+ ((<lambda-case> req opt inits rest kw gensyms)
(let ((names `(,@req
,@(or opt '())
,@(if rest (list rest) '())
,@(if kw (map cadr (cdr kw)) '()))))
- (make-binding-info (extend vars names) refs)))
- ((<let> vars names)
- (make-binding-info (extend vars names) refs))
- ((<letrec> vars names)
- (make-binding-info (extend vars names) refs))
- ((<fix> vars names)
- (make-binding-info (extend vars names) refs))
+ (make-binding-info (extend gensyms names) refs)))
+ ((<let> gensyms names)
+ (make-binding-info (extend gensyms names) refs))
+ ((<letrec> gensyms names)
+ (make-binding-info (extend gensyms names) refs))
+ ((<fix> gensyms names)
+ (make-binding-info (extend gensyms names) refs))
(else info))))
(lambda (x info env locs)
@@ -670,14 +670,14 @@ accurate information is missing from a given `tree-il' element."
;; It doesn't hurt as these are unique names, it just
;; makes REFS unnecessarily fat.
(record-case x
- ((<lambda-case> vars)
- (make-binding-info (shrink vars refs) refs))
- ((<let> vars)
- (make-binding-info (shrink vars refs) refs))
- ((<letrec> vars)
- (make-binding-info (shrink vars refs) refs))
- ((<fix> vars)
- (make-binding-info (shrink vars refs) refs))
+ ((<lambda-case> gensyms)
+ (make-binding-info (shrink gensyms refs) refs))
+ ((<let> gensyms)
+ (make-binding-info (shrink gensyms refs) refs))
+ ((<letrec> gensyms)
+ (make-binding-info (shrink gensyms refs) refs))
+ ((<fix> gensyms)
+ (make-binding-info (shrink gensyms refs) refs))
(else info))))
(lambda (result env) #t)
@@ -1106,12 +1106,12 @@ accurate information is missing from a given `tree-il' element."
exp)
toplevel-lambdas))))
(else info)))
- ((<let> vars vals)
- (fold extend info vars vals))
- ((<letrec> vars vals)
- (fold extend info vars vals))
- ((<fix> vars vals)
- (fold extend info vars vals))
+ ((<let> gensyms vals)
+ (fold extend info gensyms vals))
+ ((<letrec> gensyms vals)
+ (fold extend info gensyms vals))
+ ((<fix> gensyms vals)
+ (fold extend info gensyms vals))
((<application> proc args src)
(record-case proc
@@ -1158,12 +1158,12 @@ accurate information is missing from a given `tree-il' element."
(lexical-lambdas (lexical-lambdas info))
(toplevel-lambdas (toplevel-lambdas info)))
(record-case x
- ((<let> vars vals)
- (fold shrink info vars vals))
- ((<letrec> vars vals)
- (fold shrink info vars vals))
- ((<fix> vars vals)
- (fold shrink info vars vals))
+ ((<let> gensyms vals)
+ (fold shrink info gensyms vals))
+ ((<letrec> gensyms vals)
+ (fold shrink info gensyms vals))
+ ((<fix> gensyms vals)
+ (fold shrink info gensyms vals))
(else info))))
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index a07ad669f..10b06b8d8 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -428,7 +428,7 @@
;; new box
(emit-code #f (make-glil-lexical #t #t 'box index)))
(,x (error "what" x))))
- (reverse (lambda-case-vars lcase)))
+ (reverse (lambda-case-gensyms lcase)))
(emit-branch src 'br (car (hashq-ref allocation lcase))))
((lambda-case? lcase)
;; no match, try next case
@@ -465,7 +465,7 @@
((#t #t . ,index) ; boxed
(emit-code #f (make-glil-lexical #t #t 'box index)))
(,x (error "what" x))))
- (reverse (lambda-case-vars lcase)))
+ (reverse (lambda-case-gensyms lcase)))
(emit-branch src 'br (car (hashq-ref allocation lcase))))
((lambda-case? lcase)
;; no match, try next case
@@ -669,15 +669,15 @@
(length free-locs))))))))
(maybe-emit-return))
- ((<lambda-case> src req opt rest kw inits vars alternate body)
+ ((<lambda-case> src req opt rest kw inits gensyms alternate body)
;; o/~ feature on top of feature o/~
;; req := (name ...)
;; opt := (name ...) | #f
;; rest := name | #f
;; kw: (allow-other-keys? (keyword name var) ...) | #f
- ;; vars: (sym ...)
- ;; init: tree-il in context of vars
- ;; vars map to named arguments in the following order:
+ ;; gensyms: (sym ...)
+ ;; init: tree-il in context of gensyms
+ ;; gensyms map to named arguments in the following order:
;; required, optional (positional), rest, keyword.
(let* ((nreq (length req))
(nopt (if opt (length opt) 0))
@@ -687,7 +687,7 @@
(kw-indices (map (lambda (x)
(pmatch x
((,key ,name ,var)
- (cons key (list-index vars var)))
+ (cons key (list-index gensyms var)))
(else (error "bad kwarg" x))))
(if kw (cdr kw) '())))
(nargs (apply max (+ nreq nopt (if rest 1 0))
@@ -695,10 +695,10 @@
(nlocs (cdr (hashq-ref allocation x)))
(alternate-label (and alternate (make-label))))
(or (= nargs
- (length vars)
+ (length gensyms)
(+ nreq (length inits) (if rest 1 0)))
(error "something went wrong"
- req opt rest kw inits vars nreq nopt kw-indices nargs))
+ req opt rest kw inits gensyms nreq nopt kw-indices nargs))
;; the prelude, to check args & reset the stack pointer,
;; allowing room for locals
(emit-code
@@ -718,33 +718,33 @@
((#t #t . ,n)
(emit-code #f (make-glil-lexical #t #f 'ref n))
(emit-code #f (make-glil-lexical #t #t 'box n)))))
- vars)
+ gensyms)
;; write bindings info
- (if (not (null? vars))
+ (if (not (null? gensyms))
(emit-bindings
#f
(let lp ((kw (if kw (cdr kw) '()))
(names (append (reverse opt-names) (reverse req)))
- (vars (list-tail vars (+ nreq nopt
+ (gensyms (list-tail gensyms (+ nreq nopt
(if rest 1 0)))))
(pmatch kw
(()
- ;; fixme: check that vars is empty
+ ;; fixme: check that gensyms is empty
(reverse (if rest (cons rest names) names)))
(((,key ,name ,var) . ,kw)
- (if (memq var vars)
- (lp kw (cons name names) (delq var vars))
- (lp kw names vars)))
+ (if (memq var gensyms)
+ (lp kw (cons name names) (delq var gensyms))
+ (lp kw names gensyms)))
(,kw (error "bad keywords, yo" kw))))
- vars allocation self emit-code))
+ gensyms allocation self emit-code))
;; init optional/kw args
- (let lp ((inits inits) (n nreq) (vars (list-tail vars nreq)))
+ (let lp ((inits inits) (n nreq) (gensyms (list-tail gensyms nreq)))
(cond
((null? inits)) ; done
((and rest-idx (= n rest-idx))
- (lp inits (1+ n) (cdr vars)))
+ (lp inits (1+ n) (cdr gensyms)))
(#t
- (pmatch (hashq-ref (hashq-ref allocation (car vars)) self)
+ (pmatch (hashq-ref (hashq-ref allocation (car gensyms)) self)
((#t ,boxed? . ,n*) (guard (= n* n))
(let ((L (make-label)))
(emit-code #f (make-glil-lexical #t boxed? 'bound? n))
@@ -752,21 +752,21 @@
(comp-push (car inits))
(emit-code #f (make-glil-lexical #t boxed? 'set n))
(emit-label L)
- (lp (cdr inits) (1+ n) (cdr vars))))
+ (lp (cdr inits) (1+ n) (cdr gensyms))))
(#t (error "what" inits))))))
;; post-prelude case label for label calls
(emit-label (car (hashq-ref allocation x)))
(comp-tail body)
- (if (not (null? vars))
+ (if (not (null? gensyms))
(emit-code #f (make-glil-unbind)))
(if alternate-label
(begin
(emit-label alternate-label)
(comp-tail alternate)))))
- ((<let> src names vars vals body)
+ ((<let> src names gensyms vals body)
(for-each comp-push vals)
- (emit-bindings src names vars allocation self emit-code)
+ (emit-bindings src names gensyms allocation self emit-code)
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n)
@@ -774,29 +774,29 @@
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'box n)))
(,loc (error "badness" x loc))))
- (reverse vars))
+ (reverse gensyms))
(comp-tail body)
(emit-code #f (make-glil-unbind)))
- ((<letrec> src names vars vals body)
+ ((<letrec> src names gensyms vals body)
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'empty-box n)))
(,loc (error "badness" x loc))))
- vars)
+ gensyms)
(for-each comp-push vals)
- (emit-bindings src names vars allocation self emit-code)
+ (emit-bindings src names gensyms allocation self emit-code)
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'set n)))
(,loc (error "badness" x loc))))
- (reverse vars))
+ (reverse gensyms))
(comp-tail body)
(emit-code #f (make-glil-unbind)))
- ((<fix> src names vars vals body)
+ ((<fix> src names gensyms vals body)
;; The ideal here is to just render the lambda bodies inline, and
;; wire the code together with gotos. We can do that if
;; analyze-lexicals has determined that a given var has "label"
@@ -835,10 +835,10 @@
(let lp ((lcase (lambda-body x)))
(if lcase
(record-case lcase
- ((<lambda-case> src req vars body alternate)
+ ((<lambda-case> src req gensyms body alternate)
(emit-label (car (hashq-ref allocation lcase)))
;; FIXME: opt & kw args in the bindings
- (emit-bindings #f req vars allocation self emit-code)
+ (emit-bindings #f req gensyms allocation self emit-code)
(if src
(emit-code #f (make-glil-source src)))
(comp-fix body (or RA new-RA))
@@ -846,15 +846,15 @@
(lp alternate)))
(emit-label POST)))))))
vals
- vars)
+ gensyms)
;; Emit bindings metadata for closures
- (let ((binds (let lp ((out '()) (vars vars) (names names))
- (cond ((null? vars) (reverse! out))
- ((assq (car vars) fix-labels)
- (lp out (cdr vars) (cdr names)))
+ (let ((binds (let lp ((out '()) (gensyms gensyms) (names names))
+ (cond ((null? gensyms) (reverse! out))
+ ((assq (car gensyms) fix-labels)
+ (lp out (cdr gensyms) (cdr names)))
(else
- (lp (acons (car vars) (car names) out)
- (cdr vars) (cdr names)))))))
+ (lp (acons (car gensyms) (car names) out)
+ (cdr gensyms) (cdr names)))))))
(emit-bindings src (map cdr binds) (map car binds)
allocation self emit-code))
;; Now go back and fix up the bindings for closures.
@@ -878,7 +878,7 @@
(emit-code #f (make-glil-lexical #t #f 'fix n)))
(,loc (error "badness" x loc)))))))
vals
- vars)
+ gensyms)
(comp-tail body)
(if new-RA
(emit-label new-RA))
@@ -886,7 +886,7 @@
((<let-values> src exp body)
(record-case body
- ((<lambda-case> req opt kw rest vars body alternate)
+ ((<lambda-case> req opt kw rest gensyms body alternate)
(if (or opt kw alternate)
(error "unexpected lambda-case in let-values" x))
(let ((MV (make-label)))
@@ -896,7 +896,7 @@
(emit-code src (make-glil-mv-bind
(vars->bind-list
(append req (if rest (list rest) '()))
- vars allocation self)
+ gensyms allocation self)
(and rest #t)))
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self)
@@ -905,7 +905,7 @@
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'box n)))
(,loc (error "badness" x loc))))
- (reverse vars))
+ (reverse gensyms))
(comp-tail body)
(emit-code #f (make-glil-unbind))))))
@@ -1086,13 +1086,13 @@
;; then the args to the continuation (pushed separately), and then the
;; number of args, including the continuation.
(record-case handler
- ((<lambda-case> req opt kw rest vars body alternate)
+ ((<lambda-case> req opt kw rest gensyms body alternate)
(if (or opt kw alternate)
(error "unexpected lambda-case in prompt" x))
(emit-code src (make-glil-mv-bind
(vars->bind-list
(append req (if rest (list rest) '()))
- vars allocation self)
+ gensyms allocation self)
(and rest #t)))
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self)
@@ -1101,7 +1101,7 @@
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'box n)))
(,loc (error "badness" x loc))))
- (reverse vars))
+ (reverse gensyms))
(comp-tail body)
(emit-code #f (make-glil-unbind))))
diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm
index bef31ce8c..e849e694b 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -1,6 +1,6 @@
;;; transformation of letrec into simpler forms
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -71,15 +71,15 @@
simple
lambda*
complex))
- ((<letrec> vars)
- (values (append vars unref)
+ ((<letrec> gensyms)
+ (values (append gensyms unref)
ref
set
simple
lambda*
complex))
- ((<let> vars)
- (values (append vars unref)
+ ((<let> gensyms)
+ (values (append gensyms unref)
ref
set
simple
@@ -89,65 +89,65 @@
(values unref ref set simple lambda* complex))))
(lambda (x unref ref set simple lambda* complex)
(record-case x
- ((<letrec> (orig-vars vars) vals)
- (let lp ((vars orig-vars) (vals vals)
+ ((<letrec> (orig-gensyms gensyms) vals)
+ (let lp ((gensyms orig-gensyms) (vals vals)
(s '()) (l '()) (c '()))
(cond
- ((null? vars)
+ ((null? gensyms)
(values unref
ref
set
(append s simple)
(append l lambda*)
(append c complex)))
- ((memq (car vars) unref)
- (lp (cdr vars) (cdr vals)
+ ((memq (car gensyms) unref)
+ (lp (cdr gensyms) (cdr vals)
s l c))
- ((memq (car vars) set)
- (lp (cdr vars) (cdr vals)
- s l (cons (car vars) c)))
+ ((memq (car gensyms) set)
+ (lp (cdr gensyms) (cdr vals)
+ s l (cons (car gensyms) c)))
((lambda? (car vals))
- (lp (cdr vars) (cdr vals)
- s (cons (car vars) l) c))
- ((simple-expression? (car vals) orig-vars)
- (lp (cdr vars) (cdr vals)
- (cons (car vars) s) l c))
+ (lp (cdr gensyms) (cdr vals)
+ s (cons (car gensyms) l) c))
+ ((simple-expression? (car vals) orig-gensyms)
+ (lp (cdr gensyms) (cdr vals)
+ (cons (car gensyms) s) l c))
(else
- (lp (cdr vars) (cdr vals)
- s l (cons (car vars) c))))))
- ((<let> (orig-vars vars) vals)
+ (lp (cdr gensyms) (cdr vals)
+ s l (cons (car gensyms) c))))))
+ ((<let> (orig-gensyms gensyms) vals)
;; The point is to compile let-bound lambdas as
;; efficiently as we do letrec-bound lambdas, so
;; we use the same algorithm for analyzing the
- ;; vars. There is no problem recursing into the
+ ;; gensyms. There is no problem recursing into the
;; bindings after the let, because all variables
;; have been renamed.
- (let lp ((vars orig-vars) (vals vals)
+ (let lp ((gensyms orig-gensyms) (vals vals)
(s '()) (l '()) (c '()))
(cond
- ((null? vars)
+ ((null? gensyms)
(values unref
ref
set
(append s simple)
(append l lambda*)
(append c complex)))
- ((memq (car vars) unref)
- (lp (cdr vars) (cdr vals)
+ ((memq (car gensyms) unref)
+ (lp (cdr gensyms) (cdr vals)
s l c))
- ((memq (car vars) set)
- (lp (cdr vars) (cdr vals)
- s l (cons (car vars) c)))
+ ((memq (car gensyms) set)
+ (lp (cdr gensyms) (cdr vals)
+ s l (cons (car gensyms) c)))
((and (lambda? (car vals))
- (not (memq (car vars) set)))
- (lp (cdr vars) (cdr vals)
- s (cons (car vars) l) c))
+ (not (memq (car gensyms) set)))
+ (lp (cdr gensyms) (cdr vals)
+ s (cons (car gensyms) l) c))
;; There is no difference between simple and
;; complex, for the purposes of let. Just lump
;; them all into complex.
(else
- (lp (cdr vars) (cdr vals)
- s l (cons (car vars) c))))))
+ (lp (cdr gensyms) (cdr vals)
+ s l (cons (car gensyms) c))))))
(else
(values unref ref set simple lambda* complex))))
'()
@@ -171,11 +171,11 @@
(make-sequence #f (list exp (make-void #f)))
x))
- ((<letrec> src names vars vals body)
- (let ((binds (map list vars names vals)))
+ ((<letrec> src names gensyms vals body)
+ (let ((binds (map list gensyms names vals)))
(define (lookup set)
(map (lambda (v) (assq v binds))
- (lset-intersection eq? vars set)))
+ (lset-intersection eq? gensyms set)))
(let ((u (lookup unref))
(s (lookup simple))
(l (lookup lambda*))
@@ -216,11 +216,11 @@
;; Finally, the body.
body)))))))))
- ((<let> src names vars vals body)
- (let ((binds (map list vars names vals)))
+ ((<let> src names gensyms vals body)
+ (let ((binds (map list gensyms names vals)))
(define (lookup set)
(map (lambda (v) (assq v binds))
- (lset-intersection eq? vars set)))
+ (lset-intersection eq? gensyms set)))
(let ((u (lookup unref))
(l (lookup lambda*))
(c (lookup complex)))
diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm
index 8dd7dd334..706072940 100644
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -44,9 +44,9 @@
(let lp ((lcase body))
(and lcase
(record-case lcase
- ((<lambda-case> req opt rest kw inits vars body alternate)
- (if (and (= (length vars) (length req) (length args)))
- (let ((x (make-let src req vars args body)))
+ ((<lambda-case> req opt rest kw inits gensyms body alternate)
+ (if (and (= (length gensyms) (length req) (length args)))
+ (let ((x (make-let src req gensyms args body)))
(or (inline1 x) x))
(lp alternate)))))))
@@ -101,24 +101,24 @@
(else #f)))
- ((<let> vars body)
- (if (null? vars) body x))
+ ((<let> gensyms body)
+ (if (null? gensyms) body x))
- ((<letrec> vars body)
- (if (null? vars) body x))
+ ((<letrec> gensyms body)
+ (if (null? gensyms) body x))
- ((<fix> vars body)
- (if (null? vars) body x))
+ ((<fix> gensyms body)
+ (if (null? gensyms) body x))
- ((<lambda-case> req opt rest kw vars body alternate)
- (define (args-compatible? args vars)
- (let lp ((args args) (vars vars))
+ ((<lambda-case> req opt rest kw gensyms body alternate)
+ (define (args-compatible? args gensyms)
+ (let lp ((args args) (gensyms gensyms))
(cond
- ((null? args) (null? vars))
- ((null? vars) #f)
+ ((null? args) (null? gensyms))
+ ((null? gensyms) #f)
((and (lexical-ref? (car args))
- (eq? (lexical-ref-gensym (car args)) (car vars)))
- (lp (cdr args) (cdr vars)))
+ (eq? (lexical-ref-gensym (car args)) (car gensyms)))
+ (lp (cdr args) (cdr gensyms)))
(else #f))))
(and (not opt) (not kw) rest (not alternate)
@@ -129,7 +129,7 @@
(eq? (primitive-ref-name proc) '@apply)
(pair? args)
(lambda? (car args))
- (args-compatible? (cdr args) vars)
+ (args-compatible? (cdr args) gensyms)
(lambda-body (car args))))
(else #f))))
@@ -138,7 +138,7 @@
((<prompt> src tag body handler)
(define (escape-only? handler)
(and (pair? (lambda-case-req handler))
- (let ((cont (car (lambda-case-vars handler))))
+ (let ((cont (car (lambda-case-gensyms handler))))
(tree-il-fold (lambda (leaf escape-only?)
(and escape-only?
(not