mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 13:30:26 +02:00
Code Activity

tree-il->scheme for lambda* et al

Browse source 
* module/language/tree-il.scm (tree-il->scheme): Fix lambda* /
  case-lambda / case-lambda* transformation.
This commit is contained in:
Andy Wingo 2010-05-20 13:27:49 +02:00
parent 131ae7b49d
commit cc63545b3e
1 changed files with 56 additions and 9 deletions
Download patch file Download diff file Expand all files Collapse all files

65
module/language/tree-il.scm
View file

@ -361,17 +361,64 @@
((<lambda> meta body) ((<lambda> meta body)
;; fixme: put in docstring ;; fixme: put in docstring
(if (and (lambda-case? body) (tree-il->scheme 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 gensyms body alternate) ((<lambda-case> req opt rest kw inits gensyms body alternate)
;; FIXME! use parse-lambda-case? (cond
`((,(if rest (apply cons* gensyms) gensyms) ((and (not opt) (not kw) (not alternate))
,(tree-il->scheme body)) `(lambda ,(if rest (apply cons* gensyms) gensyms)
,@(if alternate (tree-il->scheme alternate) '()))) ,(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) ((<const> exp)
(if (and (self-evaluating? exp) (not (vector? exp))) (if (and (self-evaluating? exp) (not (vector? exp)))
exp exp