SketchyLISP Stuff | Copyright (C) 2007 Nils M Holm |
[ More Sketchy LISP Stuff ] |
Language: R5RS Scheme
Purpose:
Transform a subset of Scheme to Continuation Passing Style (CPS).
Based on a similar transformer from the book
"LISP in Small Pieces" by Christian Queinnec.
I have slightly re-structured the code and
extended it to handle
COND, AND, OR, CALL/CC, LET,
and
LETREC.
Instead of hardwiring primitives, everything
that is not defined in a
LET
or
LETREC
is assumed to be primitive.
This program is subject to numerous possible improvements.
Arguments:
X - expression to transform
Implementation:
(define (expr*->cps x* e) (cond ((pair? x*) (lambda (k) ((expr->cps (car x*) e) (lambda (a) ((expr*->cps (cdr x*) e) (lambda (a*) (k (cons a a*)))))))) (else (lambda (k) (k '()))))) (define (primitive? p e) (not (memq p e))) (define (application->cps x e) (lambda (k) (cond ((primitive? (car x) e) ((expr*->cps (cdr x) e) (lambda (x*) (k (append (list (car x)) x*))))) (else ((expr*->cps x e) (lambda (x*) (let ((v (gensym 'v))) (append (list (car x*)) (list (list 'lambda (list v) (k v))) (cdr x*))))))))) (define (quote->cps x e) (let ((datum (cadr x))) (lambda (k) (k (list 'quote datum))))) (define (lambda->cps x e) (let ((formals (cadr x)) (body (caddr x)) (cont (gensym 'k))) (lambda (k) (list 'lambda (cons cont formals) ((expr->cps body e) (lambda (a) (list cont a))))))) (define (if->cps x e) (let ((p (cadr x)) (c (caddr x)) (a (cadddr x))) (lambda (k) ((expr->cps p e) (lambda (v) (list 'if v ((expr->cps c e) k) ((expr->cps a e) k))))))) (define (cond->cps x e) (letrec ((clause*->cps (lambda (c*) (cond ((and (pair? c*) (eq? #t (caar c*))) (lambda (k) ((expr->cps (cadar c*) e) k))) ((pair? c*) (lambda (k) ((expr->cps (caar c*) e) (lambda (v) (list 'if v ((expr->cps (cadar c*) e) k) ((clause*->cps (cdr c*)) k)))))) (else (lambda (k) '(bottom '(no default in cond)))))))) (clause*->cps (cdr x)))) (define (and->cps x e) (letrec ((x*->cps (lambda (x*) (cond ((and (pair? x*) (null? (cdr x*))) (lambda (k) ((expr->cps (car x*) e) k))) ((pair? x*) (lambda (k) ((expr->cps (car x*) e) (lambda (v) (list 'if v ((x*->cps (cdr x*)) k) ((expr->cps #f e) k)))))) (else (lambda (k) ((expr->cps #t e) k))))))) (x*->cps (cdr x)))) (define (or->cps x e) (letrec ((x*->cps (lambda (x*) (cond ((and (pair? x*) (null? (cdr x*))) (lambda (k) ((expr->cps (car x*) e) k))) ((pair? x*) (lambda (k) ((expr->cps (car x*) e) (lambda (v) (let ((t (gensym 't))) (list 'let (list (list t v)) (list 'if t ((expr->cps t e) k) ((x*->cps (cdr x*)) k)))))))) (else (lambda (k) ((expr->cps #f e) k))))))) (x*->cps (cdr x)))) (define (begin->cps x e) (letrec ((x*->cps (lambda (x*) (cond ((and (pair? x*) (null? (cdr x*))) (lambda (k) ((expr->cps (car x*) e) k))) ((pair? x*) (let ((ignore (gensym 'i))) (lambda (k) ((expr->cps (car x*) e) (lambda (v) (list (list 'lambda (list ignore) ((x*->cps (cdr x*)) k)) v)))))) (else (bottom '(empty begin))))))) (x*->cps (cdr x)))) (define (call/cc->cps x e) (lambda (k) (let ((c (gensym 'c))) (k (list (cadr x) (list 'lambda (list c) (k c))))))) (define (let->cps x e) (let ((env (cadr x)) (body (caddr x))) (letrec ((locals (lambda (b*) (cond ((null? b*) e) (else (cons (caar b*) (locals (cdr b*))))))) (b*->cps (lambda (b* e) (cond ((null? b*) '()) (else (cons (list (caar b*) ((expr->cps (cadar b*) e) (lambda (x) x))) (b*->cps (cdr b*) e))))))) (let ((e (locals env))) (lambda (k) (list (car x) (b*->cps env e) ((expr->cps body e) k))))))) (define (expr->cps x e) (cond ((not (pair? x)) (lambda (k) (k x))) ((eq? 'quote (car x)) (quote->cps x e)) ((eq? 'lambda (car x)) (lambda->cps x e)) ((eq? 'if (car x)) (if->cps x e)) ((eq? 'cond (car x)) (cond->cps x e)) ((eq? 'and (car x)) (and->cps x e)) ((eq? 'or (car x)) (or->cps x e)) ((eq? 'begin (car x)) (begin->cps x e)) ((eq? 'call/cc (car x)) (call/cc->cps x e)) ((eq? 'let (car x)) (let->cps x e)) ((eq? 'letrec (car x)) (let->cps x e)) (else (application->cps x e)))) (define (scheme->cps x) ((expr->cps x '()) (lambda (x) x)))
Example:
(scheme->cps '(lambda (x) (f x))) => (lambda (k1 x) (k1 (f x)))
[ More Sketchy LISP Stuff ] |