summaryrefslogtreecommitdiff
path: root/module/language/tree-il.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-10-14 00:08:35 +0200
committerAndy Wingo <wingo@pobox.com>2009-10-23 15:10:25 +0200
commit8a4ca0ea3bd3e378fc63ef719ce828b7252b3985 (patch)
treeff71f102d96cc8f10f67618cf136aa35fc55a47f /module/language/tree-il.scm
parentc783b0827c5e5485209879b6cd329a7f095ecf9c (diff)
downloadguile-8a4ca0ea3bd3e378fc63ef719ce828b7252b3985.tar.gz
tree-il support for case-lambda
* module/language/tree-il.scm (<lambda>, <lambda-case>): Split lambda into the lambda itself, denoting the procedure, and lambda-case, denoting a particular arity case. Lambda-case is fairly featureful, and has not yet been fully tested. (<let-values>): Use a <lambda-case> as the binding expression. Seems to suit the purpose well. Adapt parsers, unparsers, traversal operators, etc. Sometimes in this first version we assume there are no optional args, rest args, or a predicate. * module/language/tree-il/analyze.scm (analyze-lexicals): Adapt for the new case-lambda regime. Fairly well commented. It actually simplifies things. (report-unused-variables): Update for new tree-il. * module/language/tree-il/compile-glil.scm: Adapt for the new tree-il. There are some first stabs here at proper case-lambda compilation, but they are untested as of yet. * module/language/tree-il/inline.scm (inline!): Rework so we can recurse on a single node; though these transformations are strictly reductive, so they should complete in bounded time. Simplify accordingly, and adapt to case-lambda. Oh, and we handle lambda->let in not just the nullary case. * module/ice-9/psyntax.scm (build-simple-lambda, build-case-lambda) (build-lambda-case): New constructors. The idea is that after syntax expansion, we shouldn't have to deal with improper lists any more. Build-simple-lambda is a shortcut for the common case. The others are not fully exercised yet. Adapt callers. (syntax): Add some debugging in the lambda case. I don't fully understand this, but in practice we don't seem to see rest args here. (lambda): Inline chi-lambda-clause, and adapt for build-simple-lambda. * module/ice-9/psyntax-pp.scm: Regenerated. * test-suite/tests/tree-il.test: Update tests for new tree-il lambda format, and to expect post-prelude labels for all glil programs.
Diffstat (limited to 'module/language/tree-il.scm')
-rw-r--r--module/language/tree-il.scm108
1 files changed, 87 insertions, 21 deletions
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 123363208..d645cafd5 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -36,11 +36,14 @@
<conditional> conditional? make-conditional conditional-src conditional-test conditional-then conditional-else
<application> application? make-application application-src application-proc application-args
<sequence> sequence? make-sequence sequence-src sequence-exps
- <lambda> lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body
+ <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-vars
+ lambda-case-predicate lambda-case-body lambda-case-else
<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-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body
+ <let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
parse-tree-il
unparse-tree-il
@@ -65,11 +68,12 @@
(<conditional> test then else)
(<application> proc args)
(<sequence> exps)
- (<lambda> names vars meta body)
+ (<lambda> meta body)
+ (<lambda-case> req opt rest kw vars predicate body else)
(<let> names vars vals body)
(<letrec> names vars vals body)
(<fix> names vars vals body)
- (<let-values> names vars exp body))
+ (<let-values> exp body))
@@ -127,11 +131,14 @@
((define ,name ,exp) (guard (symbol? name))
(make-toplevel-define loc name (retrans exp)))
- ((lambda ,names ,vars ,exp)
- (make-lambda loc names vars '() (retrans exp)))
+ ((lambda ,meta ,body)
+ (make-lambda loc meta (retrans body)))
- ((lambda ,names ,vars ,meta ,exp)
- (make-lambda loc names vars meta (retrans exp)))
+ ((lambda-case ((,req ,opt ,rest ,kw ,vars ,predicate) ,body) ,else)
+ (make-lambda-case loc req opt rest kw vars
+ (and=> predicate retrans)
+ (retrans body)
+ (and=> else retrans)))
((const ,exp)
(make-const loc exp))
@@ -148,8 +155,8 @@
((fix ,names ,vars ,vals ,body)
(make-fix loc names vars (map retrans vals) (retrans body)))
- ((let-values ,names ,vars ,exp ,body)
- (make-let-values loc names vars (retrans exp) (retrans body)))
+ ((let-values ,exp ,body)
+ (make-let-values loc (retrans exp) (retrans body)))
(else
(error "unrecognized tree-il" exp)))))
@@ -189,8 +196,13 @@
((<toplevel-define> name exp)
`(define ,name ,(unparse-tree-il exp)))
- ((<lambda> names vars meta body)
- `(lambda ,names ,vars ,meta ,(unparse-tree-il body)))
+ ((<lambda> meta body)
+ `(lambda ,meta ,(unparse-tree-il body)))
+
+ ((<lambda-case> req opt rest kw vars predicate body else)
+ `(lambda-case ((,req ,opt ,rest ,kw ,vars ,(and=> predicate unparse-tree-il))
+ ,(unparse-tree-il body))
+ ,(and=> else unparse-tree-il)))
((<const> exp)
`(const ,exp))
@@ -207,8 +219,8 @@
((<fix> names vars vals body)
`(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
- ((<let-values> names vars exp body)
- `(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
+ ((<let-values> exp body)
+ `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
(define (tree-il->scheme e)
(record-case e
@@ -247,10 +259,31 @@
((<toplevel-define> name exp)
`(define ,name ,(tree-il->scheme exp)))
- ((<lambda> vars meta body)
- `(lambda ,vars
- ,@(cond ((assq-ref meta 'documentation) => list) (else '()))
- ,(tree-il->scheme body)))
+ ((<lambda> meta body)
+ ;; fixme: put in docstring
+ (if (and (lambda-case? body)
+ (not (lambda-case-else body)))
+ `(lambda ,@(car (tree-il->scheme body)))
+ `(case-lambda ,@(tree-il->scheme body))))
+
+ ((<lambda-case> req opt rest kw vars predicate body else)
+ ;; FIXME
+ #; `(((,@req
+ ,@(if (not opt)
+ '()
+ (cons #:optional opt))
+ ,@(if (not kw)
+ '()
+ (cons #:key (cdr kw)))
+ ,@(if predicate
+ (list #:predicate (tree-il->scheme predicate))
+ '())
+ . ,(or rest '()))
+ ,(tree-il->scheme body))
+ ,@(if else (tree-il->scheme else) '()))
+ `((,(if rest (apply cons* vars) vars)
+ ,(tree-il->scheme body))
+ ,@(if else (tree-il->scheme else) '())))
((<const> exp)
(if (and (self-evaluating? exp) (not (vector? exp)))
@@ -272,7 +305,7 @@
((<let-values> vars exp body)
`(call-with-values (lambda () ,(tree-il->scheme exp))
- (lambda ,vars ,(tree-il->scheme body))))))
+ ,(tree-il->scheme (make-lambda #f '() body))))))
(define (tree-il-fold leaf down up seed tree)
@@ -306,6 +339,15 @@ 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> predicate body else)
+ (up tree (if else
+ (loop else
+ (if predicate
+ (loop body (loop predicate (down tree result)))
+ (loop body (down tree result))))
+ (if predicate
+ (loop body (loop predicate (down tree result)))
+ (loop body (down tree result))))))
((<let> vals body)
(up tree (loop body
(loop vals
@@ -357,6 +399,18 @@ This is an implementation of `foldts' as described by Andy Wingo in
(fold-values foldts exps seed ...))
((<lambda> body)
(foldts body seed ...))
+ ((<lambda-case> predicate body else)
+ (if predicate
+ (if else
+ (let*-values (((seed ...) (foldts predicate seed ...))
+ ((seed ...) (foldts body seed ...)))
+ (foldts else seed ...))
+ (let-values (((seed ...) (foldts predicate seed ...)))
+ (foldts body seed ...)))
+ (if else
+ (let-values (((seed ...) (foldts body seed ...)))
+ (foldts else seed ...))
+ (foldts body seed ...))))
((<let> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
@@ -397,9 +451,16 @@ This is an implementation of `foldts' as described by Andy Wingo in
((<toplevel-define> name exp)
(set! (toplevel-define-exp x) (lp exp)))
- ((<lambda> vars meta body)
+ ((<lambda> body)
(set! (lambda-body x) (lp body)))
+ ((<lambda-case> predicate body else)
+ (if predicate
+ (set! (lambda-case-predicate x) (lp predicate)))
+ (set! (lambda-case-body x) (lp body))
+ (if else
+ (set! (lambda-case-else x) (lp else))))
+
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
@@ -415,7 +476,7 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (fix-vals x) (map lp vals))
(set! (fix-body x) (lp body)))
- ((<let-values> vars exp body)
+ ((<let-values> exp body)
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
@@ -451,6 +512,11 @@ This is an implementation of `foldts' as described by Andy Wingo in
((<lambda> body)
(set! (lambda-body x) (lp body)))
+ ((<lambda-case> predicate body else)
+ (if predicate (set! (lambda-case-predicate x) (lp predicate)))
+ (set! (lambda-case-body x) (lp body))
+ (if else (set! (lambda-case-else x) (lp else))))
+
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))