summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/tree-il.scm40
-rw-r--r--module/language/tree-il/analyze.scm14
-rw-r--r--module/language/tree-il/compile-glil.scm28
-rw-r--r--module/language/tree-il/inline.scm6
4 files changed, 44 insertions, 44 deletions
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index db9b467ff..a2ba03b5b 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -40,7 +40,7 @@
<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-body lambda-case-else
+ 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
@@ -70,7 +70,7 @@
(<application> proc args)
(<sequence> exps)
(<lambda> meta body)
- (<lambda-case> req opt rest kw inits vars body else)
+ (<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)
@@ -135,11 +135,11 @@
((lambda ,meta ,body)
(make-lambda loc meta (retrans body)))
- ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body) ,else)
+ ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body) ,alternate)
(make-lambda-case loc req opt rest kw
(map retrans inits) vars
(retrans body)
- (and=> else retrans)))
+ (and=> alternate retrans)))
((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body))
(make-lambda-case loc req opt rest kw
@@ -206,10 +206,10 @@
((<lambda> meta body)
`(lambda ,meta ,(unparse-tree-il body)))
- ((<lambda-case> req opt rest kw inits vars body else)
+ ((<lambda-case> req opt rest kw inits vars body alternate)
`(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,vars)
,(unparse-tree-il body))
- . ,(if else (list (unparse-tree-il else)) '())))
+ . ,(if alternate (list (unparse-tree-il alternate)) '())))
((<const> exp)
`(const ,exp))
@@ -269,15 +269,15 @@
((<lambda> meta body)
;; fixme: put in docstring
(if (and (lambda-case? body)
- (not (lambda-case-else body)))
+ (not (lambda-case-alternate body)))
`(lambda ,@(car (tree-il->scheme body)))
`(case-lambda ,@(tree-il->scheme body))))
- ((<lambda-case> req opt rest kw inits vars body else)
+ ((<lambda-case> req opt rest kw inits vars body alternate)
;; FIXME! use parse-lambda-case?
`((,(if rest (apply cons* vars) vars)
,(tree-il->scheme body))
- ,@(if else (tree-il->scheme else) '())))
+ ,@(if alternate (tree-il->scheme alternate) '())))
((<const> exp)
(if (and (self-evaluating? exp) (not (vector? exp)))
@@ -333,9 +333,9 @@ This is an implementation of `foldts' as described by Andy Wingo in
(up tree (loop exps (down tree result))))
((<lambda> body)
(up tree (loop body (down tree result))))
- ((<lambda-case> inits body else)
- (up tree (if else
- (loop else
+ ((<lambda-case> inits body alternate)
+ (up tree (if alternate
+ (loop alternate
(loop body (loop inits (down tree result))))
(loop body (loop inits (down tree result))))))
((<let> vals body)
@@ -389,11 +389,11 @@ This is an implementation of `foldts' as described by Andy Wingo in
(fold-values foldts exps seed ...))
((<lambda> body)
(foldts body seed ...))
- ((<lambda-case> inits body else)
+ ((<lambda-case> inits body alternate)
(let-values (((seed ...) (fold-values foldts inits seed ...)))
- (if else
+ (if alternate
(let-values (((seed ...) (foldts body seed ...)))
- (foldts else seed ...))
+ (foldts alternate seed ...))
(foldts body seed ...))))
((<let> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
@@ -438,11 +438,11 @@ This is an implementation of `foldts' as described by Andy Wingo in
((<lambda> body)
(set! (lambda-body x) (lp body)))
- ((<lambda-case> inits body else)
+ ((<lambda-case> inits body alternate)
(set! inits (map lp inits))
(set! (lambda-case-body x) (lp body))
- (if else
- (set! (lambda-case-else x) (lp else))))
+ (if alternate
+ (set! (lambda-case-alternate x) (lp alternate))))
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
@@ -495,10 +495,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
((<lambda> body)
(set! (lambda-body x) (lp body)))
- ((<lambda-case> inits body else)
+ ((<lambda-case> inits body alternate)
(set! inits (map lp inits))
(set! (lambda-case-body x) (lp body))
- (if else (set! (lambda-case-else x) (lp else))))
+ (if alternate (set! (lambda-case-alternate x) (lp alternate))))
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index d00fe1d39..508d1a13d 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -191,7 +191,7 @@
(not (lambda-case-opt c))
(not (lambda-case-kw c))
(not (lambda-case-rest c)))
- (lp (lambda-case-else c)))))))))
+ (lp (lambda-case-alternate c)))))))))
(hashq-set! labels gensym #f))
(list gensym))
@@ -225,7 +225,7 @@
(hashq-set! free-vars x free)
free))
- ((<lambda-case> opt kw inits vars body else)
+ ((<lambda-case> opt kw inits vars body alternate)
(hashq-set! bound-vars proc
(append (reverse vars) (hashq-ref bound-vars proc)))
(lset-union
@@ -235,7 +235,7 @@
(apply lset-union eq? (map step inits))
(step-tail body))
vars)
- (if else (step-tail else) '())))
+ (if alternate (step-tail alternate) '())))
((<let> vars vals body)
(hashq-set! bound-vars proc
@@ -379,7 +379,7 @@
(hashq-set! allocation x (cons labels free-addresses)))
n)
- ((<lambda-case> opt kw inits vars body else)
+ ((<lambda-case> opt kw inits vars body alternate)
(max
(let lp ((vars vars) (n n))
(if (null? vars)
@@ -397,7 +397,7 @@
(make-hashq
proc `(#t ,(hashq-ref assigned (car vars)) . ,n)))
(lp (cdr vars) (1+ n)))))
- (if else (allocate! else proc n) n)))
+ (if alternate (allocate! alternate proc n) n)))
((<let> vars vals body)
(let ((nmax (apply max (map recur vals))))
@@ -820,8 +820,8 @@
(if (not proc)
(values name (reverse arities))
(record-case proc
- ((<lambda-case> req opt rest kw else)
- (loop name else
+ ((<lambda-case> req opt rest kw alternate)
+ (loop name alternate
(cons (list (len req) (len opt) rest
(and (pair? kw) (map car (cdr kw)))
(and (pair? kw) (car kw)))
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index bef4ac7f0..6a19c0f75 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -426,7 +426,7 @@
(emit-branch src 'br (car (hashq-ref allocation lcase))))
((lambda-case? lcase)
;; no match, try next case
- (lp (lambda-case-else lcase)))
+ (lp (lambda-case-alternate lcase)))
(else
;; no cases left; shuffle args down and jump before the prelude.
(for-each (lambda (i)
@@ -463,7 +463,7 @@
(emit-branch src 'br (car (hashq-ref allocation lcase))))
((lambda-case? lcase)
;; no match, try next case
- (lp (lambda-case-else lcase)))
+ (lp (lambda-case-alternate lcase)))
(else
;; no cases left. we can't really handle this currently.
;; ideally we would push on a new frame, then do a "local
@@ -664,7 +664,7 @@
(emit-code #f (make-glil-call 'make-closure 2)))))))
(maybe-emit-return))
- ((<lambda-case> src req opt rest kw inits vars else body)
+ ((<lambda-case> src req opt rest kw inits vars alternate body)
;; o/~ feature on top of feature o/~
;; req := (name ...)
;; opt := (name ...) | #f
@@ -688,7 +688,7 @@
(nargs (apply max (+ nreq nopt (if rest 1 0))
(map 1+ (map cdr kw-indices))))
(nlocs (cdr (hashq-ref allocation x)))
- (else-label (and else (make-label))))
+ (alternate-label (and alternate (make-label))))
(or (= nargs
(length vars)
(+ nreq (length inits) (if rest 1 0)))
@@ -701,11 +701,11 @@
(cond
(kw
(make-glil-kw-prelude nreq nopt rest-idx kw-indices
- allow-other-keys? nlocs else-label))
+ allow-other-keys? nlocs alternate-label))
((or rest opt)
- (make-glil-opt-prelude nreq nopt rest-idx nlocs else-label))
+ (make-glil-opt-prelude nreq nopt rest-idx nlocs alternate-label))
(#t
- (make-glil-std-prelude nreq nlocs else-label))))
+ (make-glil-std-prelude nreq nlocs alternate-label))))
;; box args if necessary
(for-each
(lambda (v)
@@ -754,10 +754,10 @@
(comp-tail body)
(if (not (null? vars))
(emit-code #f (make-glil-unbind)))
- (if else-label
+ (if alternate-label
(begin
- (emit-label else-label)
- (comp-tail else)))))
+ (emit-label alternate-label)
+ (comp-tail alternate)))))
((<let> src names vars vals body)
(for-each comp-push vals)
@@ -827,7 +827,7 @@
(let lp ((lcase (lambda-body x)))
(if lcase
(record-case lcase
- ((<lambda-case> src req vars body else)
+ ((<lambda-case> src req vars 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)
@@ -835,7 +835,7 @@
(emit-code #f (make-glil-source src)))
(comp-fix body (or RA new-RA))
(emit-code #f (make-glil-unbind))
- (lp else)))
+ (lp alternate)))
(emit-label POST)))))))
vals
vars)
@@ -879,8 +879,8 @@
((<let-values> src exp body)
(record-case body
- ((<lambda-case> req opt kw rest vars body else)
- (if (or opt kw else)
+ ((<lambda-case> req opt kw rest vars body alternate)
+ (if (or opt kw alternate)
(error "unexpected lambda-case in let-values" x))
(let ((MV (make-label)))
(comp-vals exp MV)
diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm
index facaa3825..841429fbb 100644
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -44,11 +44,11 @@
(let lp ((lcase body))
(and lcase
(record-case lcase
- ((<lambda-case> req opt rest kw inits vars body else)
+ ((<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)))
(or (inline1 x) x))
- (lp else)))))))
+ (lp alternate)))))))
;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
;; => (let-values (((a b . c) foo)) bar)
@@ -64,7 +64,7 @@
(lambda-case? (lambda-body consumer))
(not (lambda-case-opt (lambda-body consumer)))
(not (lambda-case-kw (lambda-body consumer)))
- (not (lambda-case-else (lambda-body consumer))))
+ (not (lambda-case-alternate (lambda-body consumer))))
(make-let-values
src
(let ((x (make-application src producer '())))