(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-body
            lambda-case-alternate
            lambda-case-arguments
            lambda-case-body
            lambda-case-gensyms
            lambda-case-rest
            lambda?
            letrec-expression
            letrec-gensyms
            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-lambda-case
            make-lexical-ref
            make-lexical-set
            make-sequence
            sequence-head
            sequence-tail
            sequence?)
          (only (csc ir2)
            make-atom
            make-branch
            make-call-closure
            make-closure
            make-kargs
            make-klabel
            make-ktail
            make-lambda-args
            make-update)
          (only (csc loop)
            loop
            return)
          (scheme base))
  (begin


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


    (define (to-cps expr continuation add-continuation)
      (cond
        ((or (constant? expr)
             (lexical-ref? expr)
             (library-ref? expr))
          (make-atom expr continuation))
        ((lexical-set? expr)
          (let ((ref (new-ref)))
            (to-cps
              (lexical-set-expression expr)
              (add-continuation
                (make-kargs (list ref)
                  (make-update (lexical-set-ref expr) ref continuation)))
              add-continuation)))
        ((library-define? expr)
          (let ((ref (new-ref)))
            (to-cps
              (library-define-expression expr)
              (add-continuation
                (make-kargs (list ref)
                  (make-update (library-define-ref expr) ref continuation)))
              add-continuation)))
        ((define-syntax? expr)
          ; no-op
          (make-atom (make-constant #f) continuation))
        ((if? expr)
          (let* ((true-id (add-continuation
                            (make-klabel
                              (to-cps (if-consequent expr) continuation add-continuation))))
                 (false-id (add-continuation
                             (make-klabel
                               (to-cps (if-alternate expr) continuation add-continuation))))
                 (test-ref (new-ref))
                 (branch-id (add-continuation
                              (make-kargs (list test-ref)
                                (make-branch test-ref true-id false-id)))))
            (to-cps (if-test expr) branch-id add-continuation)))
        ((call? expr)
          ; Technically the order of evaluation is unspecified. We evaluate
          ; expressions left to right.
          (loop with terms = (cons (call-procedure expr) (call-arguments expr))
                with temps = (map (lambda (x) (new-ref)) terms)
                with expr = (make-call-closure (car temps) (cdr temps) continuation)
                for term in (reverse terms)
                for temp in (reverse temps)
                do (set! expr (to-cps term
                                (add-continuation
                                  (make-kargs (list temp) expr))
                                add-continuation))
                finally (return expr)))
        ((sequence? expr)
          (to-cps
            (sequence-head expr)
            (add-continuation
              (make-klabel
                (to-cps (sequence-tail expr) continuation add-continuation)))
            add-continuation))
        ((lambda? expr)
          (make-closure
            (loop with tail = (add-continuation (make-ktail))
                  for lambda-case = (lambda-body expr) then (lambda-case-alternate lambda-case)
                  while lambda-case
                  collect (let ((args (lambda-case-arguments lambda-case))
                                (rest (lambda-case-rest lambda-case)))
                            (make-lambda-args
                              (length args)
                              (not (not rest))
                              (add-continuation
                                (make-kargs (map make-lexical-ref
                                              (append args (list rest))
                                              (lambda-case-gensyms lambda-case))
                                  (to-cps (lambda-case-body lambda-case) tail add-continuation))))))
            continuation))
        ((letrec? expr)
          ; We re-write a letrec into a corresponding lambda form.
          (let ((names (letrec-names expr))
                (gensyms (letrec-gensyms expr)))
            (to-cps
              (make-call
                (make-lambda
                  (make-lambda-case
                    names
                    #f
                    gensyms
                    (make-sequence
                      (loop for name in names
                            for gensym in gensyms
                            for value in (letrec-values expr)
                            for set = (make-lexical-set (make-lexical-ref name gensym) value)
                            for body = set then (make-sequence body set)
                            finally (return body))
                      (letrec-expression expr))
                    #f))
                (map (lambda (x) (make-constant #f)) names))
              continuation
              add-continuation)))
        (else (error "unexpected type in to-cps" expr))))


    ; Returns a map from integers to CPS continuations.
    ; By convention the continuation at key 0 is the entrypoint.
    (define (ir1->ir2 program)
      (define current-continuation-id 0)
      (define soup (make-map (lambda (x) x) <))
      (define (add-continuation continuation)
        (set! current-continuation-id (+ 1 current-continuation-id))
        (set! soup (insert soup
                     current-continuation-id
                     continuation))
        current-continuation-id)
      (define ktail (add-continuation (make-ktail)))
      (define entrypoint (to-cps program ktail add-continuation))
      (insert soup 0 (make-klabel entrypoint)))))