diff options
author | Andy Wingo <wingo@pobox.com> | 2010-05-20 13:27:49 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-05-20 13:27:49 +0200 |
commit | cc63545b3e5d89cb6e3235627fcacccae741afdc (patch) | |
tree | 287aa17c961af4672121ff8555557fe54cabb3dc /module/language/tree-il.scm | |
parent | 131ae7b49de8c723fafaa3f867dc9804c587f375 (diff) | |
download | guile-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.scm | 65 |
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 |