An Interpreter in Continuation-Passing-Style

Continuation Passing Style (CPS) is a powerful programming style which explictly expose the continuation as the argument to function. The continuation can be applied inside of the function body with some value as argument instead of return it.

From the view of interpreter implementation, a continuation can be implemented as a function represents the next computation we need to execute. The function (continuation) accepts one argument which represents the result from previous computation.

This post shows an CPS style interpreter for lambda calculus in Racket. This interpreter also supports call/cc and let/cc operation. Note that let/cc is just a syntax sugar of call/cc: given a let/cc expression (let/cc k body ...), we can transform it to (call/cc (lambda (k) body ...)).

The language we implemented supports basic arithmetic operations, anonymous function lambda and its application, and local identifier binding let. Moreover it also supports call/cc and let/cc, then we can do some really funky things like implementing amb operator.

The syntax description of the input language is as follow:

<lam> ::= (lambda (<var>) <exp>)

<exp> ::= <var> | <number>
       |  <lam>
       |  (<exp> <exp>)
       |  (<op> <number> <number>)
       |  (let ((<var> <exp>)) <exp>)
       |  (let/cc <var> <exp>)
       |  (call/cc <lam>)

<op> ::= + | *

The interpreter:

#lang racket

(require rackunit)

(define mt-env '())
(define ext-env cons)

(define bind (lambda (name val) (cons name val)))
(define bind-name car)
(define bind-val cdr)

(define lookup
  (lambda (x env)
    (cond [(null? env) (error 'lookup "free variable")]
          [(equal? x (bind-name (car env)))
           (bind-val (car env))]
          [else (lookup x (cdr env))])))

(struct Closure (arg body env))
(struct Cont (body))

(define done (lambda (v) v))

(define cps
  (lambda (exp env k)
    (match exp
      [(? number? x) (k x)]
      [(? symbol? x) (k (lookup x env))]
      [`(+ ,l ,r)
       (cps l env
            (lambda (l-v)
              (cps r env
                   (lambda (r-v)
                     (k (+ l-v r-v))))))]
      [`(* ,l ,r)
       (cps l env
            (lambda (l-v)
              (cps r env
                   (lambda (r-v)
                     (k (* l-v r-v))))))]
      [`(lambda (,x) ,body) (k (Closure x body env))]
      [`(let (,name ,e) ,body)
       (cps e env
            (lambda (e-v)
              (cps body (ext-env (bind name e-v) env) k)))]
      [`(let/cc ,x ,body)
       (cps `(call/cc (lambda (,x) ,body)) env k)]
      [`(call/cc (lambda (,x) ,body))
       (cps body (ext-env (bind x (Cont k)) env) k)]
      [`(,fun ,arg)
       (cps fun env
            (lambda (fun-v)
              (cond [(Closure? fun-v)
                     (cps arg env
                          (lambda (arg-v)
                            (cps (Closure-body fun-v)
                                 (ext-env (bind (Closure-arg fun-v) arg-v)
                                          (Closure-env fun-v))
                    [(Cont? fun-v) (cps arg env (Cont-body fun-v))]
                    [else (error 'cps "not a function")])))])))

(define interp
  (lambda (e)
    (cps e mt-env done)))

; test

(check-equal? (interp '{+ 1 2}) 3)
(check-equal? (interp '{* 2 3}) 6)
(check-equal? (interp '{{lambda {x} {+ x x}} 3}) 6)
(check-equal? (interp '{+ 1 {let/cc k1
                              {+ 2 {+ 3 {let/cc k2
                                          {+ 4 {k1 5}}}}}}})
(check-equal? (interp '{+ 1 {let/cc k1
                              {+ 2 {+ 3 {let/cc k2
                                          {+ 4 {k2 5}}}}}}})
(check-equal? (interp '{+ 1 {call/cc {lambda {k1}
                                       {+ 2 {+ 3 {k1 4}}}}}})
(check-equal? (interp '{let {x 1} {let {y 2} {+ x y}}}) 3)