cps.scm

(use srfi-1)
(use util.match)

(define id-cont
  `(lambda (x) x))

(define (translate term env cont)
  (match term
    ((? integer? term)
     `(,cont ,term))
    ((? string? term)
     `(,cont ,term))
    ((? symbol? term)
     `(,cont ,(cdr (assoc term env))))
    (('lambda (v) e)
     (let* ((v* (gensym "v"))
            (k* (gensym "k")))
       `(,cont
         (lambda (,v*)
           (lambda (,k*)
             ,(translate e (alist-cons v v* env) k*))))))
    (('shift v e)
     (let* ((v* (gensym "v"))
            (k* (gensym "k"))
            (kp `(lambda (,v*)
                   (lambda (,k*)
                     (,k* (,cont ,v*))))))
       (translate e (alist-cons v kp env) id-cont)))
    (('reset e)
     `(,cont ,(translate e env id-cont)))
    ((e1 e2)
     (let* ((f* (gensym "f"))
            (a* (gensym "a")))
       (translate e1 env
                  `(lambda (,f*)
                     ,(translate e2 env
                                 `(lambda (,a*)
                                    ((,f* ,a*) ,cont)))))))))

;; https://github.com/leque/Gauche-pp
(use pp)
(define (eval-and-print e env)
  (let ((v (eval e env)))
    (pretty-print e :print-shared #t)
    (display ";; => ")
    (write v)
    (newline)))

(eval-and-print
 (translate '(add1 (reset (add100 (shift k (k (k 10))))))
            '(
              (add1 . (lambda (x) (lambda (k) (k (+ x 1)))))
              (add100 . (lambda (x) (lambda (k) (k (+ x 100)))))
              )
            id-cont)
 (interaction-environment))

(eval-and-print
 (translate '(((reset ((concat (shift k (lambda (x) (k x))))
                       (shift k (lambda (x) (k (i2s x))))))
               "a")
              10)
            '(
              (concat . (lambda (x)
                          (lambda (k)
                            (k (lambda (y)
                                 (lambda (k2)
                                   (k2 (string-append x y))))))))
              (i2s . (lambda (x)
                       (lambda (k)
                         (k (number->string x)))))
              )
            id-cont)
 (interaction-environment))
;; ((lambda (#0=#:f206)
;;    ((lambda (#1=#:a207)
;;       ((#0# #1#)
;;        (lambda (#2=#:f204)
;;          ((lambda (#3=#:a205) ((#2# #3#) #4=(lambda (x) x))) 10))))
;;     "a"))
;;  ((lambda (#5=#:f218)
;;     (#4#
;;      (lambda (#6=#:v222)
;;        (lambda (#7=#:k223)
;;          ((lambda (#8=#:f224) ((lambda (#9=#:a225) ((#8# #9#) #7#)) #6#))
;;           (lambda (#10=#:v220)
;;             (lambda (#11=#:k221)
;;               (#11#
;;                ((lambda (#12=#:a219)
;;                   ((#5# #12#)
;;                    (lambda (#13=#:f208)
;;                      (#4#
;;                       (lambda (#14=#:v212)
;;                         (lambda (#15=#:k213)
;;                           ((lambda (#16=#:f214)
;;                              ((lambda (#17=#:f216)
;;                                 ((lambda (#18=#:a217)
;;                                    ((#17# #18#)
;;                                     (lambda (#19=#:a215) ((#16# #19#) #15#))))
;;                                  #14#))
;;                               (lambda (x)
;;                                 (lambda (k) (k (number->string x))))))
;;                            (lambda (#20=#:v210)
;;                              (lambda (#21=#:k211)
;;                                (#21#
;;                                 ((lambda (#22=#:a209) ((#13# #22#) #4#))
;;                                  #20#)))))))))))
;;                 #10#)))))))))
;;   (lambda (x)
;;     (lambda (k) (k (lambda (y) (lambda (k2) (k2 (string-append x y)))))))))
;; ;; => "a10"