CPS conversion from Danvy and Filinksi's “Abstracting Control”

CPS.rkt

#lang racket

(struct Constant (value))
(struct Variable (name))
(struct Apply (function argument))
(struct Lambda (variable body))
(struct If (test then else))
(struct Reset (body))
(struct Shift (variable body))
(struct Call-With-Current-Continuation (function))

(define (parse s-expression)
  (match s-expression
    [(or (? integer?)
         (? boolean?))
     (Constant s-expression)]
    [(? symbol?)
     (Variable s-expression)]
    [`(λ (,(? symbol? variable)) ,body)
     (Lambda (Variable variable) (parse body))]
    [`(reset ,body)
     (Reset (parse body))]
    [`(shift ,variable ,body)
     (Shift (parse variable) (parse body))]
    [`(call-with-current-continuation ,function)
     (Call-With-Current-Continuation (parse function))]
    [`(,function ,argument)
     (Apply (parse function) (parse argument))]))

(define (unparse expression)
  (match expression
    [(Constant value)
     value]
    [(Variable name)
     name]
    [(Lambda name body)
     `(λ (,(unparse name)) ,(unparse body))]
    [(Apply function argument)
     `(,(unparse function) ,(unparse argument))]
    [(Reset body)
     `(reset ,(unparse body))]
    [(Shift variable body)
     `(shift ,(unparse variable) ,(unparse body))]
    [(Call-With-Current-Continuation function)
     `(call-with-current-continuation ,function)]))

(define (fresh prefix)
  (Variable (gensym prefix)))

(define (CPS expression)
  (match expression
    [(or (Constant _)
         (Variable _))
     (λ (k)
       (k expression))]
    [(Apply function argument)
     (λ (k)
       ((CPS function) (λ (function-value)
                         ((CPS argument) (λ (argument-value)
                                           (Apply (Apply function-value
                                                         argument-value)
                                                  (Lambda (Variable 't)
                                                    (k (Variable 't)))))))))]
    [(If test then else)
     (λ (k)
       ((CPS test) (λ (test-value)
                     (If test-value
                         ((CPS then) k)
                         ((CPS else) k)))))]
    [(Lambda variable body)
     (define k-variable (fresh 'k))
     (λ (k)
       (k (Lambda variable
            (Lambda k-variable
              ((CPS body) (λ (a)
                            (Apply k-variable a)))))))]
    [(Call-With-Current-Continuation function)
     (λ (k)
       (Apply ((CPS function) k)
              (Lambda (Variable 'a)
                (Lambda (Variable 'k)
                  (k (Variable 'a))))))]
    [(Reset body)
     (λ (k)
       (k ((CPS body) identity)))]
    [(Shift variable body)
     (define value-variable (fresh 'v))
     (define k-variable (fresh 'k))
     (λ (k)
       (Apply (Lambda variable
                ((CPS body) identity))
              (Lambda value-variable
                (Lambda k-variable
                  (Apply k-variable (k value-variable))))))]))

(define (do-CPS expression)
  ((CPS expression) identity))

(pretty-print (unparse (do-CPS (parse '(λ (f)
                                         (λ (xs)
                                           (call-with-current-continuation (λ (k)
                                                                             (k (f xs))))))))))