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