cps.rkt

#lang racket

#|
variation of the cps transformation described by Danvy & Nielsen
http://www.brics.dk/RS/01/49/BRICS-RS-01-49.pdf
this version doesn't depend on a free variable "k"
and differentiates source lambdas and those introduced by the transformation
|#

(define (aexp? e)
  (or (symbol? e)
      (and (list? e)
	   (eq? (car e) 'lambda))))

(define (cexp? e)
  (not (aexp? e)))

(define-syntax-rule (klambda (var) body)
  (lambda (var) body))

(define (cps e)
  (define k (gensym 'k))
  `(lambda (,k) ,(ecps e k)))

(define (ecps e k)
  (scps e k))

(define (scps e k)
  (match e
    ((? aexp?) `(,k ,(tcps e)))
    ((list (? aexp? a0) (? aexp? a1))
     `(,(tcps a0) ,(tcps a1) ,k))
    ((list (? aexp? a0) (? cexp? c1))
     (define x0 (gensym 'x0))
     (scps c1 `(klambda (,x0) 
		   (,(tcps a0) ,(tcps x0) ,k))))
    ((list (? cexp? c0) (? aexp? a0))
     (define x0 (gensym 'x0))
     (scps c0 `(klambda (,x0) (,x0 ,(tcps a0) ,k))))
    ((list (? cexp? c0) (? cexp? c1))
     (define x0 (gensym 'x0))
     (define x1 (gensym 'x1))
     (scps c0 `(klambda (,x0) ,(scps c1
			         `(klambda (,x1)
                                    (,x0 ,x1 ,k))))))))

(define (tcps t)
  (match t
    (`(lambda (,x) ,e)
     (define k (gensym 'k))
     `(lambda (,x ,k) ,(ecps e k)))
    (else t)))

#|
> (cps 'x)
'(lambda (k1429) (k1429 x))
> (cps '(lambda (x) (x x)))
'(lambda (k1554) (k1554 (lambda (x k1555) (x x k1555))))
> (cps '(g (f x)))
'(lambda (k1714) (f x (klambda (x01715) (g x01715 k1714))))
> (cps '((f a) g))
'(lambda (k1829) (f a (klambda (x01830) (x01830 g k1829))))
> (cps '((lambda (f) (lambda (x) (f x))) (lambda (x) x)))
'(lambda (k3186) ((lambda (f k3187) (k3187 (lambda (x k3188) (f x k3188)))) (lambda (x k3189) (k3189 x)) k3186))
|#