CPS変換して全部tail callにしてsetTimeoutでスタックの深さを節約。すごく適当そして途中。

input.scm

;;you can use native macro system!
(define-macro (defn name+args . body)
  `(define ,(car name+args) (lambda ,(cdr name+args) ,@body)))

;;javascript macro
(javascript

  (define z 5)
  (defn (foo x y) (add x y))
  (|console.log| (foo z 6))

)

output-helper.js

var add = function (kont, x, y) {
    kont(x + y);
};
var identity = function (x) {
    return x
};
var test = function (k1, k2, b) {
    if (b) k1();
    else k2();
}

output.js

   var z = 5;
   var foo = (function (kont, x, y) {
       setTimeout(function () {
           (function (G47) {
               setTimeout(function () {
                   (function (G48) {
                       setTimeout(function () {
                           (function (G49) {
                               setTimeout(function () {
                                   G47(kont, G48, G49)
                               }, 0)
                           })(y)
                       }, 0)
                   })(x)
               }, 0)
           })(add)
       }, 0)
   });
   setTimeout(function () {
       (function (G50) {
           setTimeout(function () {
               (function (G52) {
                   setTimeout(function () {
                       (function (G53) {
                           setTimeout(function () {
                               (function (G54) {
                                   setTimeout(function () {
                                       G52((function (G51) {
                                           setTimeout(function () {
                                               G50(identity, G51)
                                           }, 0)
                                       }), G53, G54)
                                   }, 0)
                               })(6)
                           }, 0)
                       })(z)
                   }, 0)
               })(foo)
           }, 0)
       })(console.log)
   }, 0)

schip.scm

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

;;CPS Conversion
;;http://repository.readscheme.org/ftp/papers/orbit-thesis.pdf

(define (convert-arguments expr final-call)
  (match expr
         [() final-call]
         [(arg rest ...)
          (let ([sym (gensym)])
            (convert arg `(lambda (,sym)
                            ,(convert-arguments rest
                                                (append final-call `(,sym))))))]))

(define (convert expr cont)
  (match expr
         [('lambda (vars ...) body)
          (let ([k 'kont])
            `(tail (,cont (lambda (,k ,@vars) ,(convert body k)))))]
         [('lambda (vars ...) body ...)
          (let ([k 'kont])
            `(tail (,cont (lambda (,k ,@vars) ,(convert `(begin ,@body) k)))))]

         [('if pred then otherwise)
          (convert pred
                   `(lambda (v)
                      ((lambda (j)
                         (test (lambda () ,(convert then 'j))
                               (lambda () ,(convert otherwise 'j))
                               v))
                       ,cont)))]

         [('begin e1) (convert e1 cont)]
         [('begin e1 rest ...)
          (convert e1 `(lambda (_) (convert `(begin ,@rest) cont)))]

         [('call/cc ('lambda (cc) body ...))
          `((lambda (,cc) ,(convert `(begin ,@body) 'null))
            (lambda (_ result) (,cont result)))]

         [(proc arguments ...)
          (let ([sym (gensym)])
            (convert proc
                     `(lambda (,sym)
                        ,(convert-arguments arguments
                                            `(,sym ,cont)))))]

         [else `(tail (,cont ,expr))]))


(define (convert-all code)
  (if (null? code) '()
      (let ([sexp (macroexpand (car code))]
            [next (cdr code)])
        (match sexp
               [('define sym val)
                (cons `(define ,sym ,(convert val 'identity))
                      (convert-all next))]
               [else
                (cons (convert sexp 'identity)
                      (convert-all next))]))))

(define (schip-atom? x)
  (or (number? x)
      (symbol? x)
      (string? x)))

(define (js-flatten x)
  (print x)
  (string-append " "
                 (cond
                  [(symbol? x) (symbol->string x)]
                  [(null? x) ""]
                  [(pair? x) (string-append (js-flatten (car x))
                                            (js-flatten (cdr x)))]
                  [(string? x) x]
                  [else (format "~S" x)])))

(define (inject-sepalator-symbol xs sym)
  (drop-right (fold-right (lambda [x acc]
                            (cons x (cons sym acc))) '() xs) 1))

(print (inject-sepalator-symbol '(1 2 3 4 5) '|,|))

(define (schip->js code)
  (if (null? code) '()
      (let ([sexp (car code)]
            [next (cdr code)])
        (cons
         (match sexp
                [('define sym val)
                 `(var ,sym = ,(schip->js (list val)) |;|)]

                [('if pred then else)
                 `(if |(| ,(schip->js (list pred)) |)| |{|
                      ,(schip->js (list then)) |;|
                      |}| else |{|
                      ,(schip->js (list else)) |;|
                      |}|)]

                [('lambda params body)
                 `(|(| function |(| ,(inject-sepalator-symbol (map symbol->string params) '|,|) |)| |{|
                   ,(schip->js (list body))
                   |}| |)|)]

                [('tail (f e ...))
                 (if (eq? f 'identity)
                     `(,@(schip->js e))
                     `(setTimeout |(| function |() {|
                                  ,(schip->js (list f)) |(| ,@(inject-sepalator-symbol
                                                               (map (^e (schip->js (list e))) e)
                                                               '|,|) |)|
                                                               |}, 0)|))]
                [(f e ...)
                 (if (eq? f 'identity)
                     `(,@(schip->js e))
                     `(,(schip->js (list f)) |(| ,@(inject-sepalator-symbol
                                                    (map (^e (schip->js (list e))) e)
                                                    '|,|) |)|))]
                [#t `(true)]
                [#f `(false)]
                [else
                 `(,sexp)]) (schip->js next)))))

;;CPS-converted primitives
(define-module schip-env
  (export-all)
  (define (test k1 k2 b) (if b (k1) (k2)))
  (define (add cont x y)
    (cont (+ x y)))
  (define (subtract cont x y)
    (cont (- x y))))

;;Schip program
(define test-programs
  '(
    ((lambda (x) (add x x)) 5)
    (if #f 1000 -1000)
    (if #t (add 2 3) 100)
    ((lambda (x y) (add x y)) 4 5)))

(define-macro (defn name+args . body)
  `(define ,(car name+args) (lambda ,(cdr name+args) ,@body)))

(define-macro (javascript . scheme)
  (let* ([cps (convert-all scheme)]
         [js- (schip->js cps)]
         [js  (js-flatten js-)])
    js))

(print (javascript
        (define z 5)
        (defn (foo x y) (add x y))
        (|console.log| (foo z 6))
        (|console.log| (add 2 (call/cc (lambda (cc) (cc 3)))))))


(define (test-convert . _)
  (map (lambda [sexp]
         (let ([cps (convert sexp 'print)])
           (print (tree->format-string cps))
           (eval cps (find-module 'schip-env))))
       test-programs))


;;debug
;;http://practical-scheme.net/wiliki/wiliki.cgi?Gauche:PrettyPrint
(define (tree->format-string tree)
  (define indent 2)
  (define (insert-space n)
    (display (make-string n #\space)))
  (define (format-one-list t n)
    (display "(")
    (let loop ((l t))
      (cond ((null? l) (display ")"))
            ((list? (car l))
             (format-one-list (car l) (+ n indent))
             (unless (null? (cdr l)) (newline) (insert-space n))
             (loop (cdr l)))
            (else
             (write (car l))
             (cond ((null? (cdr l)))
                   ((list? (cadr l)) (newline) (insert-space n))
                   (else (display " ")))
             (loop (cdr l))))))
  (with-output-to-string
    (cut format-one-list tree indent)))

おそらく末尾じゃないものまでCPSにしなくていい