(define-library (csc ir2)
  (export
    apply-arguments
    apply-procedure
    apply?
    atom-continuation
    atom-expression
    atom?
    branch-atom
    branch-false
    branch-true
    branch?
    call-closure-args
    call-closure-closure
    call-closure?
    closure-arguments
    closure-body
    closure-name
    closure-rest
    closure?
    fix-body
    fix-functions
    fix?
    ir2=?
    kargs-expression
    kargs-refs
    kargs?
    klabel-expression
    klabel?
    ktail?
    make-apply
    make-atom
    make-branch
    make-call-closure
    make-closure
    make-fix
    make-kargs
    make-klabel
    make-ktail
    make-update
    update-atom
    update-continuation
    update-ref

    ; Re-exports from IR1.
    constant-expression
    constant?
    lexical-ref-gensym
    lexical-ref-name
    lexical-ref?
    library-ref-library
    library-ref-name
    library-ref?
    make-constant
    make-lexical-ref
    lexical-set-expression
    lexical-set-ref
    lexical-set?
    make-lexical-set
    make-library-ref)
  (import (scheme base)
          (only (csc ir1)
            constant?
            ir1=?
            lexical-ref-gensym
            lexical-ref-name
            lexical-ref?
            lexical-set-expression
            lexical-set-ref
            lexical-set?
            library-ref-library
            library-ref-name
            library-ref?
            make-constant
            make-lexical-ref
            make-lexical-set
            make-library-ref)
          (only (csc list) all)
          (only (csc loop)
            loop
            return))
  (begin
    ; This library defines the intermediate representation IR2.
    ; It's CPS time bitch.

    ; CPS atom:
    ;   An atom is a value that can be computed immediately without
    ;   any subexpressions.
    ;   Atoms consist of
    ;     - constant,
    ;     - lexical-ref,
    ;     - or library-ref

    ; CPS expressions:
    ;   CPS expressions are similar to IR1 expressions,
    ;   but constrained not to have any subexpressions except atoms.
    ;   And they take a continuation.


    ; Modifies a library or lexically bound variable to the given atom.
    (define-record-type <update>
      (make-update ref atom continuation)
      update?
      (ref update-ref)
      (atom update-atom)
      (continuation update-continuation))


    ; Branches depending on the given atom.
    ; If it is true, continue with continuation true.
    ; If false, continue with continuation false.
    (define-record-type <branch>
      (make-branch atom true false)
      branch?
      (atom branch-atom)
      (true branch-true)
      (false branch-false))


    ; Applies a procedure to a list of arguments. Apply does not take a
    ; continuation. Instead the continuation will be passed as the first
    ; argument to the function.
    (define-record-type <apply>
      (make-apply procedure arguments)
      apply?
      (procedure apply-procedure)
      (arguments apply-arguments))


    ; A procedure. All closures are allocated in a fix expression. A closure
    ; does not take a continuation. Instead, the procedure will accept the
    ; continuation as an argument.
    (define-record-type <closure>
      (make-closure name arguments rest body)
      closure?
      (name closure-name)
      (arguments closure-arguments)
      (rest closure-rest)
      (body closure-body))


    ; Defines a list of mutually recursive procedures.
    ; Functions is a list of closures, and body is an expression.
    (define-record-type <fix>
      (make-fix functions body)
      fix?
      (functions fix-functions)
      (body fix-body))


    (define (closure=? x y)
      (let ((x-args (closure-arguments x))
            (x-rest (closure-rest x))
            (y-args (closure-arguments y))
            (y-rest (closure-rest y)))
        (and (ir1=? (closure-name x) (closure-name y))
             (= (length x-args) (length y-args))
             (all ir1=? x-args y-args)
             (or (and (not x-rest) (not y-rest))
                 (and x-rest y-rest (ir1=? x-rest y-rest)))
             (ir2=? (closure-body x) (closure-body y)))))


    (define (ir2=?-sametype x y)
      (cond
        ((and (update? x) (update? y))
          (and (ir1=? (update-ref x) (update-ref y))
               (ir1=? (update-atom x) (update-atom y))
               (ir2=? (update-continuation x) (update-continuation y))))
        ((and (branch? x) (branch? y))
          (and (ir1=? (branch-atom x) (branch-atom y))
               (ir2=? (branch-true x) (branch-true y))
               (ir2=? (branch-false x) (branch-false y))))
        ((and (apply? x) (apply? y))
          (let ((x-args (apply-arguments x))
                (y-args (apply-arguments y)))
            (and (ir1=? (apply-procedure x) (apply-procedure y))
                 (= (length x-args) (length y-args))
                 (all ir1=? x-args y-args))))
        ((and (fix? x) (fix? y))
          (let ((x-funs (fix-functions x))
                (y-funs (fix-functions y)))
            (and (= (length x-funs) (length y-funs))
                 (all closure=? x-funs y-funs)
                 (ir2=? (fix-body x) (fix-body y)))))
        (else #f)))


    (define (ir2=? x y)
      (cond
        ((ir2=?-sametype x y) #t)
        ((and (ir2=?-sametype x x) (ir2=?-sametype y y))
          #f)
        (else (error "One or more arguments has a type unknown to ir2=?" x y))))))