(define-library (csc cps)
  (export
    ir1->ir2)
  (import (scheme base)
          (only (csc gensym) gensym)
          (only (csc hash-map)
            insert
            make-map
            merge)
          (only (csc ir1)
            %call
            %define-syntax
            %if
            %lambda
            %letrec
            %lexical-set
            %library-define
            %sequence
            call?
            constant?
            if?
            lambda?
            letrec?
            lexical-ref?
            lexical-set?
            library-define?
            library-ref?
            make-call
            make-constant
            make-lambda
            make-lexical-ref
            make-lexical-set
            make-sequence
            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)
          (only (csc match) match))
  (begin


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


    (define (collect-functions-and-variables expr)
      (match expr
        ((% %letrec _ names gensyms vals _)
          (loop for name in names
                for gensym in gensyms
                for value in vals
                if (lambda? value)
                  collect (match value
                            ((% %lambda args rest body)
                              (define continuation (new-ref))
                              (make-closure
                                (make-lexical-ref name gensym)
                                (cons continuation args)
                                rest
                                (ir1->ir2
                                  body
                                  (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)
      (match expr
        (_ (when (or (constant? expr)
                     (lexical-ref? expr)
                     (library-ref? expr)))
          (continuation expr))
        ((% %lexical-set ref arg)
          (ir1->ir2
            arg
            (lambda (val)
              (make-update ref val (continuation (make-constant #f))))))
        ((% %library-define ref arg)
          (ir1->ir2
            arg
            (lambda (val)
              (make-update ref val (continuation (make-constant #f))))))
        ((% %define-syntax _ _)
          ; no-op
          (continuation (make-constant #f)))
        ((% %if test consequent alternate)
          (ir1->ir2
            test
            (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
                    consequent
                    (lambda (result)
                      (make-apply continuation-ref (list result))))
                  (ir1->ir2
                    alternate
                    (lambda (result)
                      (make-apply continuation-ref (list result)))))))))
        ((% %call proc args)
          (define return-address (new-ref))
          (define result (new-ref))
          (make-fix
            (list (make-closure return-address (list result) #f (continuation result)))
            (ir1->ir2
              proc
              (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 args))
                           (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 head tail)
          (ir1->ir2
            head
            (lambda (x)
              (ir1->ir2
                tail
                continuation))))
        ((% %lambda args rest body)
          (define f (new-ref))
          (define k (new-ref))
          (make-fix
            (list
              (make-closure f (cons k args) rest
                (ir1->ir2
                  body
                  (lambda (ret)
                    (make-apply k (list ret))))))
            (continuation f)))
        ((% %letrec in-order? _ _ _ body)
          (define-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 in-order?
                (loop for name in (reverse variable-names)
                      for value in (reverse variable-values)
                      for expr = (make-call
                                   (make-lambda
                                     (list name)
                                     #f
                                     body)
                                   (list value))
                               then (make-call
                                      (make-lambda
                                        (list name)
                                        #f
                                        expr)
                                      (list value))
                      finally (return expr))
                (make-call
                  (make-lambda
                    variable-names
                    #f
                    body)
                  variable-values))
              continuation)))
        (_ (error "unexpected type in ir1->ir2" expr))))))