lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fixes and improvements to cps converter

This commit is contained in:
JeffBezanson 2009-01-02 22:58:14 +00:00
parent 9716ee3452
commit 88938bc6d1
1 changed files with 17 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
femtolisp/cps.lsp
View File

@ -16,9 +16,12 @@
,(progn->cps (cdr forms) k))))))) ,(progn->cps (cdr forms) k)))))))
(define (rest->cps xformer form k argsyms) (define (rest->cps xformer form k argsyms)
(let ((g (gensym))) (let ((el (car form)))
(cps- (car form) `(lambda (,g) (if (or (atom el) (constantp el))
,(xformer (cdr form) k (cons g argsyms)))))) (xformer (cdr form) k (cons el argsyms))
(let ((g (gensym)))
(cps- el `(lambda (,g)
,(xformer (cdr form) k (cons g argsyms))))))))
; (f x) => (cps- f `(lambda (F) ,(cps- x `(lambda (X) (F ,k X))))) ; (f x) => (cps- f `(lambda (F) ,(cps- x `(lambda (X) (F ,k X)))))
(define (app->cps form k argsyms) (define (app->cps form k argsyms)
@ -158,10 +161,13 @@
(any (lambda (p) (contains x p)) form))) (any (lambda (p) (contains x p)) form)))
(define (β-reduce form) (define (β-reduce form)
(cond ((or (atom form) (constantp form)) form) (if (or (atom form) (constantp form))
form
(β-reduce- (map β-reduce form))))
(define (β-reduce- form)
; ((lambda (f) (f arg)) X) => (X arg) ; ((lambda (f) (f arg)) X) => (X arg)
((and (= (length form) 2) (cond ((and (= (length form) 2)
(consp (car form)) (consp (car form))
(eq (caar form) 'lambda) (eq (caar form) 'lambda)
(let ((args (cadr (car form))) (let ((args (cadr (car form)))
@ -172,12 +178,12 @@
(eq (car body) (car args)) (eq (car body) (car args))
(not (eq (cadr body) (car args))) (not (eq (cadr body) (car args)))
(symbolp (cadr body))))) (symbolp (cadr body)))))
`(,(β-reduce (cadr form)) `(,(cadr form)
,(cadr (caddr (car form))))) ,(cadr (caddr (car form)))))
; (identity x) => x ; (identity x) => x
((eq (car form) *top-k*) ((eq (car form) *top-k*)
(β-reduce (cadr form))) (cadr form))
; uncurry: ; uncurry:
; ((lambda (p1) ((lambda (args...) body) exprs...)) s) => ; ((lambda (p1) ((lambda (args...) body) exprs...)) s) =>
@ -189,7 +195,7 @@
(or (atom (cadr form)) (constantp (cadr form))) (or (atom (cadr form)) (constantp (cadr form)))
(let ((args (cadr (car form))) (let ((args (cadr (car form)))
(s (cadr form)) (s (cadr form))
(body (β-reduce (caddr (car form))))) (body (caddr (car form))))
(and (= (length args) 1) (and (= (length args) 1)
(consp body) (consp body)
(consp (car body)) (consp (car body))
@ -203,7 +209,7 @@
,s ,s
,@params))))))) ,@params)))))))
(T (map β-reduce form)))) (T form)))
(defmacro with-delimited-continuations code (cps (f-body code))) (defmacro with-delimited-continuations code (cps (f-body code)))
@ -250,6 +256,8 @@ todo:
- handle dotted arglists in lambda - handle dotted arglists in lambda
- use fewer gensyms
here's an alternate way to transform a while loop: here's an alternate way to transform a while loop:
(let ((x 0)) (let ((x 0))