{ : elaborate_recursion : collect_free_variables : lift_functions : collect_constants } Where Define (elaborate_recursion expr) 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 (sequence cs) 'sequence.cs 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) | 'package._ (pure expr) | 'prim._ (pure expr) | 'var._ (pure expr) | 'chain.{expr chain} (lift1 (use expr) Func expr 'chain.{expr chain}) | 'tuple.exprs (lift1 (sequence (LIST.map exprs use)) Func exprs 'tuple.exprs) | 'record.{labels inits} (lift1 (sequence (LIST.map inits use)) Func inits 'record.{labels inits}) | 'block.{binders expr} Define (compile_binder binder) Match binder | 'do.body (lift1 (use body) Func body 'do.body) | 'let.{pat body} (lift1 (use body) Func body 'let.{pat body}) ; In (lift2 (sequence (LIST.map binders compile_binder)) (pass expr) Func {binders expr} 'block.{binders expr}) | 'app.{func args} (lift2 (use func) (sequence (LIST.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 (sequence (LIST.map inits use)) (push_loop expr) Func {inits expr} 'iterate.{vars inits expr}) | 'continue.exprs (lift1 (sequence (LIST.map exprs use)) Func exprs 'continue.exprs) | 'unfold.{vars inits expr} Let tagged_vars (LIST.map vars [Func name 'var.name]) In (pass 'block.{ [ '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 (sequence (LIST.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}) | 'not.expr (lift1 (use expr) Func expr 'not.expr) | 'and.{test then} (lift2 (use test) (pass then) Func {test then} 'and.{test then}) | 'or.{test else} (lift2 (use test) (pass else) Func {test else} 'or.{test 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) (sequence (LIST.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)) | 'sequence.cs Match cs | 'nil 'nil | 'cons.{c cs} 'cons.{(Fold c context) (Fold 'sequence.cs context)} ; | 'push_loop.expr (Fold 'pass.expr 'loop) | 'use.expr (Fold (compile expr) 'other) | 'pass.expr Let expr Match context | 'loop Match expr | 'fold.exprs 'continue.exprs | _ expr ; | 'other expr ; In (Fold (compile expr) context) ; Define (collect_free_variables expr) 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 (collect name) 'collect.name Define (in_context vars c) 'in_context.{vars c} Define (eval expr) 'eval.expr Define (eval_func vars expr) 'eval_func.{vars expr} In Define (sequence cs) (LIST.fold cs (pure 'nil) Func {c1 c2} (lift2 c1 c2 LIST.cons)) In Define (compile expr) Match expr | 'true (pure expr) | 'false (pure expr) | 'num._ (pure expr) | 'str._ (pure expr) | 'package._ (pure expr) | 'prim._ (pure expr) | 'var.name (lift1 (collect name) [Func _ expr]) | 'chain.{expr chain} (lift1 (eval expr) Func expr 'chain.{expr chain}) | 'tuple.exprs (lift1 (sequence (LIST.map exprs eval)) Func exprs 'tuple.exprs) | 'record.{labels inits} (lift1 (sequence (LIST.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 (sequence (LIST.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 | 'do._ 'do.expr | 'let.{pat _} 'let.{pat expr} ;) In 'block.{binders expr}) | 'app.{func args} (lift2 (eval func) (sequence (LIST.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 (sequence (LIST.map inits eval)) (in_context vars (eval expr)) Func {inits expr} 'iterate.{vars inits expr}) | 'continue.exprs (lift1 (sequence (LIST.map exprs eval)) Func exprs 'continue.exprs) | 'cond.clauses Define (compile_clause {test body}) (lift2 (eval test) (eval body) Func clause clause) In (lift1 (sequence (LIST.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}) | 'not.expr (lift1 (eval expr) Func expr 'not.expr) | 'and.{test then} (lift2 (eval test) (eval then) Func {test then} 'and.{test then}) | 'or.{test else} (lift2 (eval test) (eval else) Func {test else} 'or.{test 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) (sequence (LIST.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 [Right "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 i expr) 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 (lookup var) 'lookup.var Define (in_context bindings c) 'in_context.{bindings c} Define (insert_func f) 'insert_func.f Define (eval expr) 'eval.expr In Define (sequence cs) (LIST.fold cs (pure 'nil) Func {c1 c2} (lift2 c1 c2 LIST.cons)) In Define (compile 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 (eval expr) Func expr 'chain.{expr chain}) | 'tuple.exprs (lift1 (sequence (LIST.map exprs eval)) Func exprs 'tuple.exprs) | 'record.{labels inits} (lift1 (sequence (LIST.map inits eval)) Func inits 'record.{labels inits}) | 'block.{binders expr} Let binder_exprs (LIST.map binders binder_expr) In (bind1 (sequence (LIST.map binder_exprs eval)) 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 (eval expr)) Func expr 'block.{binders expr})) | 'app.{func args} Match func | 'var.var (bind1 (lookup var) Func expr Match expr | 'func.{i num_params} Let num_args (LIST.length args) In Do Let is_compatible Or [num_params = num_args] Or [num_params = 1] [num_args = 1] In When !is_compatible (die "Protocol mismatch in function application.") End In (lift2 (eval func) (sequence (LIST.map args eval)) Func {func args} If [num_params = num_args] 'app_known.{i func args} 'app.{func args}) | 'expr (lift2 (eval func) (sequence (LIST.map args eval)) Func {func args} 'app.{func args}) ;) | _ (lift2 (eval func) (sequence (LIST.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 (sequence (LIST.map inits eval)) (in_context bindings (eval expr)) Func {inits expr} 'iterate.{vars inits expr}) | 'continue.exprs (lift1 (sequence (LIST.map exprs eval)) Func exprs 'continue.exprs) | 'cond.clauses Define (compile_clause {test body}) (lift2 (eval test) (eval body) Func clause clause) In (lift1 (sequence (LIST.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}) | 'not.expr (lift1 (eval expr) Func expr 'not.expr) | 'and.{test then} (lift2 (eval test) (eval then) Func {test then} 'and.{test then}) | 'or.{test else} (lift2 (eval test) (eval else) Func {test else} 'or.{test 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) (sequence (LIST.map clauses compile_clause)) Func {expr clauses} 'match.{expr clauses}) ; In Let MAP (SEARCH.MAP STRING.compare Func {key _} key) In Unfold {command env i funcs} From {'eval.expr MAP.empty i '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) ; Define (collect_constants program) 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 (intern_string s) 'intern_string.s Define (intern_label name) 'intern_label.name Define (intern_layout layout) 'intern_layout.layout Define (eval expr) 'eval.expr In Define (sequence cs) (LIST.fold cs (pure 'nil) Func {c1 c2} (lift2 c1 c2 LIST.cons)) In Let package_table Let MAP (SEARCH.MAP STRING.compare [Func {key _} key]) In Let {_ map} (LIST.reduce program {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} In Define (compile 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 (compile_access access) Match access | 'id.name (lift1 (intern_label name) Func id 'record_fetch.id) | 'num.i (pure 'tuple_fetch.i) ; In (lift2 (eval expr) (sequence (LIST.map chain compile_access)) Func {expr chain} 'chain.{expr chain}) | 'tuple.exprs (lift1 (sequence (LIST.map exprs eval)) Func exprs 'tuple.exprs) | 'record.{labels inits} (bind1 (sequence (LIST.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) (sequence (LIST.map inits eval)) Func {layout_id inits} 'record.{layout_id inits})) | 'block.{binders expr} Let binder_exprs (LIST.map binders binder_expr) In (lift2 (sequence (LIST.map binder_exprs eval)) (eval 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 (sequence (LIST.map args eval)) (eval func) Func {args func} 'closure_app_known.{j func args}) | 'app.{func args} Match func | 'prim.name Cond | (STRING.equal name "cons") (eval 'labeled.{"cons" 'tuple.args}) | (STRING.equal name "not_equal") (eval 'if.{'app.{'prim."equal" args} 'false 'true}) | True (lift1 (sequence (LIST.map args eval)) Func args 'prim_app.{name args}) ; | _ (lift2 (sequence (LIST.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 (sequence (LIST.map inits eval)) (eval expr) Func {inits expr} 'iterate.{vars inits expr}) | 'continue.exprs (lift1 (sequence (LIST.map exprs eval)) Func exprs 'continue.exprs) | 'cond.clauses Define (compile_clause {test body}) (lift2 (eval test) (eval body) Func clause clause) In (lift1 (sequence (LIST.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}) | 'not.expr (lift1 (eval expr) Func expr 'not.expr) | 'and.{test then} (lift2 (eval test) (eval then) Func {test then} 'and.{test then}) | 'or.{test else} (lift2 (eval test) (eval else) Func {test else} 'or.{test 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) (sequence (LIST.map clauses compile_clause)) Func {expr clauses} 'match.{expr clauses}) ; In Let command Define (eval_package package) (lift2 (eval package.init) (sequence (LIST.map package.functions eval)) Func {init functions} { : path package.path : imports package.imports : init : functions }) In (lift3 (intern_label "nil") (intern_label "cons") (sequence (LIST.map program eval_package)) Func {nil_label cons_label packages} {nil_label cons_label packages}) 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 {output 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 {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 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"