An Interpreter in Continuation-Passing Style

Continuation-Passing Style (CPS) is a powerful programming style which explictly exposes the continuation as arguments of a function. The continuation can be applied inside of the function body with some values as arguments, then the control is transferred to that function instead of returning.

From the view of interpreter implementation, continuations can be implemented as a higher-order functions that is an argument to the interpreter. This function represents the next computation that we need to execute. The function (continuation) accepts one argument which is the result from previous computation.

This post presents a CPS style interpreter in Racket for lambda calculus with arithmetics. The interpreter supports call/cc and let/cc operators. Note that, let is a syntax sugar of function applications, likewise, let/cc is also a syntax sugar of call/cc: given a let/cc expression (let/cc k e), we can safely desugar it into (call/cc (lambda (k) e)).

The language we implemented supports basic arithmetic operations, anonymous functions lambda, function applications, and local identifier binding syntax let. And of course, it also supports call/cc and let/cc.

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

We make some some program for testing:

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