Kennedy's CPS algorithm exhbits an interesting symmetry: the code for handling expressions in tail and non-tail position is almost identical. Here is an implementation of Kennedy's algorithm that exploits this symmetry.
;; translation-time lambda
(define-syntax tlambda
(syntax-rules ()
[(_ args b b* ...)
(lambda args b b* ...)]))
;; base continuation
(define tk_0
(tlambda (x)
`(halt ,x)))
(define cps
(lambda (e)
(cps-nontail e tk_0)))
(define simple-tail (lambda (k) (lambda (x) `(,k ,x))))
(define nonsimple-tail (lambda (constructor) constructor))
(define simple-nontail (lambda (tk) tk))
(define nonsimple-nontail
(lambda (constructor)
(lambda (tk)
(let ((x (gensym "x")) (k (gensym "k")))
`(let ((,k (lambda (,x) ,(tk x))))
,(constructor k))))))
(define cps-tail
(lambda (e k)
(cpser e k simple-tail nonsimple-tail)))
(define cps-nontail
(lambda (e tk)
(cpser e tk simple-nontail nonsimple-nontail)))
(define cpser
(lambda (e tk simple-op op)
(pmatch e
[,x (guard (symbol? x)) ((simple-op tk) x)]
[(lambda (,x) ,e)
(let ((f (gensym "f")) (k (gensym "k")))
`(let ((,f (lambda (,x ,k) ,(cps-tail e k))))
,((simple-op tk) f)))]
[(,e1 ,e2)
(cps-nontail e1
(tlambda (x1)
(cps-nontail e2
(tlambda (x2)
((op (lambda (k) `(,x1 ,x2 ,k))) tk)))))])))
Your task is to extend this CPSer to support the following language forms: numbers,
sub1, *, zero?, if, letcc and throw.
Submit the code for your CPSer to Vincent in a file named a12.scm.
Here are some tests for your extended CPSer. In order for the test macro to work, the tests must appear within a fluid-let that rebinds Chez Scheme's gensym function.
You needn't worry about calls to print-num within the test programs: for purposes of the CPS pass, print-num can just be considered an arbitrary function.
(load "a12.scm")
(define-syntax test
(syntax-rules ()
((_ title tested-expression expected-result)
(let* ((expected expected-result)
(produced tested-expression))
(if (equal? expected produced)
(printf "~s works!\n" title)
(error
'test
"Failed ~s: ~a\nExpected: ~a\nComputed: ~a"
title 'tested-expression expected produced))))))
(fluid-let ((gensym (lambda (str) (string->symbol str))))
(test "lambda-1"
(cps '(lambda (x) x))
'(let ((f (lambda (x k) (k x))))
(halt f)))
(test "lambda-2"
(cps '(lambda (x) 5))
'(let ([f (lambda (x k) (k 5))])
(halt f)))
(test "app-1"
(cps '((lambda (x) (lambda (z) z))
(lambda (y) y)))
'(let ([f (lambda (x k)
(let ([f (lambda (z k) (k z))]) (k f)))])
(let ([f (lambda (y k) (k y))])
(let ([k (lambda (x) (halt x))]) (f f k)))))
(test "app-2"
(cps '((lambda (x) x)
(lambda (y) y)))
'(let ([f (lambda (x k) (k x))])
(let ([f (lambda (y k) (k y))])
(let ([k (lambda (x) (halt x))]) (f f k)))))
(test "number-1"
(cps '42)
'(halt 42))
(test "print-1"
(cps '(print-num 42))
'(let ([k (lambda (x) (halt x))]) (print-num 42 k)))
(test "number-2"
(cps '((lambda (n) 5)
(lambda (x) x)))
'(let ([f (lambda (n k) (k 5))])
(let ([f (lambda (x k) (k x))])
(let ([k (lambda (x) (halt x))]) (f f k)))))
(test "number-3"
(cps '((lambda (n) 7) 5))
'(let ([f (lambda (n k) (k 7))])
(let ([k (lambda (x) (halt x))]) (f 5 k))))
(test "number-4"
(cps '((lambda (n) n) 5))
'(let ([f (lambda (n k) (k n))])
(let ([k (lambda (x) (halt x))]) (f 5 k))))
(test "print-2"
(cps '((lambda (n) (print-num 137)) 5))
'(let ([f (lambda (n k) (print-num 137 k))])
(let ([k (lambda (x) (halt x))]) (f 5 k))))
(test "print-3"
(cps '((lambda (n) (print-num n)) 5))
'(let ([f (lambda (n k) (print-num n k))])
(let ([k (lambda (x) (halt x))]) (f 5 k))))
(test "print-4"
(cps '(((lambda (n)
(lambda (m)
(print-num n)))
7)
8))
'(let ([f (lambda (n k)
(let ([f (lambda (m k) (print-num n k))]) (k f)))])
(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (x 8 k)))])
(f 7 k))))
(test "print-5"
(cps '(((lambda (n)
(lambda (m)
(print-num m)))
7)
8))
'(let ([f (lambda (n k)
(let ([f (lambda (m k) (print-num m k))]) (k f)))])
(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (x 8 k)))])
(f 7 k))))
(test "print-6"
(cps '(((lambda (n)
(lambda (n)
(print-num n)))
7)
8))
'(let ([f (lambda (n k)
(let ([f (lambda (n k) (print-num n k))]) (k f)))])
(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (x 8 k)))])
(f 7 k))))
(test "print-7"
(cps '((lambda (f)
(print-num (f f)))
(lambda (ignore) 3)))
'(let ([f (lambda (f k)
(let ([k (lambda (x) (print-num x k))]) (f f k)))])
(let ([f (lambda (ignore k) (k 3))])
(let ([k (lambda (x) (halt x))]) (f f k)))))
(test "*-1"
(cps '(print-num (* 3 4)))
'(let ([k (lambda (x) (halt x))])
(print-num (* 3 4) k)))
(test "*-2"
(cps '((lambda (n) (print-num n))
(* 3 4)))
'(let ([f (lambda (n k) (print-num n k))])
(let ([k (lambda (x) (halt x))])
(f (* 3 4) k))))
(test "*-3"
(cps '((lambda (n) (print-num n))
(* (* 3 4) 5)))
'(let ([f (lambda (n k) (print-num n k))])
(let ([k (lambda (x) (halt x))])
(f (* (* 3 4) 5) k))))
(test "*-4"
(cps '((lambda (n) (print-num n))
(* (* 3 4) (* 5 2))))
'(let ([f (lambda (n k) (print-num n k))])
(let ([k (lambda (x) (halt x))])
(f (* (* 3 4) (* 5 2)) k))))
(test "*-5"
(cps '((lambda (n) (print-num (* n n)))
(* (* 3 4) (* 5 2))))
'(let ([f (lambda (n k) (print-num (* n n) k))])
(let ([k (lambda (x) (halt x))])
(f (* (* 3 4) (* 5 2)) k))))
(test "*-6"
(cps '((lambda (n) (print-num (* n n)))
(((lambda (n)
(lambda (m)
(* n m)))
(* 3 4))
(* 5 2))))
'(let ([f (lambda (n k) (print-num (* n n) k))])
(let ([f (lambda (n k)
(let ([f (lambda (m k) (k (* n m)))]) (k f)))])
(let ([k (lambda (x)
(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (f x k)))])
(x (* 5 2) k)))])
(f (* 3 4) k)))))
(test "*-7"
(cps '(((lambda (n)
(lambda (f)
(f n)))
(((lambda (n)
(lambda (m)
(* n m)))
(* 3 4))
(* 5 2)))
(lambda (n) (print-num (* n n)))))
'(let ([f (lambda (n k)
(let ([f (lambda (f k) (f n k))]) (k f)))])
(let ([f (lambda (n k)
(let ([f (lambda (m k) (k (* n m)))]) (k f)))])
(let ([k (lambda (x)
(let ([k (lambda (x)
(let ([k (lambda (x)
(let ([f (lambda (n k)
(print-num (* n n) k))])
(let ([k (lambda (x) (halt x))])
(x f k))))])
(f x k)))])
(x (* 5 2) k)))])
(f (* 3 4) k)))))
(test "sub1-1"
(cps '(print-num (sub1 4)))
'(let ([k (lambda (x) (halt x))])
(print-num (sub1 4) k)))
(test "sub1-2"
(cps '((lambda (n) (print-num n))
(sub1 (* 3 4))))
'(let ([f (lambda (n k) (print-num n k))])
(let ([k (lambda (x) (halt x))])
(f (sub1 (* 3 4)) k))))
(test "sub1-3"
(cps '((lambda (n) (print-num n))
(* (sub1 (sub1 (* 3 4)))
(sub1 5))))
'(let ([f (lambda (n k) (print-num n k))])
(let ([k (lambda (x) (halt x))])
(f (* (sub1 (sub1 (* 3 4))) (sub1 5)) k))))
(test "sub1-4"
(cps '((lambda (n) (print-num n))
(* (sub1 (* (sub1 3) (sub1 4))) (* 5 2))))
'(let ([f (lambda (n k) (print-num n k))])
(let ([k (lambda (x) (halt x))])
(f (* (sub1 (* (sub1 3) (sub1 4))) (* 5 2)) k))))
(test "sub1-5"
(cps '((lambda (n) (print-num (sub1 (* n n))))
(* (sub1 4) (sub1 5))))
'(let ([f (lambda (n k) (print-num (sub1 (* n n)) k))])
(let ([k (lambda (x) (halt x))])
(f (* (sub1 4) (sub1 5)) k))))
(test "sub1-6"
(cps '((lambda (n) (print-num (sub1 (* n n))))
(((lambda (n)
(lambda (m)
(sub1 (sub1 (* n m)))))
(sub1 4))
(sub1 5))))
'(let ([f (lambda (n k) (print-num (sub1 (* n n)) k))])
(let ([f (lambda (n k)
(let ([f (lambda (m k) (k (sub1 (sub1 (* n m)))))])
(k f)))])
(let ([k (lambda (x)
(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (f x k)))])
(x (sub1 5) k)))])
(f (sub1 4) k)))))
(test "sub1-7"
(cps '(((lambda (n)
(lambda (f)
(f n)))
(((lambda (n)
(lambda (m)
(sub1 (* n m))))
(sub1 (* 3 4)))
(sub1 (* 5 2))))
(lambda (n) (print-num (sub1 (* n n))))))
'(let ([f (lambda (n k)
(let ([f (lambda (f k) (f n k))]) (k f)))])
(let ([f (lambda (n k)
(let ([f (lambda (m k) (k (sub1 (* n m))))]) (k f)))])
(let ([k (lambda (x)
(let ([k (lambda (x)
(let ([k (lambda (x)
(let ([f (lambda (n k)
(print-num
(sub1 (* n n))
k))])
(let ([k (lambda (x) (halt x))])
(x f k))))])
(f x k)))])
(x (sub1 (* 5 2)) k)))])
(f (sub1 (* 3 4)) k)))))
(test "sub1-8"
(cps '(sub1 ((lambda (x) x) 5)))
'(let ([f (lambda (x k) (k x))])
(let ([k (lambda (x) (halt (sub1 x)))])
(f 5 k))))
(test "zero?-1"
(cps '(print-num (zero? 0)))
'(let ([k (lambda (x) (halt x))])
(print-num (zero? 0) k)))
(test "zero?-2"
(cps '(print-num (zero? 1)))
'(let ([k (lambda (x) (halt x))])
(print-num (zero? 1) k)))
(test "zero?-3"
(cps '(print-num (zero? 2)))
'(let ([k (lambda (x) (halt x))])
(print-num (zero? 2) k)))
(test "zero?-4"
(cps '(print-num (zero? (sub1 1))))
'(let ([k (lambda (x) (halt x))])
(print-num (zero? (sub1 1)) k)))
(test "zero?-5"
(cps '((lambda (n) (print-num (zero? (sub1 n))))
(* 1 1)))
'(let ([f (lambda (n k) (print-num (zero? (sub1 n)) k))])
(let ([k (lambda (x) (halt x))])
(f (* 1 1) k))))
(test "zero?-6"
(cps '((lambda (n) (print-num (zero? (sub1 n))))
(* 2 2)))
'(let ([f (lambda (n k) (print-num (zero? (sub1 n)) k))])
(let ([k (lambda (x) (halt x))])
(f (* 2 2) k))))
(test "zero?-7"
(cps '(zero? ((lambda (x) x) 5)))
'(let ([f (lambda (x k) (k x))])
(let ([k (lambda (x) (halt (zero? x)))])
(f 5 k))))
(test "if-0"
(cps '(if (zero? 0)
3
4))
'(let ([k (lambda (x) (halt x))])
(if (zero? 0)
(k 3)
(k 4))))
(test "if-1"
(cps '(if (zero? 0)
(print-num 3)
(print-num 4)))
'(let ([k (lambda (x) (halt x))])
(if (zero? 0)
(print-num 3 k)
(print-num 4 k))))
(test "if-2"
(cps '(if (zero? 1)
(print-num 3)
(print-num 4)))
'(let ([k (lambda (x) (halt x))])
(if (zero? 1)
(print-num 3 k)
(print-num 4 k))))
(test "if-3"
(cps '(if (zero? (* (sub1 8) 9))
(print-num 3)
(print-num 4)))
'(let ([k (lambda (x) (halt x))])
(if (zero? (* (sub1 8) 9))
(print-num 3 k)
(print-num 4 k))))
(test "if-4"
(cps '(if (if (zero? 0)
(zero? 0)
(zero? 1))
(print-num 3)
(print-num 4)))
'(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))])
(if x (print-num 3 k) (print-num 4 k))))])
(if (zero? 0)
(k (zero? 0))
(k (zero? 1)))))
(test "if-5"
(cps '(if (if (zero? 0)
(zero? 1)
(zero? 0))
(print-num 3)
(print-num 4)))
'(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))])
(if x (print-num 3 k) (print-num 4 k))))])
(if (zero? 0)
(k (zero? 1))
(k (zero? 0)))))
(test "if-6"
(cps '(if (if (zero? 0)
(zero? 1)
(zero? 0))
(if (zero? 0)
(print-num 3)
(print-num 4))
(if (zero? 0)
(print-num 5)
(print-num 6))))
'(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))])
(if x
(if (zero? 0) (print-num 3 k) (print-num 4 k))
(if (zero? 0) (print-num 5 k) (print-num 6 k)))))])
(if (zero? 0)
(k (zero? 1))
(k (zero? 0)))))
(test "if-7"
(cps '(if (if (zero? 0)
(zero? 1)
(zero? 0))
(if (zero? 0)
(print-num 3)
(print-num 4))
(if (zero? 7)
(print-num 5)
(print-num 6))))
'(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))])
(if x
(if (zero? 0) (print-num 3 k) (print-num 4 k))
(if (zero? 7) (print-num 5 k) (print-num 6 k)))))])
(if (zero? 0) (k (zero? 1)) (k (zero? 0)))))
(test "if-8"
(cps '(print-num (sub1 (if (zero? 0) 5 6))))
'(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (print-num (sub1 x) k)))])
(if (zero? 0) (k 5) (k 6))))
(test "if-9"
(cps '(print-num (sub1 (if (zero? 9) 5 6))))
'(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (print-num (sub1 x) k)))])
(if (zero? 9) (k 5) (k 6))))
(test "if-10"
(cps '(print-num (* (if (if (zero? 0)
(zero? 1)
(zero? 0))
(if (zero? 0)
3
4)
(if (zero? 7)
5
6))
5)))
'(let ([k (lambda (x)
(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))])
(print-num (* x 5) k)))])
(if x
(if (zero? 0) (k 3) (k 4))
(if (zero? 7) (k 5) (k 6)))))])
(if (zero? 0) (k (zero? 1)) (k (zero? 0)))))
(test "fact-5"
(cps `(print-num '((lambda (f)
((f f) 5))
(lambda (f)
(lambda (n)
(if (zero? n)
1
(* n ((f f) (sub1 n)))))))))
'(let ([f (lambda (f k)
(let ([k (lambda (x) (x 5 k))]) (f f k)))])
(let ([f (lambda (f k)
(let ([f (lambda (n k)
(if (zero? n)
(k 1)
(let ([k (lambda (x)
(let ([k (lambda (x) (k (* n x)))])
(x (sub1 n) k)))])
(f f k))))])
(k f)))])
(let ([k (lambda (x)
(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))])
(print-num x k)))])
(quote x k)))])
(f f k)))))
(test "letcc-1"
(cps '(letcc q 5))
'(let ([k (lambda (x) (halt x))])
(let ([q (lambda (x) (k x))]) (k 5))))
(test "letcc-2"
(cps '(print-num (letcc q 5)))
'(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (print-num x k)))])
(let ([q (lambda (x) (k x))]) (k 5))))
(test "letcc-3"
(cps '(print-num (letcc q (* 3 4))))
'(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (print-num x k)))])
(let ([q (lambda (x) (k x))]) (k (* 3 4)))))
(test "letcc-4"
(cps '(print-num (* (letcc q (* 3 4)) 5)))
'(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (print-num (* x 5) k)))])
(let ([q (lambda (x) (k x))])
(k (* 3 4)))))
(test "letcc-5"
(cps '(letcc q (throw 4 q)))
'(let ([k (lambda (x) (halt x))])
(let ([q (lambda (x) (k x))])
(q 4))))
(test "letcc-6"
(cps '(print-num (letcc q (throw 4 q))))
'(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (print-num x k)))])
(let ([q (lambda (x) (k x))])
(q 4))))
(test "letcc-7"
(cps '(print-num (letcc q (throw (* 3 4) q))))
'(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (print-num x k)))])
(let ([q (lambda (x) (k x))])
(q (* 3 4)))))
(test "letcc-8"
(cps '(print-num (* (letcc q (throw (* 3 4) q)) 5)))
'(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (print-num (* x 5) k)))])
(let ([q (lambda (x) (k x))])
(q (* 3 4)))))
(test "letcc-9"
(cps '(print-num (* (letcc q (letcc r (throw (* 3 4) q))) 5)))
'(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (print-num (* x 5) k)))])
(let ([q (lambda (x) (k x))])
(let ([r (lambda (x) (k x))])
(q (* 3 4))))))
(test "letcc-fun-1"
(cps '(* 3 (letcc q (* 2 (throw 4 q)))))
'(let ([k (lambda (x) (halt (* 3 x)))])
(let ([q (lambda (x) (k x))])
(let ([k (lambda (x) (k (* 2 x)))])
(q 4)))))
(test "letcc-fun-2"
(cps '(print-num (* 3 (letcc q (* 2 (throw 4 q))))))
'(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (print-num (* 3 x) k)))])
(let ([q (lambda (x) (k x))])
(let ([k (lambda (x) (k (* 2 x)))])
(q 4)))))
(test "letcc-fun-3"
(cps '(print-num ((lambda (f) (* 3 (letcc q (* 2 (f q)))))
(lambda (k) (throw 4 k)))))
'(let ([f (lambda (f k)
(let ([k (lambda (x) (k (* 3 x)))])
(let ([q (lambda (x) (k x))])
(let ([k (lambda (x) (k (* 2 x)))]) (f q k)))))])
(let ([f (lambda (k k) (k 4))])
(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (print-num x k)))])
(f f k)))))
(test "letcc-fun-4"
(cps '(print-num (* 3 (letcc q ((lambda (x) (* x (throw 4 q))) 2)))))
'(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (print-num (* 3 x) k)))])
(let ([q (lambda (x) (k x))])
(let ([f (lambda (x k)
(let ([k (lambda (x) (k (* x x)))]) (q 4)))])
(f 2 k)))))
(test "letcc-fun-5"
(cps '(print-num (letcc q ((lambda (x) (* x (throw 4 q))) 2))))
'(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (print-num x k)))])
(let ([q (lambda (x) (k x))])
(let ([f (lambda (x k)
(let ([k (lambda (x) (k (* x x)))]) (q 4)))])
(f 2 k)))))
(test "omega-1"
(cps '((lambda (n) (print-num 7))
((lambda (x) (x x))
(lambda (y) (y y)))))
'(let ([f (lambda (n k) (print-num 7 k))])
(let ([f (lambda (x k) (x x k))])
(let ([f (lambda (y k) (y y k))])
(let ([k (lambda (x)
(let ([k (lambda (x) (halt x))]) (f x k)))])
(f f k))))))
)