{
:expand_macros
:elaborate_operators
:elaborate_recursion
:collect_free_variables
:lift_functions
:collect_constants
:elaborate_patterns
}

Where

Define (expand_macros expr)
    Define (compile expr)
        Match expr {
        | 'true (pure expr)
        | 'false (pure expr)
        | 'num._ (pure expr)
        | 'str._ (pure expr)
        | 'prim._ (pure expr)
        | 'var._ (pure expr)
        | 'record_fetch._ (pure expr)
        | 'tuple.exprs
            (lift1 (map exprs eval)
                Func exprs 'tuple.exprs)
        | 'record.{labels inits}
            (lift1 (map inits eval)
                Func inits 'record.{labels inits})
        | 'block.{binders expr}
            Define (compile_binder binder)
                Match binder {
                | 'let.{pat body}
                    (lift1 (eval body)
                        Func body 'let.{pat body})
                | 'open._ (pure binder)
                }
            In
            (lift2 (map binders compile_binder) (eval expr)
                Func {binders expr} 'block.{binders expr})
        | 'app.{func args}
            (lift2 (eval func) (map args eval)
                Func {func args} 'app.{func args})
        | 'app_infix.{op left rights}
            (lift2 (eval left) (map rights eval)
                Func {left rights}
                    'app_infix.{op left rights})
        | 'func.{param_pats expr}
            (lift1 (eval expr)
                Func expr 'func.{param_pats expr})
        | 'iterate.{vars inits expr}
            (lift2 (map inits eval) (eval expr)
                Func {inits expr} 'iterate.{vars inits expr})
        | 'continue.exprs
            (lift1 (map exprs eval)
                Func exprs 'continue.exprs)
        | 'unfold.{vars inits expr}
            (lift2 (map inits eval) (eval expr)
                Func {inits expr} 'unfold.{vars inits expr})
        | 'fold.exprs
            (lift1 (map exprs eval)
                Func exprs 'fold.exprs)
        | 'cond.clauses
            Match clauses {
            | 'nil (pure expr)
            | 'cons.{clause clauses}
                Unfold {clause clauses}
                    Let {test body} clause
                    In
                    Match clauses {
                    | 'nil
                        If Pattern 'pattern_matches.{pat match_expr} Matches test
                            (lift2 (eval match_expr) (eval body)
                                Func {match_expr body}
                                    'match.{match_expr [{pat body} & 'nil]})
                            (lift2 (eval test) (eval body)
                                Func {test body}
                                    'cond.[{test body} & 'nil])
                    | 'cons.{clause clauses}
                        If Pattern 'pattern_matches.{pat match_expr} Matches test
                            (lift3 (eval match_expr) (eval body) (Fold clause clauses)
                                Func {match_expr then else}
                                    Let match_clauses
                                        (Reduce & {pat then} {'default else} 'nil)
                                    In
                                    'match.{match_expr match_clauses})
                            (lift3 (eval test) (eval body) (Fold clause clauses)
                                Func {test body more}
                                    Match more {
                                    | 'cond.clauses
                                        'cond.[{test body} & clauses]
                                    | 'match._
                                        'cond.[{test body} & {'true more} & 'nil]
                                    })
                    }
            }
        | 'if.{test then else}
            If Pattern 'pattern_matches.{pat match_expr} Matches test
                (lift3 (eval match_expr) (eval then) (eval else)
                    Func {match_expr then else}
                        Let match_clauses
                            (Reduce & {pat then} {'default else} 'nil)
                        In
                        'match.{match_expr match_clauses})
                (lift3 (eval test) (eval then) (eval else)
                    Func {test then else} 'if.{test then else})
        | 'and.{test then}
            (eval 'if.{test then 'false})
        | 'or.{test else}
            (lift2 (eval test) (eval else)
                Func {test else} 'if.{test 'true else})
        | 'pattern_matches.{pat match_expr}
            (lift1 (eval match_expr)
                Func match_expr
                    'match.{match_expr [{pat 'true} & {'default 'false} & 'nil]})
        | 'labeled.{label expr}
            (lift1 (eval expr)
                Func expr 'labeled.{label expr})
        | 'match.{expr clauses}
            Define (compile_clause {pat body})
                (lift1 (eval body)
                    Func body {pat body})
            In
            (lift2 (eval expr) (map clauses compile_clause)
                Func {expr clauses} 'match.{expr clauses})
        }
    In
    Unfold c From (compile expr)
        Match c {
        | 'pure.x x
        | 'lift1.{c1 f} (f (Fold c1))
        | 'lift2.{c1 c2 f} (f (Fold c1) (Fold c2))
        | 'lift3.{c1 c2 c3 f} (f (Fold c1) (Fold c2) (Fold c3))
        | 'eval.expr (Fold (compile expr))
        }

Define (elaborate_operators expr)
    Let reduce_infix
        Define (app left var right)
            'app.{var [left & right & 'nil]}
        In
        Define (reduce_left var left rights)
            (LIST.reduce rights left
                Func {left right} (app left var right))
        Define (reduce_right var left rights)
            Match (LIST.reverse [left & rights]) {
            | 'cons.{right lefts}
                (LIST.reduce lefts right
                    Func {right left} (app left var right))
            }
        Define (reduce_not var left rights)
            Match rights {
            | 'cons.{right rights}
                Match rights {
                | 'nil (app left var right)
                | 'cons._ (die "No associativity rule for operator.")
                }
            }
        In
        Func {var assoc left rights}
            Let reduce
                Match assoc {
                | 'left reduce_left
                | 'right reduce_right
                | 'not reduce_not
                }
            In
            (reduce var left rights)
    In
    Define (adjust pat)
        Match pat {
        | 'infix_op.{op _} 'var.(STRING.append "Infix_" op)
        | 'prefix_op.op 'var.(STRING.append "Prefix_" op)
        | _ pat
        }
    Define (match pat static)
        Match pat {
        | 'var.var [{var static} & 'nil]
        | 'tuple.vars
            Let statics
                If Pattern 'tuple.statics Matches static
                    If [(LIST.length vars) = (LIST.length statics)]
                        statics
                        (LIST.map vars [Func _ 'expr])
                    (LIST.map vars [Func _ 'expr])
            In
            (LIST.filter (LIST.zip vars statics)
                Func {var _} !(STRING.equal var "_"))
        | 'infix_op.{op assoc}
            Let var (STRING.append "Infix_" op)
            In
            [{var 'infix_op.{assoc static}} & 'nil]
        | 'prefix_op.op
            Let var (STRING.append "Prefix_" op)
            In
            [{var 'prefix_op.static} & 'nil]
        | 'open.pairs
            Match static {
            | 'record.{labels statics}
                Let OPEN_MAP (SEARCH.MAP STRING.compare [Func {label _} label])
                In
                Let static_env (OPEN_MAP.new (LIST.zip labels statics))
                In
                (LIST.reduce pairs 'nil
                    Func {matches {label_name var_name}}
                        Match (OPEN_MAP.search static_env label_name) {
                        | 'nothing
                            Let strings
                                (Reduce &
                                    "Cannot resolve binding for "
                                    var_name
                                    "."
                                    'nil)
                            In
                            (die (STRING.concat strings))
                        | 'just.{_ static}
                            [{var_name static} & matches]
                        })
            | _ (die "Cannot resolve Open binder.")
            }
        }
    Define (choose_nonstatic {expr _}) expr
    Define ((evaluator env) expr) (eval expr env)
    Let MAP (SEARCH.MAP STRING.compare [Func {var _} var])
    In
    Define (compile expr env)
        Match expr {
        | 'true (pure {expr 'expr})
        | 'false (pure {expr 'expr})
        | 'num._ (pure {expr 'expr})
        | 'str._ (pure {expr 'expr})
        | 'prim._ (pure {expr 'expr})
        | 'var.name
            Match (MAP.search env name) {
            | 'nothing
                Let {description name}
                    Let n (STRING.length "Prefix_")
                    Let name_len (STRING.length name)
                    In
                    Let is_prefix_op
                        (And [name_len > n]
                            (STRING.equal (STRING.clip name 0 n) "Prefix_"))
                    In
                    If is_prefix_op
                        {"prefix operator" (STRING.clip name n name_len)}
                        {"variable" name}
                In
                (die (Reduce <- STDIO.sprintf "Unbound %s: %s." description name))
            | 'just.{_ static}
                (pure {expr static})
            }
        | 'record_fetch.{prefix field}
            Iterate {prefix fields} From {prefix [field & 'nil]}
                Match prefix {
                | 'var._
                    (lift1 (eval prefix env)
                        Func {prefix _}
                            Let expr
                                Iterate {prefix fields}
                                    Match fields {
                                    | 'nil prefix
                                    | 'cons.{field fields}
                                        (Continue 'record_fetch.{prefix field} fields)
                                    }
                            In
                            {expr 'expr})
                | 'record_fetch.{prefix field}
                    (Continue prefix [field & fields])
                }
        | 'tuple.exprs
            (lift1 (map exprs (evaluator env))
                Func exprs
                    Let {exprs statics} (LIST.unzip exprs)
                    In
                    {'tuple.exprs 'tuple.statics})
        | 'record.{labels inits}
            (lift1 (map inits (evaluator env))
                Func inits
                    Let {inits statics} (LIST.unzip inits)
                    In
                    {'record.{labels inits} 'record.{labels statics}})
        | 'block.{binders expr}
            (bind1
                (map binders
                    Func binder
                        Match binder {
                        | 'let.{pat expr}
                            (lift1 (eval expr env)
                                Func expr 'let.{pat expr})
                        | 'open.{expr pairs}
                            (lift1 (eval expr env)
                                Func expr 'open.{expr pairs})
                        })
                Func binders
                    Let env
                        (LIST.reduce binders env
                            Func {env binder}
                                Let {pat expr}
                                    Match binder {
                                    | 'let.{pat expr} {pat expr}
                                    | 'open.{expr pairs} {'open.pairs expr}
                                    }
                                In
                                Let {_ static} expr
                                In
                                (LIST.reduce (match pat static) env MAP.insert))
                    Let binders
                        (LIST.fold binders 'nil
                            Func {binder binders}
                                Match binder {
                                | 'let.{pat expr}
                                    Let {expr _} expr
                                    In
                                    ['let.{(adjust pat) expr} & binders]
                                | 'open.{expr pairs}
                                    Let {expr _} expr
                                    In
                                    (LIST.fold pairs binders
                                        Func {{label_name var_name} binders}
                                            Let expr
                                                'record_fetch.{expr label_name}
                                            In
                                            ['let.{'var.var_name expr} & binders])
                                })
                    In
                    (lift1 (eval expr env)
                        Func {expr static}
                            {'block.{binders expr} static}))
        | 'app.{func args}
            (lift2 (eval func env) (map args (evaluator env))
                Func {func args}
                    Let {func _} func
                    Let args (LIST.map args choose_nonstatic)
                    In
                    {'app.{func args} 'expr})
        | 'app_infix.{op left rights}
            Match (MAP.search env (STRING.append "Infix_" op)) {
            | 'nothing
                (die (STRING.concat ["Unbound operator: " & op & "." & 'nil]))
            | 'just.{_ static}
                Match static {
                | 'infix_op.{assoc static}
                    (lift2 (eval left env)
                        (map rights (evaluator env))
                        Func {left rights}
                            Let {left _} left
                            Let rights (LIST.map rights choose_nonstatic)
                            Let var 'var.(STRING.append "Infix_" op)
                            In
                            {(reduce_infix var assoc left rights) 'expr})
                }
            }
        | 'func.{param_pats expr}
            Let vars (LIST.concat_map param_pats pattern_variables)
            In
            Let env
                (LIST.reduce vars env
                    Func {env var}
                        (MAP.insert env {var 'expr}))
            In
            (lift1 (eval expr env)
                Func {expr _}
                    {'func.{param_pats expr} 'expr})
        | 'iterate.{vars inits expr}
            (bind1 (map inits (evaluator env))
                Func inits
                    Let {inits statics} (LIST.unzip inits)
                    In
                    Let env
                        (LIST.reduce
                            (LIST.filter (LIST.zip vars statics)
                                Func {var _} !(STRING.equal var "_"))
                            env
                            MAP.insert)
                    In
                    (lift1 (eval expr env)
                        Func {expr _}
                            {'iterate.{vars inits expr} 'expr}))
        | 'continue.exprs
            (lift1 (map exprs (evaluator env))
                Func exprs
                    Let exprs (LIST.map exprs choose_nonstatic)
                    In
                    {'continue.exprs 'expr})
        | 'unfold.{vars inits expr}
            (bind1 (map inits (evaluator env))
                Func inits
                    Let {inits statics} (LIST.unzip inits)
                    In
                    Let env
                        (LIST.reduce
                            (LIST.filter (LIST.zip vars statics)
                                Func {var _} !(STRING.equal var "_"))
                            env
                            MAP.insert)
                    In
                    (lift1 (eval expr env)
                        Func {expr _}
                            {'unfold.{vars inits expr} 'expr}))
        | 'fold.exprs
            (lift1 (map exprs (evaluator env))
                Func exprs
                    Let exprs (LIST.map exprs choose_nonstatic)
                    In
                    {'fold.exprs 'expr})
        | 'cond.clauses
            Define (compile_clause {test body})
                (lift2 (eval test env) (eval body env)
                    Func clause clause)
            In
            (lift1 (map clauses compile_clause)
                Func clauses
                    Let clauses
                        (LIST.map clauses
                            Func {{test _} {body _}} {test body})
                    In
                    {'cond.clauses 'expr})
        | 'if.{test then else}
            (lift3 (eval test env) (eval then env) (eval else env)
                Func {test then else}
                    Let {test _} test
                    Let {then _} then
                    Let {else _} else
                    In
                    {'if.{test then else} 'expr})
        | 'labeled.{label expr}
            (lift1 (eval expr env)
                Func {expr _} {'labeled.{label expr} 'expr})
        | 'match.{expr clauses}
            Define (compile_clause {pat body})
                Let vars
                    Match pat {
                    | 'default 'nil
                    | 'labeled.{_ pat} (pattern_variables pat)
                    }
                In
                Let env
                    (LIST.reduce vars env
                        Func {env var} (MAP.insert env {var 'expr}))
                In
                (lift1 (eval body env)
                    Func body {pat body})
            In
            (lift2 (eval expr env) (map clauses compile_clause)
                Func {{expr _} clauses}
                    Let clauses
                        (LIST.map clauses
                            Func {pat {body _}} {pat body})
                    In
                    {'match.{expr clauses} 'expr})
        }
    In
    Let {expr _}
        Unfold c From (compile expr MAP.empty)
            Match c {
            | 'pure.x x
            | 'lift1.{c1 f} (f (Fold c1))
            | 'lift2.{c1 c2 f} (f (Fold c1) (Fold c2))
            | 'lift3.{c1 c2 c3 f} (f (Fold c1) (Fold c2) (Fold c3))
            | 'bind1.{c1 f} (Fold (f (Fold c1)))
            | 'eval.{expr env} (Fold (compile expr env))
            }
    In
    expr

Define (elaborate_recursion expr)
    Define (push_loop expr) 'push_loop.expr
    Define (use expr) 'use.expr
    Define (pass expr) 'pass.expr
    In
    Define (compile expr)
        Match expr {
        | 'true (pure expr)
        | 'false (pure expr)
        | 'num._ (pure expr)
        | 'str._ (pure expr)
        | 'prim._ (pure expr)
        | 'var._ (pure expr)
        | 'record_fetch._ (pure expr)
        | 'tuple.exprs
            (lift1 (map exprs use)
                Func exprs 'tuple.exprs)
        | 'record.{labels inits}
            (lift1 (map inits use)
                Func inits 'record.{labels inits})
        | 'block.{binders expr}
            Define (compile_binder binder)
                Match binder {
                | 'let.{pat body}
                    (lift1 (use body)
                        Func body 'let.{pat body})
                }
            In
            (lift2 (map binders compile_binder) (pass expr)
                Func {binders expr} 'block.{binders expr})
        | 'app.{func args}
            (lift2 (use func) (map args use)
                Func {func args} 'app.{func args})
        | 'func.{param_pats expr}
            (lift1 (use expr)
                Func expr 'func.{param_pats expr})
        | 'iterate.{vars inits expr}
            (lift2 (map inits use) (push_loop expr)
                Func {inits expr} 'iterate.{vars inits expr})
        | 'continue.exprs
            (lift1 (map exprs use)
                Func exprs 'continue.exprs)
        | 'unfold.{vars inits expr}
            Let tagged_vars (LIST.map vars [Func name 'var.name])
            In
            (pass
                'block.{
                    (Reduce &
                        'let.{
                            'var."Fold"
                            'func.{
                                ['var."Fold" & tagged_vars]
                                'iterate.{vars tagged_vars expr}
                            }
                        }
                        'nil)
                    'app.{'var."Fold" ['var."Fold" & inits]}
                })
        | 'fold.exprs
            (pass 'app.{'var."Fold" ['var."Fold" & exprs]})
        | 'cond.clauses
            Define (compile_clause {test body})
                (lift2 (use test) (pass body)
                    Func clause clause)
            In
            (lift1 (map clauses compile_clause)
                Func clauses 'cond.clauses)
        | 'if.{test then else}
            (lift3 (use test) (pass then) (pass else)
                Func {test then else} 'if.{test then else})
        | 'labeled.{label expr}
            (lift1 (use expr)
                Func expr 'labeled.{label expr})
        | 'match.{expr clauses}
            Define (compile_clause {pat body})
                (lift1 (pass body)
                    Func body {pat body})
            In
            (lift2 (use expr) (map clauses compile_clause)
                Func {expr clauses} 'match.{expr clauses})
        }
    In
    Unfold {command context} From {(compile expr) 'other}
        Match command {
        | 'pure.expr expr
        | 'lift1.{c1 f} (f (Fold c1 context))
        | 'lift2.{c1 c2 f} (f (Fold c1 context) (Fold c2 context))
        | 'lift3.{c1 c2 c3 f}
            (f (Fold c1 context) (Fold c2 context) (Fold c3 context))
        | 'push_loop.expr (Fold 'pass.expr 'loop)
        | 'use.expr (Fold (compile expr) 'other)
        | 'pass.expr
            Let expr
                Match context {
                | 'loop
                    If Pattern 'fold.exprs Matches expr
                        'continue.exprs
                        expr
                | 'other expr
                }
            In
            (Fold (compile expr) context)
        }

Define (collect_free_variables expr)
    Define (collect name) 'collect.name
    Define (in_context vars c) 'in_context.{vars c}
    Define (eval_func vars expr) 'eval_func.{vars expr}
    In
    Define (compile expr)
        Match expr {
        | 'true (pure expr)
        | 'false (pure expr)
        | 'num._ (pure expr)
        | 'str._ (pure expr)
        | 'prim._ (pure expr)
        | 'var.name (lift1 (collect name) [Func _ expr])
        | 'record_fetch.{prefix field}
            Iterate prefix
                Match prefix {
                | 'var.name (lift1 (collect name) [Func _ expr])
                | 'record_fetch.{prefix _} (Continue prefix)
                }
        | 'tuple.exprs
            (lift1 (map exprs eval)
                Func exprs 'tuple.exprs)
        | 'record.{labels inits}
            (lift1 (map inits eval)
                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 eval)
                (in_context vars (eval expr))
                Func {binder_exprs expr}
                    Let binders
                        (LIST.map (LIST.zip binders binder_exprs)
                            Func {binder expr}
                                Match binder {
                                | 'let.{pat _} 'let.{pat expr}
                                })
                    In
                    'block.{binders expr})
        | 'app.{func args}
            (lift2 (eval func) (map args eval)
                Func {func args} 'app.{func args})
        | 'func.{param_pats expr}
            Let vars (LIST.concat_map param_pats pattern_variables)
            In
            (lift1 (eval_func vars expr)
                Func {func_free_list expr}
                    'func.{func_free_list param_pats expr})
        | 'iterate.{vars inits expr}
            (lift2 (map inits eval) (in_context vars (eval expr))
                Func {inits expr} 'iterate.{vars inits expr})
        | 'continue.exprs
            (lift1 (map exprs eval)
                Func exprs 'continue.exprs)
        | 'cond.clauses
            Define (compile_clause {test body})
                (lift2 (eval test) (eval body)
                    Func clause clause)
            In
            (lift1 (map clauses compile_clause)
                Func clauses 'cond.clauses)
        | 'if.{test then else}
            (lift3 (eval test) (eval then) (eval else)
                Func {test then else} 'if.{test then else})
        | 'labeled.{label expr}
            (lift1 (eval expr)
                Func expr 'labeled.{label expr})
        | 'match.{expr clauses}
            Define (compile_clause {pat body})
                Let vars
                    Match pat {
                    | 'default 'nil
                    | 'labeled.{_ pat} (pattern_variables pat)
                    }
                In
                (lift1 (in_context vars (eval body))
                    Func body {pat body})
            In
            (lift2 (eval expr) (map clauses compile_clause)
                Func {expr clauses} 'match.{expr clauses})
        }
    In
    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
                    ["Variable \"" & name & "\" is not bound." & 'nil]))
        }
    In
    Let {expr _}
        Unfold {command env depth free} From {'eval.expr MAP.empty 0 SET.empty}
            Match command {
            | 'pure.x {x free}
            | 'lift1.{c1 f}
                Let {x1 free} (Fold c1 env depth free)
                In
                {(f x1) free}
            | 'lift2.{c1 c2 f}
                Let {x1 free} (Fold c1 env depth free)
                In
                Let {x2 free} (Fold c2 env depth free)
                In
                {(f x1 x2) free}
            | 'lift3.{c1 c2 c3 f}
                Let {x1 free} (Fold c1 env depth free)
                In
                Let {x2 free} (Fold c2 env depth free)
                In
                Let {x3 free} (Fold c3 env depth free)
                In
                {(f x1 x2 x3) free}
            | 'collect.name {{} (maybe_insert env depth free name)}
            | 'in_context.{vars c}
                Let env (insert_each env depth vars)
                In
                (Fold c env depth free)
            | 'eval.expr (Fold (compile expr) env depth free)
            | 'eval_func.{vars expr}
                Let {expr func_free}
                    Let depth [depth + 1]
                    In
                    Let env (insert_each env depth vars)
                    In
                    (Fold (compile expr) env depth SET.empty)
                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_free_list expr} free}
            }
    In
    expr

Define (lift_functions expr)
    Define (lookup var) 'lookup.var
    Define (in_context bindings c) 'in_context.{bindings c}
    Define (insert_func f) 'insert_func.f
    In
    Define (compile expr)
        Match expr {
        | 'true (pure expr)
        | 'false (pure expr)
        | 'num._ (pure expr)
        | 'str._ (pure expr)
        | 'prim._ (pure expr)
        | 'var._ (pure expr)
        | 'record_fetch._ (pure expr)
        | 'tuple.exprs
            (lift1 (map exprs eval)
                Func exprs 'tuple.exprs)
        | 'record.{labels inits}
            (lift1 (map inits eval)
                Func inits 'record.{labels inits})
        | 'block.{binders expr}
            Let binder_exprs (LIST.map binders binder_expr)
            In
            (bind1 (map binder_exprs eval)
                Func binder_exprs
                    Let binders
                        (LIST.map (LIST.zip binders binder_exprs)
                            Func {binder expr}
                                Match binder {
                                | 'let.{pat _} 'let.{pat expr}
                                })
                    In
                    Let bindings
                        (LIST.concat_map binders
                            Func binder
                                Match binder {
                                | 'let.{pat expr}
                                    Match pat {
                                    | 'ignore 'nil
                                    | 'var.var
                                        If Pattern 'closure.{i _ num_params} Matches expr
                                            [{var 'func.{i num_params}} & 'nil]
                                            [{var 'expr} & 'nil]
                                    | 'tuple.vars
                                        (LIST.map vars
                                            Func var {var 'expr})
                                    }
                                })
                    In
                    (lift1 (in_context bindings (eval expr))
                        Func expr 'block.{binders expr}))
        | 'app.{func args}
            Match func {
            | 'var.var
                (bind1 (lookup var)
                    Func expr
                        Begin Match expr {
                        | 'func.{i num_params}
                            Let num_args (LIST.length args)
                            Let is_compatible
                                (Or [num_params = num_args]
                                    [num_params = 1]
                                    [num_args = 1])
                            When !is_compatible {
                                (die "Protocol mismatch in function application.")
                            }
                            (lift2 (eval func) (map args eval)
                                Func {func args}
                                    If [num_params = num_args]
                                        'app_known.{i func args}
                                        'app.{func args})
                        | 'expr
                            (lift2 (eval func) (map args eval)
                                Func {func args} 'app.{func args})
                        })
            | _
                (lift2 (eval func) (map args eval)
                    Func {func args} 'app.{func args})
            }
        | 'func.{free param_pats expr}
            Let bindings
                (LIST.map (LIST.concat_map param_pats pattern_variables)
                    Func var {var 'expr})
            In
            (bind1 (in_context bindings (eval expr))
                Func expr
                    (insert_func
                        Func i
                            Let closure 'closure.{i free (LIST.length param_pats)}
                            Let func 'func.{i free param_pats expr}
                            In
                            {closure func}))
        | 'iterate.{vars inits expr}
            Let bindings
                (LIST.map vars
                    Func var {var 'expr})
            In
            (lift2 (map inits eval) (in_context bindings (eval expr))
                Func {inits expr} 'iterate.{vars inits expr})
        | 'continue.exprs
            (lift1 (map exprs eval)
                Func exprs 'continue.exprs)
        | 'cond.clauses
            Define (compile_clause {test body})
                (lift2 (eval test) (eval body)
                    Func clause clause)
            In
            (lift1 (map clauses compile_clause)
                Func clauses 'cond.clauses)
        | 'if.{test then else}
            (lift3 (eval test) (eval then) (eval else)
                Func {test then else} 'if.{test then else})
        | 'labeled.{label expr}
            (lift1 (eval expr)
                Func expr 'labeled.{label expr})
        | 'match.{expr clauses}
            Define (compile_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 (eval body))
                    Func body {pat body})
            In
            (lift2 (eval expr) (map clauses compile_clause)
                Func {expr clauses} 'match.{expr clauses})
        }
    In
    Let MAP
        (SEARCH.MAP STRING.compare
            Func {key _} key)
    In
    Let {init _ functions}
        Unfold {command env i funcs} From {'eval.expr MAP.empty 1 'nil}
            Match command {
            | 'pure.x {x i funcs}
            | 'lift1.{c1 f}
                Let {x1 i funcs} (Fold c1 env i funcs)
                In
                {(f x1) i funcs}
            | 'lift2.{c1 c2 f}
                Let {x1 i funcs} (Fold c1 env i funcs)
                In
                Let {x2 i funcs} (Fold c2 env i funcs)
                In
                {(f x1 x2) i funcs}
            | 'lift3.{c1 c2 c3 f}
                Let {x1 i funcs} (Fold c1 env i funcs)
                In
                Let {x2 i funcs} (Fold c2 env i funcs)
                In
                Let {x3 i funcs} (Fold c3 env i funcs)
                In
                {(f x1 x2 x3) i funcs}
            | 'bind1.{c1 f}
                Let {x1 i funcs} (Fold c1 env i funcs)
                In
                (Fold (f x1) env i funcs)
            | 'lookup.var
                Match (MAP.search env var) {
                | 'just.{_ expr} {expr i funcs}
                | 'nothing (die "No var.")
                }
            | 'in_context.{bindings c}
                Let env (LIST.reduce bindings env MAP.insert)
                In
                (Fold c env i funcs)
            | 'insert_func.f
                Let {x func} (f i)
                In
                {x [i + 1] [func & funcs]}
            | 'eval.expr (Fold (compile expr) env i funcs)
            }
    In
    {init functions}

Define (collect_constants init functions)
    Define (intern_string s) 'intern_string.s
    Define (intern_label name) 'intern_label.name
    Define (intern_layout layout) 'intern_layout.layout
    In
    Define (compile expr)
        Match expr {
        | 'true (pure expr)
        | 'false (pure expr)
        | 'num._ (pure expr)
        | 'str.s (intern_string s)
        | 'var._ (pure expr)
        | 'record_fetch.{prefix field}
            (lift2 (eval prefix) (intern_label field)
                Func {prefix field}
                    'record_fetch.{prefix field})
        | 'tuple.exprs
            (lift1 (map exprs eval)
                Func exprs 'tuple.exprs)
        | 'record.{labels inits}
            (bind1 (map labels intern_label)
                Func ids
                    Let {layout inits}
                        Define (sort pairs)
                            (SORT.list_insertion
                                Func {{i _} {j _}} (Z.compare i j)
                                pairs)
                        In
                        (LIST.unzip (sort (LIST.zip ids inits)))
                    In
                    (lift2 (intern_layout layout) (map inits eval)
                        Func {layout_id inits}
                            'record.{layout_id inits}))
        | 'block.{binders expr}
            Let binder_exprs (LIST.map binders binder_expr)
            In
            (lift2 (map binder_exprs eval) (eval expr)
                Func {binder_exprs expr}
                    Let binders
                        (LIST.map (LIST.zip binders binder_exprs)
                            Func {binder expr}
                                Match binder {
                                | 'let.{pat _} 'let.{pat expr}
                                })
                    In
                    'block.{binders expr})
        | 'app_known.{j func args}
            (lift2 (map args eval) (eval func)
                Func {args func} 'closure_app_known.{j func args})
        | 'app.{func args}
            If Pattern 'prim.name Matches func
                (lift1 (map args eval)
                    Func args 'prim_app.{name args})
                (lift2 (map args eval) (eval func)
                    Func {args func} 'closure_app.{func args})
        | 'closure._ (pure expr)
        | 'func.{j free param_pats expr}
            (lift1 (eval expr)
                Func expr 'func.{j free param_pats expr})
        | 'iterate.{vars inits expr}
            (lift2 (map inits eval) (eval expr)
                Func {inits expr} 'iterate.{vars inits expr})
        | 'continue.exprs
            (lift1 (map exprs eval)
                Func exprs 'continue.exprs)
        | 'cond.clauses
            Define (compile_clause {test body})
                (lift2 (eval test) (eval body)
                    Func clause clause)
            In
            (lift1 (map clauses compile_clause)
                Func clauses 'cond.clauses)
        | 'if.{test then else}
            (lift3 (eval test) (eval then) (eval else)
                Func {test then else} 'if.{test then else})
        | 'labeled.{label expr}
            (bind1 (intern_label label)
                Func id
                    (lift1 (eval expr)
                        Func expr 'labeled.{id expr}))
        | 'match.{expr clauses}
            Define (compile_clause {pat body})
                Match pat {
                | 'default
                    (lift1 (eval body)
                        Func body {pat body})
                | 'labeled.{label vars}
                    (lift2 (intern_label label) (eval body)
                        Func {id body} {'labeled.{id vars} body})
                }
            In
            (lift2 (eval expr) (map clauses compile_clause)
                Func {expr clauses} 'match.{expr clauses})
        }
    In
    Let command
        (lift2 (eval init) (map functions eval)
            Func x x)
    Let state
        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
        {string_env label_env layout_env}
    In
    Let {init_functions state}
        Unfold {command state}
            Match command {
            | 'pure.x {x state}
            | 'lift1.{c1 f}
                Let {x1 state} (Fold c1 state)
                In
                {(f x1) state}
            | 'lift2.{c1 c2 f}
                Let {x1 state} (Fold c1 state)
                In
                Let {x2 state} (Fold c2 state)
                In
                {(f x1 x2) state}
            | 'lift3.{c1 c2 c3 f}
                Let {x1 state} (Fold c1 state)
                In
                Let {x2 state} (Fold c2 state)
                In
                Let {x3 state} (Fold c3 state)
                In
                {(f x1 x2 x3) state}
            | 'bind1.{c1 f}
                Let {x1 state} (Fold c1 state)
                In
                (Fold (f x1) state)
            | 'intern_string.s
                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}
                }
            | 'intern_label.name
                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}}
                }
            | 'intern_layout.layout
                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}}
                }
            | 'eval.expr (Fold (compile expr) state)
            }
    In
    Let {init functions} init_functions             ;   TODO Make this unnecessary.
    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
    :init
    :functions
    }

Define (elaborate_patterns program)
    Let VAR_MAP (SEARCH.MAP STRING.compare [Func {key _} key])
    In
    Let functions
        (LIST.map program.functions
            Func function
                (elaborate_patterns VAR_MAP 0 VAR_MAP.empty
                    'nothing function))
    Let init
        (elaborate_patterns VAR_MAP 0 VAR_MAP.empty
            'nothing program.init)
    In
    {
    :init
    :functions
    :constants program.constants
    :label_names program.label_names
    :record_indexes program.record_indexes
    }

Where

Define (elaborate_patterns VAR_MAP m env loop expr)
    Define (fresh_var m)
        {[m + 1] 'x.m}
    In
    Unfold {m env loop expr}
        Match expr {
        | 'true 'true
        | 'false 'false
        | 'num.n 'num.(RUNTIME.encode_small_integer n)
        | 'const.i 'c.i
        | 'var.name
            Match (VAR_MAP.search env name) {
            | 'nothing (die "Unexpected scope error.")
            | 'just.{_ xm} xm
            }
        | 'record_fetch.{prefix field}
            Let prefix (Fold m env 'nothing prefix)
            In
            'record_fetch.{prefix field}
        | 'tuple.exprs
            Match exprs {
            | 'nil 'empty_tuple
            | 'cons._
                'alloc_tuple.(LIST.map exprs [Func expr (Fold m env 'nothing expr)])
            }
        | 'record.{layout inits}
            Let inits
                (LIST.map inits
                    Func init (Fold m env 'nothing init))
            In
            'alloc_record.{layout inits}
        | 'block.{binders expr}
            Let m0 m
            Let {m env stmts}
                Let env_outer env
                In
                (LIST.fold binders {m env_outer QUEUE.empty}
                    Func {binder {m env_inner stmts}}
                        Match binder {
                        | 'let.{pat expr}
                            Match pat {
                            | 'var.name
                                Cond {
                                | (STRING.equal name "_")
                                    {m env_inner
                                        (QUEUE.push stmts
                                            'expr.(Fold m env_outer 'nothing expr))}
                                | True
                                    Let {m xm} (fresh_var m)
                                    In
                                    {m (VAR_MAP.insert env_inner {name xm})
                                        (QUEUE.push stmts
                                            'assign.{xm
                                                (Fold m env_outer 'nothing expr)})}
                                }
                            | 'tuple.names
                                Match names {
                                | 'nil
                                    {m env_inner
                                        (QUEUE.push stmts
                                            'expr.(Fold m env_outer 'nothing expr))}
                                | 'cons._
                                    Let {m tuple_var} (fresh_var m)
                                    In
                                    Let stmts
                                        (QUEUE.push stmts
                                            'assign.{tuple_var
                                                (Fold m env_outer 'nothing expr)})
                                    In
                                    Let {_ m env_inner stmts}
                                        (LIST.reduce names {0 m env_inner stmts}
                                            Func {{i m env_inner stmts} name}
                                                Cond {
                                                | (STRING.equal name "_")
                                                    {[i + 1] m env_inner stmts}
                                                | True
                                                    Let {m xm} (fresh_var m)
                                                    In
                                                    Let env_inner
                                                        (VAR_MAP.insert env_inner {name xm})
                                                    Let stmts
                                                        (QUEUE.push stmts
                                                            'assign.{xm
                                                                'tuple_fetch.{tuple_var i}})
                                                    In
                                                    {[i + 1] m env_inner stmts}
                                                })
                                    In
                                    {m env_inner stmts}
                                }
                            }
                        })
            In
            Cond {
            | (QUEUE.is_empty stmts)
                (Fold m env loop expr)
            | True
                Let stmts (QUEUE.pop_all stmts)
                In
                Let stmts
                    Cond {
                    | [m = m0] stmts
                    | True
                        Let decls
                            (LIST.map (LIST.iota [m - m0])
                                Func i {'x.[m0 + i] 'nothing})
                        In
                        ['decls.decls & stmts]
                    }
                In
                'stmt_expr.{stmts (Fold m env loop expr)}
            }
        | 'func.{i free param_pats expr}
            Let {m args inits env}
                {0 QUEUE.empty QUEUE.empty VAR_MAP.empty}
            In
            Let {m args env}
                Let {m xm} (fresh_var m)
                In
                {m (QUEUE.push args xm) env}
            In
            Let {m args inits env}
                (LIST.reduce param_pats {m args inits env}
                    Func {{m args inits env} pat}
                        Let {m arg} (fresh_var m)
                        In
                        Let args (QUEUE.push args arg)
                        In
                        Match pat {
                        | 'ignore
                            {m args inits env}
                        | 'var.name
                            {m args inits
                                (VAR_MAP.insert env {name arg})}
                        | 'tuple.names
                            Let {_ m inits env}
                                (LIST.reduce names {0 m inits env}
                                    Func {{j m inits env} name}
                                        ;   TODO Handle name="_" case better.
                                        Let {m xm} (fresh_var m)
                                        In
                                        Let env
                                            (VAR_MAP.insert env {name xm})
                                        Let init
                                            {xm 'just.'tuple_fetch.{arg j}}
                                        In
                                        {[j + 1] m
                                            (QUEUE.push inits init)
                                            env})
                            In
                            {m args inits env}
                        })
            In
            Let {m maybe_env_access env}
                Match free {
                | 'nil {m 'nothing env}
                | _
                    Let {_ m pairs env}
                        (LIST.reduce free {0 m QUEUE.empty env}
                            Func {{j m pairs env} name}
                                Let {m xm} (fresh_var m)
                                In
                                {[j + 1] m
                                    (QUEUE.push pairs {xm j})
                                    (VAR_MAP.insert env {name xm})})
                    In
                    {m 'just.'env_access.{'x.0 (QUEUE.pop_all pairs)} env}
                }
            In
            Let expr (Fold m env 'nothing expr)
            Let stmts
                Let stmts
                    Match maybe_env_access {
                    | 'nothing 'nil
                    | 'just.stmt [stmt & 'nil]
                    }
                In
                If (QUEUE.is_empty inits)
                    stmts
                    ['decls.(QUEUE.pop_all inits) & stmts]
            In
            'func.{i (QUEUE.pop_all args) stmts expr}
        | 'prim_app.{name args}
            Define (transform arg)
                (Fold m env 'nothing arg)
            In
            'prim_app.{name (LIST.map args transform)}
        | 'closure_app_known.{i func args}
            Define (transform expr)
                (Fold m env 'nothing expr)
            In
            'closure_app_known.{i (transform func) (LIST.map args transform)}
        | 'closure_app.{func args}
            Define (transform expr)
                (Fold m env 'nothing expr)
            In
            'closure_app.{(transform func) (LIST.map args transform)}
        | 'closure.{i free num_params}
            Let free
                (LIST.map free
                    Func name
                        Match (VAR_MAP.search env name) {
                        | 'nothing (die "Unexpected scope error.")
                        | 'just.{_ xm} xm
                        })
            In
            'alloc_closure.{i free num_params}
        | 'iterate.{vars inits expr}
            Let inits
                (LIST.map inits
                    Func init 'just.(Fold m env 'nothing init))
            Let {vars expr}
                Let {m vars env}
                    (LIST.fold vars {m 'nil env}
                        Func {name {m vars env}}
                            Let {m var} (fresh_var m)
                            In
                            Let env (VAR_MAP.insert env {name var})
                            In
                            {m [var & vars] env})
                In
                {vars (Fold m env 'just.vars expr)}
            In
            'iterate.{(LIST.zip vars inits) expr}
        | 'continue.exprs
            Match loop {
            | 'nothing (die "Unexpected loop scoping error.")
            | 'just.params
                Let args exprs
                Let m0 m
                In
                Let {_ evals}
                    (LIST.reduce args {m QUEUE.empty}
                        Func {{m evals} arg}
                            Let {m xm} (fresh_var m)
                            Let arg_code (Fold m0 env 'nothing arg)
                            In
                            {m (QUEUE.push evals {xm 'just.arg_code})})
                In
                Let stmts
                    If (QUEUE.is_empty evals)
                        QUEUE.empty
                        (QUEUE.new ['decls.(QUEUE.pop_all evals) & 'nil])
                In
                Let {_ stmts}
                    (LIST.reduce params {m0 stmts}
                        Func {{m stmts} param}
                            Let {m xm} (fresh_var m)
                            In
                            {m (QUEUE.push stmts 'assign.{param xm})})
                In
                'continue.(QUEUE.pop_all stmts)
            }
        | 'cond.clauses
            (LIST.fold clauses 'stuck_cond
                Func {{test body} expr}
                    Match test {
                    | 'true (Fold m env loop body)
                    | 'false expr
                    | _
                        'if.{(Fold m env 'nothing test) (Fold m env loop body) expr}
                    })
        | 'if.{test_expr then_expr else_expr}
            'if.{(Fold m env 'nothing test_expr)
                (Fold m env loop then_expr)
                (Fold m env loop else_expr)}
        | 'labeled.{label expr}
            Let expr_is_empty_tuple
                (And [Pattern 'tuple.exprs Matches expr] [Pattern 'nil Matches exprs])
            In
            If expr_is_empty_tuple
                'labeled_empty_tuple.label
                'alloc_labeled_value.{label (Fold m env 'nothing expr)}
        | 'match.{expr clauses}
            Let {m expr_var} (fresh_var m)
            In
            Let {m pat_var} (fresh_var m)
            In
            Let default_clause
                (LIST.reduce clauses 'default.'stuck
                    Func {clause {pat body}}
                        Match pat {
                        | 'default 'default.'expr.(Fold m env loop body)
                        | 'labeled._ clause
                        })
            Define (labeled_clause label vars body)
                Match vars {
                | 'ignore
                    'labeled.{label (Fold m env loop body)}
                | 'var.name
                    Let env (VAR_MAP.insert env {name pat_var})
                    In
                    'labeled.{label (Fold m env loop body)}
                | 'tuple.names
                    Let n (LIST.length names)
                    In
                    Cond {
                    | [n = 0]
                        'labeled.{label (Fold m env loop body)}
                    | True
                        Let {_ m env inits}
                            (LIST.fold names {[n - 1] m env 'nil}
                                Func {name {i m env inits}}
                                    Cond {
                                    | (STRING.equal name "_")
                                        {[i - 1] m env inits}
                                    | True
                                        Let {m xm} (fresh_var m)
                                        In
                                        Let env (VAR_MAP.insert env {name xm})
                                        Let init {xm 'just.'tuple_fetch.{pat_var i}}
                                        In
                                        {[i - 1] m env [init & inits]}
                                    })
                        In
                        Let expr (Fold m env loop body)
                        In
                        Match inits {
                        | 'nil 'labeled.{label expr}
                        | 'cons._ 'labeled.{label 'stmt_expr.{['decls.inits & 'nil] expr}}
                        }
                    }
                }
            In 
            Let clauses
                (LIST.reduce clauses [default_clause & 'nil]
                    Func {clauses {pat body}}
                        Match pat {
                        | 'default clauses
                        | 'labeled.{label vars}
                            Let clause (labeled_clause label vars body)
                            In
                            [clause & clauses]
                        })
            In
            'match.{expr_var pat_var (Fold m env 'nothing expr) clauses}
        | _ (die "Unexpected expression class.")
        }

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}}
                        If Pattern 'equal Matches relation
                            Cond {
                            | [ai < bi] 'less
                            | [ai > bi] 'greater
                            | True 'equal
                            }
                            relation)
            }
        Func {key _} key)

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]
        }
    }

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

Where

Define (map xs f)
    (LIST.fold xs (pure 'nil)
        Func {x c} (lift2 (f x) c LIST.cons))

Where

Define (pure x) 'pure.x
Define (lift1 c1 f) 'lift1.{c1 f}
Define (lift2 c1 c2 f) 'lift2.{c1 c2 f}
Define (lift3 c1 c2 c3 f) 'lift3.{c1 c2 c3 f}
Define (bind1 c1 f) 'bind1.{c1 f}
Define (eval expr) 'eval.expr

Where

Open Package "os" {:die}

Open Z
    {
    :Infix <
    :Infix >
    :Infix =
    :Infix +
    :Infix -
    }

Open LIST {:Infix &}

Open Package "func" {:Infix <-}

Open Package "bool" {:Prefix !}

Where

Let LIST Package "list"
Let QUEUE Package "queue"
Let RUNTIME Package "runtime"
Let SEARCH Package "search"
Let SORT Package "sort"
Let STDIO Package "stdio"
Let STRING Package "string"
Let Z Package "z"