{
: collect_free_variables
: lift_functions
: collect_constants
}

Where

Define (collect_free_variables expr)
    Let SET (SEARCH.SET STRING.compare)
    Let MAP
        (SEARCH.MAP
            STRING.compare
            Func {var} var.name)
    In
    Define (insert_each env depth vars)
        (LIST.reduce vars env
            Func {env var} (MAP.insert env {: name var : depth}))
    Define (maybe_insert env depth free name)
        Match (MAP.search env name)
        | 'just.var
            If [var.depth < depth]
                (SET.insert free name)
                free
        | 'nothing
            (die
                (STRING.concat
                    [Right "Variable \"" & name & "\" is not bound." & 'nil]))
        ;
    In
    Define (pure x)
        Func {_ _ free rec} {x free}
    Define (lift1 m1 f)
        Func {env depth free rec}
            Let {x1 free} (m1 env depth free rec)
            In
            {(f x1) free}
    Define (lift2 m1 m2 f)
        Func {env depth free rec}
            Let {x1 free} (m1 env depth free rec)
            In
            Let {x2 free} (m2 env depth free rec)
            In
            {(f x1 x2) free}
    Define (lift3 m1 m2 m3 f)
        Func {env depth free rec}
            Let {x1 free} (m1 env depth free rec)
            In
            Let {x2 free} (m2 env depth free rec)
            In
            Let {x3 free} (m3 env depth free rec)
            In
            {(f x1 x2 x3) free}
    Define (in_context vars m)
        Func {env depth free rec}
            Let env (insert_each env depth vars)
            In
            (m env depth free rec)
    Define (map list f)
        Func {env depth free rec}
            ((rec.map list f) env depth free rec)
    Define (collect expr)
        Func {env depth free rec}
            ((rec.collect expr) env depth free rec)
    In
    Define (map list f)
        Match list
        | 'nil (pure 'nil)
        | 'cons.{item list} (lift2 (f item) (map list f) LIST.cons)
        ;
    Define (collect expr)
        Match expr
        | 'true (pure expr)
        | 'false (pure expr)
        | 'num._ (pure expr)
        | 'str._ (pure expr)
        | 'package._ (pure expr)
        | 'prim._ (pure expr)
        | 'var.name
            Func {env depth free _} {expr (maybe_insert env depth free name)}
        | 'chain.{expr chain}
            (lift1 (collect expr)
                Func {expr} 'chain.{expr chain})
        | 'tuple.exprs
            (lift1 (map exprs collect)
                Func {exprs} 'tuple.exprs)
        | 'record.{labels inits}
            (lift1 (map inits collect)
                Func {inits} 'record.{labels inits})
        | 'block.{binders expr}
            Let vars (LIST.concat_map binders binder_variables)
            Let binder_exprs (LIST.map binders binder_expr)
            In
            (lift2 (map binder_exprs collect) (in_context vars (collect expr))
                Func {binder_exprs expr}
                    Let binders
                        (LIST.map (LIST.zip binders binder_exprs)
                            Func {{binder expr}}
                                Match binder
                                | 'do._ 'do.expr
                                | 'let.{pat _} 'let.{pat expr}
                                ;)
                    In
                    'block.{binders expr})
        | 'app.{func args}
            (lift2 (collect func) (map args collect)
                Func {func args} 'app.{func args})
        | 'func.{param_pats expr}
            Let vars (LIST.concat_map param_pats pattern_variables)
            In
            Func {env depth free rec}
                Let {expr func_free}
                    Let depth [depth + 1]
                    In
                    Let env (insert_each env depth vars)
                    Let m (collect expr)
                    In
                    (m env depth SET.empty rec)
                In
                Let func_free_list (SET.list func_free)
                In
                Let free
                    (LIST.reduce func_free_list free
                        Func {free name} (maybe_insert env depth free name))
                In
                {'func.{func_free_list param_pats expr} free}
        | 'iterate.{vars inits expr}
            (lift2 (map inits collect) (in_context vars (collect expr))
                Func {inits expr} 'iterate.{vars inits expr})
        | 'continue.exprs
            (lift1 (map exprs collect)
                Func {exprs} 'continue.exprs)
        | 'cond.clauses
            Define (collect_in_clause {test body})
                (lift2 (collect test) (collect body)
                    Func {test body} {test body})
            In
            (lift1 (map clauses collect_in_clause)
                Func {clauses} 'cond.clauses)
        | 'if.{test then else}
            (lift3 (collect test) (collect then) (collect else)
                Func {test then else} 'if.{test then else})
        | 'not.expr
            (lift1 (collect expr)
                Func {expr} 'not.expr)
        | 'and.{test then}
            (lift2 (collect test) (collect then)
                Func {test then} 'and.{test then})
        | 'or.{test else}
            (lift2 (collect test) (collect else)
                Func {test else} 'or.{test else})
        | 'list.exprs
            (lift1 (map exprs collect)
                Func {exprs} 'list.exprs)
        | 'labeled.{label expr}
            (lift1 (collect expr)
                Func {expr} 'labeled.{label expr})
        | 'match.{expr clauses}
            Define (collect_in_clause {pat body})
                Let vars
                    Match pat
                    | 'default 'nil
                    | 'labeled.{_ pat} (pattern_variables pat)
                    ;
                In
                (lift1 (in_context vars (collect body))
                    Func {body} {pat body})
            In
            (lift2 (collect expr) (map clauses collect_in_clause)
                Func {expr clauses} 'match.{expr clauses})
        ;
    In
    For expr
        Let {expr _}
            ((collect expr) MAP.empty 0 SET.empty {: map : collect})

Define (lift_functions i expr)
    Let MAP
        (SEARCH.MAP STRING.compare
            Func {{key _}} key)
    In
    Define (pure x)
        Func {_ i funcs rec} {x i funcs}
    Define (lift1 m1 f)
        Func {env i funcs rec}
            Let {x1 i funcs} (m1 env i funcs rec)
            In
            {(f x1) i funcs}
    Define (lift2 m1 m2 f)
        Func {env i funcs rec}
            Let {x1 i funcs} (m1 env i funcs rec)
            In
            Let {x2 i funcs} (m2 env i funcs rec)
            In
            {(f x1 x2) i funcs}
    Define (lift3 m1 m2 m3 f)
        Func {env i funcs rec}
            Let {x1 i funcs} (m1 env i funcs rec)
            In
            Let {x2 i funcs} (m2 env i funcs rec)
            In
            Let {x3 i funcs} (m3 env i funcs rec)
            In
            {(f x1 x2 x3) i funcs}
    Define (bind m1 f)
        Func {env i funcs rec}
            Let {x1 i funcs} (m1 env i funcs rec)
            In
            Let m2 (f x1)
            In
            (m2 env i funcs rec)
    Define (lookup var)
        Func {env i funcs _}
            Match (MAP.search env var)
            | 'just.{_ expr} {expr i funcs}
            | 'nothing (die "No var.")
            ;
    Define (in_context bindings m)
        Func {env i funcs rec}
            Let env (LIST.reduce bindings env MAP.insert)
            In
            (m env i funcs rec)
    Define (map list f)
        Func {env i funcs rec}
            ((rec.map list f) env i funcs rec)
    Define (rewrite expr)
        Func {env i funcs rec}
            ((rec.rewrite expr) env i funcs rec)
    In
    Define (map list f)
        Match list
        | 'nil (pure 'nil)
        | 'cons.{item items} (lift2 (f item) (map items f) LIST.cons)
        ;
    Define (rewrite expr)
        Match expr
        | 'true (pure expr)
        | 'false (pure expr)
        | 'num._ (pure expr)
        | 'str._ (pure expr)
        | 'package._ (pure expr)
        | 'prim._ (pure expr)
        | 'var._ (pure expr)
        | 'chain.{expr chain}
            (lift1 (rewrite expr)
                Func {expr} 'chain.{expr chain})
        | 'tuple.exprs
            (lift1 (map exprs rewrite)
                Func {exprs} 'tuple.exprs)
        | 'record.{labels inits}
            (lift1 (map inits rewrite)
                Func {inits} 'record.{labels inits})
        | 'block.{binders expr}
            Let binder_exprs (LIST.map binders binder_expr)
            In
            (bind (map binder_exprs rewrite)
                Func {binder_exprs}
                    Let binders
                        (LIST.map (LIST.zip binders binder_exprs)
                            Func {{binder expr}}
                                Match binder
                                | 'do._ 'do.expr
                                | 'let.{pat _} 'let.{pat expr}
                                ;)
                    In
                    Let bindings
                        (LIST.concat_map binders
                            Func {binder}
                                Match binder
                                | 'do._ 'nil
                                | 'let.{pat expr}
                                    Match pat
                                    | 'ignore 'nil
                                    | 'var.var
                                        Match expr
                                        | 'closure.{i _ num_params}
                                            [{var 'func.{i num_params}} & 'nil]
                                        | _ [{var 'expr} & 'nil]
                                        ;
                                    | 'tuple.vars
                                        (LIST.map vars
                                            Func {var} {var 'expr})
                                    ;
                                ;)
                    In
                    (lift1 (in_context bindings (rewrite expr))
                        Func {expr} 'block.{binders expr}))
        | 'app.{func args}
            Match func
            | 'var.var
                (bind (lookup var)
                    Func {expr}
                        Match expr
                        | 'func.{i num_params}
                            If [num_params != (LIST.length args)]
                                (die "Protocol mismatch in function application.")
                                (lift2 (rewrite func) (map args rewrite)
                                    Func {func args} 'app_known.{i func args})
                        | 'expr
                            (lift2 (rewrite func) (map args rewrite)
                                Func {func args} 'app.{func args})
                        ;)
            | _
                (lift2 (rewrite func) (map args rewrite)
                    Func {func args} 'app.{func args})
            ;
        | 'func.{free param_pats expr}
            Func {env i funcs rec}
                Let rewriter
                    Let bindings
                        (LIST.map (LIST.concat_map param_pats pattern_variables)
                            Func {var} {var 'expr})
                    In
                    (in_context bindings (rewrite expr))
                In
                Let {expr i funcs} (rewriter env i funcs rec)
                In
                Let closure 'closure.{i free (LIST.length param_pats)}
                Let func 'func.{i free param_pats expr}
                In
                {closure [i + 1] [func & funcs]}
        | 'iterate.{vars inits expr}
            Let bindings
                (LIST.map vars
                    Func {var} {var 'expr})
            In
            (lift2 (map inits rewrite) (in_context bindings (rewrite expr))
                Func {inits expr} 'iterate.{vars inits expr})
        | 'continue.exprs
            (lift1 (map exprs rewrite)
                Func {exprs} 'continue.exprs)
        | 'cond.clauses
            Define (rewrite_clause {test body})
                (lift2 (rewrite test) (rewrite body)
                    Func {test body} {test body})
            In
            (lift1 (map clauses rewrite_clause)
                Func {clauses} 'cond.clauses)
        | 'if.{test then else}
            (lift3 (rewrite test) (rewrite then) (rewrite else)
                Func {test then else} 'if.{test then else})
        | 'not.expr
            (lift1 (rewrite expr)
                Func {expr} 'not.expr)
        | 'and.{test then}
            (lift2 (rewrite test) (rewrite then)
                Func {test then} 'and.{test then})
        | 'or.{test else}
            (lift2 (rewrite test) (rewrite else)
                Func {test else} 'or.{test else})
        | 'list.exprs
            (lift1 (map exprs rewrite)
                Func {exprs} 'list.exprs)
        | 'labeled.{label expr}
            (lift1 (rewrite expr)
                Func {expr} 'labeled.{label expr})
        | 'match.{expr clauses}
            Define (rewrite_clause {pat body})
                Let bindings
                    Match pat
                    | 'default 'nil
                    | 'labeled.{_ pat}
                        (LIST.map (pattern_variables pat)
                            Func {var} {var 'expr})
                    ;
                In
                (lift1 (in_context bindings (rewrite body))
                    Func {body} {pat body})
            In
            (lift2 (rewrite expr) (map clauses rewrite_clause)
                Func {expr clauses} 'match.{expr clauses})
        ;
    In
    ((rewrite expr) MAP.empty i 'nil {: map : rewrite})

Define (collect_constants program)
    Let package_table (package_table program)
    In
    Define (pure x)
        Func {state rec} {x state}
    Define (lift1 m1 f)
        Func {state rec}
            Let {x1 state} (m1 state rec)
            In
            {(f x1) state}
    Define (lift2 m1 m2 f)
        Func {state rec}
            Let {x1 state} (m1 state rec)
            In
            Let {x2 state} (m2 state rec)
            In
            {(f x1 x2) state}
    Define (lift3 m1 m2 m3 f)
        Func {state rec}
            Let {x1 state} (m1 state rec)
            In
            Let {x2 state} (m2 state rec)
            In
            Let {x3 state} (m3 state rec)
            In
            {(f x1 x2 x3) state}
    Define (bind1 m1 f)
        Func {state rec}
            Let {x1 state} (m1 state rec)
            In
            Let m2 (f x1)
            In
            (m2 state rec)
    Define (map items f)
        Func {state rec}
            ((rec.map items f) state rec)
    Define (rewrite expr)
        Func {state rec}
            ((rec.rewrite expr) state rec)
    In
    Define (map items f)
        Match items
        | 'nil (pure 'nil)
        | 'cons.{item items} (lift2 (f item) (map items f) LIST.cons)
        ;
    Define (rewrite expr)
        Match expr
        | 'true (pure expr)
        | 'false (pure expr)
        | 'num._ (pure expr)
        | 'str.s (intern_string s)
        | 'package.path (pure 'package.(package_table.lookup path))
        | 'var._ (pure expr)
        | 'chain.{expr chain}
            Define (intern_access access)
                Match access
                | 'id.name
                    (lift1 (intern_label name)
                        Func {id} 'record_fetch.id)
                | 'num.i (pure 'tuple_fetch.i)
                ;
            In
            (lift2 (rewrite expr) (map chain intern_access)
                Func {expr chain} 'chain.{expr chain})
        | 'tuple.exprs
            (lift1 (map exprs rewrite)
                Func {exprs} 'tuple.exprs)
        | 'record.{labels inits}
            (bind1 (map labels intern_label)
                Func {ids}
                    Let {layout inits}
                        For (LIST.unzip (sort (LIST.zip ids inits)))
                            Define (sort pairs)
                                (SORT.list_insertion
                                    Func {{i _} {j _}} (Z.compare i j)
                                    pairs)
                    In
                    (lift2 (intern_layout layout) (map inits rewrite)
                        Func {layout_id inits}
                            'record.{layout_id inits}))
        | 'block.{binders expr}
            Let binder_exprs (LIST.map binders binder_expr)
            In
            (lift2 (map binder_exprs rewrite) (rewrite expr)
                Func {binder_exprs expr}
                    Let binders
                        (LIST.map (LIST.zip binders binder_exprs)
                            Func {{binder expr}}
                                Match binder
                                | 'do._ 'do.expr
                                | 'let.{pat _} 'let.{pat expr}
                                ;)
                    In
                    'block.{binders expr})
        | 'app_known.{j func args}
            (lift2 (map args rewrite) (rewrite func)
                Func {args func} 'closure_app_known.{j func args})
        | 'app.{func args}
            Match func
            | 'prim.name
                Cond
                | (STRING.equal name "cons")
                    (rewrite 'labeled.{"cons" 'tuple.args})
                | (STRING.equal name "not_equal")
                    (rewrite 'if.{'app.{'prim."equal" args} 'false 'true})
                | True
                    (lift1 (map args rewrite)
                        Func {args}
                            'prim_app.{name args})
                ;
            | _
                (lift2 (map args rewrite) (rewrite func)
                    Func {args func} 'closure_app.{func args})
            ;
        | 'closure._ (pure expr)
        | 'func.{j free param_pats expr}
            (lift1 (rewrite expr)
                Func {expr} 'func.{j free param_pats expr})
        | 'iterate.{vars inits expr}
            (lift2 (map inits rewrite) (rewrite expr)
                Func {inits expr} 'iterate.{vars inits expr})
        | 'continue.exprs
            (lift1 (map exprs rewrite)
                Func {exprs} 'continue.exprs)
        | 'cond.clauses
            Define (rewrite_clause {test body})
                (lift2 (rewrite test) (rewrite body)
                    Func {test body} {test body})
            In
            (lift1 (map clauses rewrite_clause)
                Func {clauses} 'cond.clauses)
        | 'if.{test then else}
            (lift3 (rewrite test) (rewrite then) (rewrite else)
                Func {test then else} 'if.{test then else})
        | 'not.expr
            (lift1 (rewrite expr)
                Func {expr} 'not.expr)
        | 'and.{test then}
            (lift2 (rewrite test) (rewrite then)
                Func {test then} 'and.{test then})
        | 'or.{test else}
            (lift2 (rewrite test) (rewrite else)
                Func {test else} 'or.{test else})
        | 'list.exprs
            Let expr
                (LIST.fold exprs 'labeled.{"nil" 'tuple.'nil}
                    Func {expr rest}
                        'labeled.{"cons" 'tuple.[Right expr & rest & 'nil]})
            In
            (rewrite expr)
        | 'labeled.{label expr}
            (bind1 (intern_label label)
                Func {id}
                    (lift1 (rewrite expr)
                        Func {expr} 'labeled.{id expr}))
        | 'match.{expr clauses}
            Define (rewrite_clause {pat body})
                Match pat
                | 'default
                    (lift1 (rewrite body)
                        Func {body} {pat body})
                | 'labeled.{label vars}
                    (lift2 (intern_label label) (rewrite body)
                        Func {id body} {'labeled.{id vars} body})
                ;
            In
            (lift2 (rewrite expr) (map clauses rewrite_clause)
                Func {expr clauses} 'match.{expr clauses})
        ;
    In
    Let {output state}
        Define (rewrite_package package)
            (lift2 (rewrite package.init) (map package.functions rewrite)
                Func {init functions}
                    {
                    : path package.path
                    : imports package.imports
                    : init
                    : functions
                    })
        In
        Let rewriter
            (lift3 (intern_label "nil") (intern_label "cons")
                (map program rewrite_package)
                Func {nil_label cons_label packages}
                    {nil_label cons_label packages})
        In
        Let string_env {STRING_ID_MAP.empty 0}
        Let label_env
            {
            : name_of_id ID_LABEL_MAP.empty
            : id_of_name LABEL_ID_MAP.empty
            : i 0
            }
        Let layout_env
            {
            : indexes 'nil
            : map LAYOUT_ID_MAP.empty
            : i 0
            }
        In
        (rewriter {string_env label_env layout_env} {: map : rewrite})
    In
    Let {nil_label cons_label packages} output
    Let {string_env label_env layout_env} state
    In
    Let constants
        Let {map _} string_env
        In
        (LIST.map
            (SORT.list_insertion
                Func {{_ i} {_ j}} (Z.compare i j)
                (STRING_ID_MAP.list map))
            Func {{s _}} s)
    Let record_indexes (LIST.reverse layout_env.indexes)
    Let label_names (ID_LABEL_MAP.list label_env.name_of_id)
    In
    {
    : constants
    : label_names
    : record_indexes
    : packages
    : nil_label
    : cons_label
    }

Where

Define (package_table packages)
    Let MAP (SEARCH.MAP STRING.compare [Func {{key _}} key])
    In
    Let {_ map}
        (LIST.reduce packages {0 MAP.empty}
            Func {{i map} package}
                {[i + 1] (MAP.insert map {package.path i})})
    In
    Define (lookup path)
        Match (MAP.search map path)
        | 'just.{_ i} i
        ;
    In
    {: lookup}

Define (intern_string s)
    Func {state _}
        Let {string_env label_env layout_env} state
        In
        Let {map i} string_env
        In
        Match (STRING_ID_MAP.search map s)
        | 'nothing
            Let map (STRING_ID_MAP.insert map {s i})
            In
            {'const.i {{map [i + 1]} label_env layout_env}}
        | 'just.{_ j}
            {'const.j state}
        ;

Define (intern_label name)
    Func {state _}
        Let {string_env label_env layout_env} state
        In
        Match (LABEL_ID_MAP.search label_env.id_of_name name)
        | 'just.{_ i} {i state}
        | 'nothing
            Let i label_env.i
            In
            Let label_env
                {
                : name_of_id (ID_LABEL_MAP.insert label_env.name_of_id {i name})
                : id_of_name (LABEL_ID_MAP.insert label_env.id_of_name {name i})
                : i [i + 1]
                }
            In
            {i {string_env label_env layout_env}}
        ;

Define (intern_layout layout)
    Func {state _}
        Let {string_env label_env layout_env} state
        In
        Match (LAYOUT_ID_MAP.search layout_env.map layout)
        | 'just.{_ i} {i state}
        | 'nothing
            Let i layout_env.i
            In
            Let layout_env
                {
                : map (LAYOUT_ID_MAP.insert layout_env.map {layout i})
                : indexes [layout & layout_env.indexes]
                : i [i + (LIST.length layout) + 1]
                }
            In
            {i {string_env label_env layout_env}}
        ;

Where

Let STRING_ID_MAP (SEARCH.MAP STRING.compare [Func {{key _}} key])

Let LABEL_ID_MAP (SEARCH.MAP STRING.compare [Func {{key _}} key])
Let ID_LABEL_MAP (SEARCH.MAP Z.compare [Func {{key _}} key])

Let LAYOUT_ID_MAP
    (SEARCH.MAP
        Func {a b}
            Let m (LIST.length a)
            Let n (LIST.length b)
            In
            Cond
            | [m < n] 'less
            | [m > n] 'greater
            | True
                (LIST.reduce (LIST.zip a b) 'equal
                    Func {relation {ai bi}}
                        Match relation
                        | 'equal
                            Cond
                            | [ai < bi] 'less
                            | [ai > bi] 'greater
                            | True 'equal
                            ;
                        | _ relation
                        ;)
            ;
        Func {{key _}} key)

Where

Define (pattern_variables pat)
    Match pat
    | 'tuple.vars vars
    | 'var.var [var & 'nil]
    | 'ignore 'nil
    ;

Define (binder_variables binder)
    Match binder
    | 'let.{pat _}
        Match pat
        | 'tuple.vars vars
        | 'var.var [var & 'nil]
        ;
    | 'do._ 'nil
    ;

Define (binder_expr binder)
    Match binder
    | 'do.expr expr
    | 'let.{_ expr} expr
    ;

Where

Let die OS.die

Where

Let LIST Package "list"
Let OS Package "os"
Let SEARCH Package "search"
Let SORT Package "sort"
Let STDIO Package "stdio"
Let STRING Package "string"
Let Z Package "z"