(define-library (csc ir2)
  (export
    %apply
    %branch
    %closure
    %fix
    %primitive
    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-primitive
    primitive-arguments
    primitive-continuation
    primitive-operation
    primitive-results
    primitive?

    ; 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)
          (only (csc match)
            define-match-record-type
            match))
  (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.


    ; A primitive encodes one of a number of primitive operations.
    ; Each operation takes a number of arguments,
    ; and binds some number of result variables.
    ; The known primitives are listed below, along with their arity.
    ;   - alloc: size -> result
    ;   - peek: pointer * offset -> result
    ;   - poke: word * pointer * offset -> ()
    (define-match-record-type <primitive>
      (make-primitive operation arguments results continuation)
      primitive?
      %primitive
      (operation primitive-operation)
      (arguments primitive-arguments)
      (results primitive-results)
      (continuation primitive-continuation))


    ; Branches depending on the given atom.
    ; If it is true, continue with continuation true.
    ; If false, continue with continuation false.
    (define-match-record-type <branch>
      (make-branch atom true false)
      branch?
      %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-match-record-type <apply>
      (make-apply procedure arguments)
      apply?
      %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-match-record-type <closure>
      (make-closure name arguments rest body)
      closure?
      %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-match-record-type <fix>
      (make-fix functions body)
      fix?
      %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)
      (match (cons x y)
        (((% %primitive x-oper x-args x-res x-cont) . (% %primitive y-oper y-args y-res y-cont))
          (and (symbol=? x-oper y-oper)
               (= (length x-args) (length y-args))
               (all ir1=? x-args y-args)
               (= (length x-res) (length y-res))
               (all ir1=? x-res y-res)
               (ir2=? x-cont y-cont)))
        (((% %branch x-atom x-true x-false) . (% %branch y-atom y-true y-false))
          (and (ir1=? x-atom y-atom)
               (ir2=? x-true y-true)
               (ir2=? x-false y-false)))
        (((% %apply x-proc x-args) . (% %apply y-proc y-args))
          (and (ir1=? x-proc y-proc)
               (= (length x-args) (length y-args))
               (all ir1=? x-args y-args)))
        (((% %fix x-funs x-body) . (% %fix y-funs y-body))
          (and (= (length x-funs) (length y-funs))
               (all closure=? x-funs y-funs)
               (ir2=? x-body y-body)))
        (_ #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))))))