diff options
-rw-r--r-- | module/language/tree-il.scm | 40 | ||||
-rw-r--r-- | module/language/tree-il/analyze.scm | 14 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 28 | ||||
-rw-r--r-- | module/language/tree-il/inline.scm | 6 |
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 '()))) |