summaryrefslogtreecommitdiff
path: root/module/language/tree-il.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-05-20 13:27:49 +0200
committerAndy Wingo <wingo@pobox.com>2010-05-20 13:27:49 +0200
commitcc63545b3e5d89cb6e3235627fcacccae741afdc (patch)
tree287aa17c961af4672121ff8555557fe54cabb3dc /module/language/tree-il.scm
parent131ae7b49de8c723fafaa3f867dc9804c587f375 (diff)
downloadguile-cc63545b3e5d89cb6e3235627fcacccae741afdc.tar.gz
tree-il->scheme for lambda* et al
* module/language/tree-il.scm (tree-il->scheme): Fix lambda* / case-lambda / case-lambda* transformation.
Diffstat (limited to 'module/language/tree-il.scm')
-rw-r--r--module/language/tree-il.scm65
1 files changed, 56 insertions, 9 deletions
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 5f4c014fb..f9181ed7a 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -361,17 +361,64 @@
((<lambda> meta body)
;; fixme: put in docstring
- (if (and (lambda-case? body)
- (not (lambda-case-alternate body)))
- `(lambda ,@(car (tree-il->scheme body)))
- `(case-lambda ,@(tree-il->scheme body))))
+ (tree-il->scheme body))
((<lambda-case> req opt rest kw inits gensyms body alternate)
- ;; FIXME! use parse-lambda-case?
- `((,(if rest (apply cons* gensyms) gensyms)
- ,(tree-il->scheme body))
- ,@(if alternate (tree-il->scheme alternate) '())))
-
+ (cond
+ ((and (not opt) (not kw) (not alternate))
+ `(lambda ,(if rest (apply cons* gensyms) gensyms)
+ ,(tree-il->scheme body)))
+ ((and (not opt) (not kw))
+ (let ((alt-expansion (tree-il->scheme alternate))
+ (formals (if rest (apply cons* gensyms) gensyms)))
+ (case (car alt-expansion)
+ ((lambda)
+ `(case-lambda (,formals ,(tree-il->scheme body))
+ ,@(cdr alt-expansion)))
+ ((lambda*)
+ `(case-lambda* (,formals ,(tree-il->scheme body))
+ ,(cdr alt-expansion)))
+ ((case-lambda)
+ `(case-lambda (,formals ,(tree-il->scheme body))
+ ,@(cdr alt-expansion)))
+ ((case-lambda*)
+ `(case-lambda* (,formals ,(tree-il->scheme body))
+ ,@(cdr alt-expansion))))))
+ (else
+ (let* ((alt-expansion (and alternate (tree-il->scheme alternate)))
+ (nreq (length req))
+ (nopt (if opt (length opt) 0))
+ (restargs (if rest (list-ref gensyms (+ nreq nopt)) '()))
+ (reqargs (list-head gensyms nreq))
+ (optargs (if opt
+ `(#:optional
+ ,@(map list
+ (list-head (list-tail gensyms nreq) nopt)
+ (map tree-il->scheme
+ (list-head inits nopt))))
+ '()))
+ (kwargs (if kw
+ `(#:key
+ ,@(map list
+ (map caddr (cdr kw))
+ (map tree-il->scheme
+ (list-tail inits nopt))
+ (map car (cdr kw)))
+ ,@(if (car kw)
+ '(#:allow-other-keys)
+ '()))
+ '()))
+ (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs)))
+ (if (not alt-expansion)
+ `(lambda* ,formals ,(tree-il->scheme body))
+ (case (car alt-expansion)
+ ((lambda lambda*)
+ `(case-lambda* (,formals ,(tree-il->scheme body))
+ ,(cdr alt-expansion)))
+ ((case-lambda case-lambda*)
+ `(case-lambda* (,formals ,(tree-il->scheme body))
+ ,@(cdr alt-expansion)))))))))
+
((<const> exp)
(if (and (self-evaluating? exp) (not (vector? exp)))
exp