LiSP Ch.5: CPS conversion

gistfile1.scm

;; outlet: https://github.com/jlongster/outlet

(define-macro (case c . variants)
  `(cond
    ,@(map (lambda (exp)
             (if (== (car exp) 'else)
                 exp
                 `((list-find ',(car exp) ,c)
                   ,@(cdr exp))))
           variants)))

(define (atom? exp)
  (or (number? exp)
      (string? exp)
      (boolean? exp)
      (null? exp)
      (symbol? exp)))

(define (cps-quote data)
  (lambda (k)
    (k `(quote ,data))))

(define (cps-set! var form)
  (lambda (k)
    ((cps form)
     (lambda (a)
       (k `(set! ,var ,a))))))

(define (cps-if bool form1 form2)
  (lambda (k)
    ((cps bool)
     (lambda (b)
       `(if ,b
            ,((cps form1) k)
            ,((cps form2) k))))))

(define (cps-begin e)
  (if (list? e)
      (if (list? (cdr e))
          (let ((v (gensym)))
            (lambda (k)
              ((cps-begin (cdr e))
               (lambda (b)
                 ((cps (car e))
                  (lambda (a)
                    (k `((lambda (,v) ,b) ,a))))))))
          (cps (car e)))
      (cps '())))

(define (cps-application e)
  (lambda (k)
    (if (list-find primitives e)
        ((cps-terms (cdr e))
         (lambda (t)
           (k `(,(car e) ,@t))))
        ((cps-terms e)
         (lambda (t)
           (let ((d (gensym)))
             `(,(car t) (lambda (,d) ,(k d)) ,@(cdr t))))))))

(define (cps-terms e)
  (if (list? e)
      (lambda (k)
        ((cps (car e))
         (lambda (a)
           ((cps-terms (cdr e))
            (lambda (as)
              (k (cons a as)))))))
      (lambda (k) (k '()))))

(define (cps-abstraction vars body)
  (lambda (k)
    (k (let ((c (gensym)))
         `(lambda (,c ,@vars)
            ,((cps body)
              (lambda (a) `(,c ,a))))))))

(define primitives '(cons car cdr list))

(define (cps e)
  (if (atom? e)
      (lambda (k) (k e))
      (case (car e)
        ((quote) (cps-quote (cadr e)))
        ((if) (cps-if (cadr e) (caddr e) (car (cdddr e))))
        ((begin) (cps-begin (cdr e)))
        ((set!) (cps-set! (cadr e) (caddr e)))
        ((lambda) (cps-abstraction (cadr e) (caddr e)))
        (else (cps-application e)))))

(pp ((cps '(lambda (bar baz)
             (foo (baz 1)))) (lambda (r) r)))
;; ->
;; (lambda
;;  (o1 bar baz)
;;  (baz
;;   (lambda
;;    (o2)
;;    (foo (lambda (o3) (o1 o3)) o2))
;;   1))