diff options
Diffstat (limited to 'module/language/tree-il.scm')
-rw-r--r-- | module/language/tree-il.scm | 167 |
1 files changed, 6 insertions, 161 deletions
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 69af8d65a..fb58a027e 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -36,7 +36,7 @@ <conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate <call> call? make-call call-src call-proc call-args <primcall> primcall? make-primcall primcall-src primcall-name primcall-args - <seq> seq? make-seq seq-head seq-tail + <seq> seq? make-seq seq-src seq-head seq-tail <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 @@ -356,165 +356,10 @@ `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args) ,(unparse-tree-il tail))))) -(define (tree-il->scheme e) - (record-case e - ((<void>) - '(if #f #f)) - - ((<call> proc args) - `(,(tree-il->scheme proc) ,@(map tree-il->scheme args))) - - ((<primcall> name args) - `(,name ,@(map tree-il->scheme args))) - - ((<conditional> test consequent alternate) - (if (void? alternate) - `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent)) - `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent) ,(tree-il->scheme alternate)))) - - ((<primitive-ref> name) - name) - - ((<lexical-ref> gensym) - gensym) - - ((<lexical-set> gensym exp) - `(set! ,gensym ,(tree-il->scheme exp))) - - ((<module-ref> mod name public?) - `(,(if public? '@ '@@) ,mod ,name)) - - ((<module-set> mod name public? exp) - `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp))) - - ((<toplevel-ref> name) - name) - - ((<toplevel-set> name exp) - `(set! ,name ,(tree-il->scheme exp))) - - ((<toplevel-define> name exp) - `(define ,name ,(tree-il->scheme exp))) - - ((<lambda> meta body) - ;; fixme: put in docstring - (tree-il->scheme body)) - - ((<lambda-case> req opt rest kw inits gensyms body 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 - (list 'quote exp))) - - ((<seq> head tail) - `(begin ,(tree-il->scheme head) - ,@(unfold (lambda (x) (not (seq? x))) - (lambda (x) (tree-il->scheme (seq-head x))) - seq-tail - tail - (lambda (x) - (list (tree-il->scheme x)))))) - - ((<let> gensyms vals body) - `(let ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body))) - - ((<letrec> in-order? gensyms vals body) - `(,(if in-order? 'letrec* 'letrec) - ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body))) - - ((<fix> gensyms vals body) - ;; not a typo, we really do translate back to letrec. use letrec* since it - ;; doesn't matter, and the naive letrec* transformation does not require an - ;; inner let. - `(letrec* ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body))) - - ((<let-values> exp body) - `(call-with-values (lambda () ,(tree-il->scheme exp)) - ,(tree-il->scheme (make-lambda #f '() body)))) - - ((<dynwind> winder body unwinder) - `(dynamic-wind ,(tree-il->scheme winder) - (lambda () ,(tree-il->scheme body)) - ,(tree-il->scheme unwinder))) - - ((<dynlet> fluids vals body) - `(with-fluids ,(map list - (map tree-il->scheme fluids) - (map tree-il->scheme vals)) - ,(tree-il->scheme body))) - - ((<dynref> fluid) - `(fluid-ref ,(tree-il->scheme fluid))) - - ((<dynset> fluid exp) - `(fluid-set! ,(tree-il->scheme fluid) ,(tree-il->scheme exp))) - - ((<prompt> tag body handler) - `(call-with-prompt - ,(tree-il->scheme tag) - (lambda () ,(tree-il->scheme body)) - ,(tree-il->scheme handler))) - - - ((<abort> tag args tail) - `(apply abort-to-prompt - ,(tree-il->scheme tag) ,@(map tree-il->scheme args) - ,(tree-il->scheme tail))))) +(define* (tree-il->scheme e #:optional (env #f) (opts '())) + (values ((@ (language scheme decompile-tree-il) + decompile-tree-il) + e env opts))) (define (tree-il-fold leaf down up seed tree) |