1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
|
structure Elab =
struct
structure StringMap = Map(type k = string val cmp = String.compare);
fun primop (s : string) : Syntax.primop =
case s of
"exit" => Syntax.PExit
| "add" => Syntax.PAdd
| "sub" => Syntax.PSub
| "mul" => Syntax.PMul
| "div" => Syntax.PDiv
| _ => raise Fail ("invalid op: " ^ s)
fun elab (env : int StringMap.map) (p : Syntax.expr) : Syntax.lexp =
case p of
Syntax.EIdent [i] => (case StringMap.lookup i env of
NONE => raise Fail ("unbound identifier " ^ i)
| SOME x => Syntax.LVar x)
| Syntax.EIdent _ => raise Fail "long identifiers are not supported"
| Syntax.EBuiltin builtin => Syntax.LPrim (primop builtin)
| Syntax.EInt i => Syntax.LInt i
| Syntax.EStr s => Syntax.LString s
| Syntax.ETuple exprs => Syntax.LRecord (map (elab env) exprs)
| Syntax.EList exprs =>
foldr
(fn (x, acc) =>
Syntax.LRecord [elab env x, acc])
(Syntax.LInt 0)
exprs
| Syntax.EApp (f, x) => Syntax.LApp (elab env f, elab env x)
| Syntax.ETyped (e, _) => elab env e
| Syntax.EAndAlso (_, _) => raise Fail "unimplemented"
| Syntax.EOrElse (_, _) => raise Fail "unimplemented"
| Syntax.ELet ([], body) => elab env body
| Syntax.ELet (Syntax.DVal (pat, v) :: decls, body) =>
elab env (Syntax.ECase (v, [(pat, Syntax.ELet (decls, body))]))
| Syntax.ELambda (pat, body) =>
let
val v = Gensym.new ()
val env' =
case pat of
Syntax.PVar name => StringMap.insert name v env
| _ => env
in Syntax.LFn (v, elab env' body)
end
| Syntax.ECase (expr, []) => raise Fail "nonexhaustive match"
| Syntax.ECase (expr, arms) =>
let
fun go [] _ = raise Fail "nonexhaustive match"
| go ((Syntax.PWild, body) :: []) acc = Syntax.LSwitch (elab env expr, rev acc, elab env body)
| go ((Syntax.PVar name, body) :: []) acc =
let val v = Gensym.new () in
Syntax.LApp (Syntax.LFn (v, Syntax.LSwitch (Syntax.LVar v, rev acc, elab (StringMap.insert name v env) body)), elab env expr)
end
| go ((Syntax.PInt i, body) :: rest) acc =
go rest ((i, elab env body) :: acc)
| go _ _ = raise Fail "redundant match"
in go arms []
end
fun elaborate (p : Syntax.expr) : Syntax.lexp = elab StringMap.empty p
end
|
