(define-library (csc ir2)
  (export
    atom-continuation
    atom-expression
    atom?
    branch-atom
    branch-false
    branch-true
    branch?
    call-closure-args
    call-closure-closure
    call-closure?
    closure-cases
    closure-continuation
    closure?
    ir2=?
    kargs-expression
    kargs-refs
    kargs?
    klabel-expression
    klabel?
    ktail?
    lambda-args-kargs
    lambda-args-nargs
    lambda-args-rest
    lambda-args?
    make-atom
    make-branch
    make-call-closure
    make-closure
    make-kargs
    make-klabel
    make-ktail
    make-lambda-args
    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.

    ; CPS continuations
    ;   There are a few continuations.
    ;   Continuations are identified by an integer ID into the
    ;   continuation map.
    ;   Guile calls this map the "continuation soup".


    ; CPS expressions.


    ; An atom consists of an atom and a continuation.
    (define-record-type <atom>
      (make-atom expression continuation)
      atom?
      (expression atom-expression)
      (continuation atom-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))


    ; Evaluates 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))


    ; Calls the given closure. Closure is an atom, and args is a list of atoms.
    (define-record-type <call-closure>
      (make-call-closure closure args continuation)
      call-closure?
      (closure call-closure-closure)
      (args call-closure-args)
      (continuation call-closure-continuation))


    ; One branch of a case-lambda. nargs encodes the number of required
    ; arguments, and rest is a boolean indicating whether the function takes a
    ; rest parameter. kargs is a continuation ID pointing to a
    ; kargs continuation.
    (define-record-type <lambda-args>
      (make-lambda-args nargs rest kargs)
      lambda-args?
      (nargs lambda-args-nargs)
      (rest lambda-args-rest)
      (kargs lambda-args-kargs))


    ; A lambda expression.
    (define-record-type <closure>
      (make-closure cases continuation)
      closure?
      (cases closure-cases)
      (continuation closure-continuation))


    ; CPS continuations.


    ; The tail continuation.
    (define-record-type <ktail>
      (make-ktail)
      ktail?)


    ; Binds the incoming values to the given lexically-bound variables
    ; and then evaluates expression.
    (define-record-type <kargs>
      (make-kargs refs expression)
      kargs?
      (refs kargs-refs)
      (expression kargs-expression))


    ; Ignores any incoming values and evaluates the given expression.
    (define-record-type <klabel>
      (make-klabel expression)
      klabel?
      (expression klabel-expression))


    (define (ir2=?-sametype x y)
      (cond
        ((and (atom? x) (atom? y))
          (and (ir1=? (atom-expression x) (atom-expression y))
               (= (atom-continuation x) (atom-continuation y))))
        ((and (update? x) (update? y))
          (and (ir1=? (update-ref x) (update-ref y))
               (ir1=? (update-atom x) (update-atom y))
               (= (update-continuation x) (update-continuation y))))
        ((and (branch? x) (branch? y))
          (and (ir1=? (branch-atom x) (branch-atom y))
               (= (branch-true x) (branch-true y))
               (= (branch-false x) (branch-false y))))
        ((and (call-closure? x) (call-closure? y))
          (let ((x-args (call-closure-args x))
                (y-args (call-closure-args y)))
            (and (ir1=? (call-closure-closure x) (call-closure-closure y))
                 (= (length x-args) (length y-args))
                 (all (lambda (x) x) (map ir1=? x-args y-args))
                 (= (call-closure-continuation x) (call-closure-continuation y)))))
        ((and (lambda-args? x) (lambda-args? y))
          (and (= (lambda-args-nargs x) (lambda-args-nargs y))
               (boolean=? (lambda-args-rest x) (lambda-args-rest y))
               (= (lambda-args-kargs x) (lambda-args-kargs y))))
        ((and (closure? x) (closure? y))
          (let ((x-cases (closure-cases x))
                (y-cases (closure-cases y)))
            (and (= (length x-cases) (length y-cases))
                 (all (lambda (x) x) (map ir2=? x-cases y-cases))
                 (= (closure-continuation x) (closure-continuation y)))))
        ((and (ktail? x) (ktail? y)) #t)
        ((and (kargs? x) (kargs? y))
          (let ((x-refs (kargs-refs x))
                (y-refs (kargs-refs y)))
            (and (= (length x-refs) (length y-refs))
                 (all (lambda (x) x) (map ir1=? x-refs y-refs))
                 (ir2=? (kargs-expression x) (kargs-expression y)))))
        ((and (klabel? x) (klabel? y))
          (ir2=? (klabel-expression x) (klabel-expression 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))))))