(define-library (csc cps)
  (export
    ir1->ir2)
  (import (only (csc gensym) gensym)
          (only (csc hash-map)
            insert
            make-map
            merge)
          (only (csc ir1)
            call-arguments
            call-procedure
            call?
            constant?
            define-syntax?
            if-alternate
            if-consequent
            if-test
            if?
            lambda-arguments
            lambda-body
            lambda-rest
            lambda?
            letrec-expression
            letrec-gensyms
            letrec-in-order?
            letrec-names
            letrec-values
            letrec?
            lexical-ref?
            lexical-set-expression
            lexical-set-ref
            lexical-set?
            library-define-expression
            library-define-ref
            library-define?
            library-ref?
            make-call
            make-constant
            make-lambda
            make-lexical-ref
            make-lexical-set
            make-sequence
            sequence-head
            sequence-tail
            sequence?)
          (only (csc ir2)
            make-apply
            make-atom
            make-branch
            make-call-closure
            make-closure
            make-fix
            make-kargs
            make-klabel
            make-ktail
            make-update)
          (only (csc loop)
            loop
            return)
          (scheme base))
  (begin


    (define (new-ref)
      (make-lexical-ref 'generated-symbol (gensym)))


    (define (collect-functions-and-variables expr)
      (loop for name in (letrec-names expr)
            for gensym in (letrec-gensyms expr)
            for value in (letrec-values expr)
            if (lambda? value)
              collect (let ((continuation (new-ref)))
                        (make-closure
                          (make-lexical-ref name gensym)
                          (cons continuation (lambda-arguments value))
                          (lambda-rest value)
                          (ir1->ir2
                            (lambda-body value)
                            (lambda (z)
                              (make-apply continuation (list z))))))
                      into functions
            else
              collect (make-lexical-ref name gensym) into variable-names
              and collect value into variable-values
            finally (return (values functions variable-names variable-values))))


    (define (ir1->ir2 expr continuation)
      (cond
        ((or (constant? expr)
             (lexical-ref? expr)
             (library-ref? expr))
          (continuation expr))
        ((lexical-set? expr)
          (ir1->ir2
            (lexical-set-expression expr)
            (lambda (val)
              (make-update (lexical-set-ref expr) val (continuation (make-constant #f))))))
        ((library-define? expr)
          (ir1->ir2
            (library-define-expression expr)
            (lambda (val)
              (make-update (library-define-ref expr) val (continuation (make-constant #f))))))
        ((define-syntax? expr)
          ; no-op
          (continuation (make-constant #f)))
        ((if? expr)
          (ir1->ir2
            (if-test expr)
            (lambda (val)
              (define continuation-ref (new-ref))
              (define result-ref (new-ref))
              (make-fix
                (list (make-closure continuation-ref (list result-ref) #f
                        (continuation result-ref)))
                (make-branch val
                  (ir1->ir2
                    (if-consequent expr)
                    (lambda (result)
                      (make-apply continuation-ref (list result))))
                  (ir1->ir2
                    (if-alternate expr)
                    (lambda (result)
                      (make-apply continuation-ref (list result)))))))))
        ((call? expr)
          (let ((return-address (new-ref))
                (result (new-ref)))
            (make-fix
              (list (make-closure return-address (list result) #f (continuation result)))
              (ir1->ir2
                (call-procedure expr)
                (lambda (f)
                  ; Technically the order of evaluation is unspecified.
                  ; We evaluate expressions left to right.
                  ;
                  ; I would use the loop macro, but it mutates the loop
                  ; variables which plays badly with building a lambda.
                  (let loop ((args (reverse (call-arguments expr)))
                             (exprs (lambda (vals)
                                      (make-apply f (cons return-address (reverse vals))))))
                    (if (null? args)
                      (exprs '())
                      (loop (cdr args)
                            (lambda (vals)
                              (ir1->ir2
                                (car args)
                                (lambda (val)
                                  (exprs (cons val vals)))))))))))))
        ((sequence? expr)
          (ir1->ir2
            (sequence-head expr)
            (lambda (x)
              (ir1->ir2
                (sequence-tail expr)
                continuation))))
        ((lambda? expr)
          (let ((f (new-ref))
                (k (new-ref)))
            (make-fix
              (list
                (make-closure f (cons k (lambda-arguments expr)) (lambda-rest expr)
                  (ir1->ir2
                    (lambda-body expr)
                    (lambda (ret)
                      (make-apply k (list ret))))))
              (continuation f))))
        ((letrec? expr)
          (let-values (((functions variable-names variable-values) (collect-functions-and-variables expr)))
            (make-fix functions
              (ir1->ir2
                ; We re-write a letrec into a corresponding lambda form.
                (if (letrec-in-order? expr)
                  (loop for name in (reverse variable-names)
                        for value in (reverse variable-values)
                        for expr = (make-call
                                     (make-lambda
                                       (list name)
                                       #f
                                       (letrec-expression expr))
                                     (list value))
                                 then (make-call
                                        (make-lambda
                                          (list name)
                                          #f
                                          expr)
                                        (list value))
                        finally (return expr))
                  (make-call
                    (make-lambda
                      variable-names
                      #f
                      (letrec-expression expr))
                    variable-values))
                continuation))))
        (else (error "unexpected type in ir1->ir2" expr))))))