scheme->cps

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)))