Commit | Line | Data |
---|---|---|
8f1ee487 PS |
1 | module Eval |
2 | ||
3 | open Types | |
4 | ||
5 | type Env = Map<string, Node> | |
6 | ||
1e4687b4 | 7 | let errExpected tok = EvalError(sprintf "expected %s" tok) |
8f1ee487 | 8 | |
a836d8f3 | 9 | let iterPairs f (source : seq<_>) = |
0756d620 PS |
10 | use iter = source.GetEnumerator() |
11 | let rec loop () = | |
12 | if iter.MoveNext() then | |
13 | let first = iter.Current | |
14 | if not (iter.MoveNext()) then raise <| errExpected "even node count" | |
15 | let second = iter.Current | |
16 | f first second | |
17 | loop () | |
18 | loop () | |
19 | ||
8f1ee487 | 20 | let rec eval_ast env = function |
37bb752e | 21 | | Symbol(sym) -> Env.get env sym |
8f1ee487 PS |
22 | | List(lst) -> lst |> List.map (eval env) |> List |
23 | | Vector(arr) -> arr |> Array.map (eval env) |> Vector | |
24 | | Map(map) -> map |> Map.map (fun k v -> eval env v) |> Map | |
25 | | node -> node | |
26 | ||
6a4627fb PS |
27 | and defBangForm env = function |
28 | | [sym; form] -> | |
1e4687b4 | 29 | match sym with |
6a4627fb PS |
30 | | Symbol(sym) -> |
31 | let node = eval env form | |
37bb752e PS |
32 | Env.set env sym node |
33 | node | |
1e4687b4 PS |
34 | | _ -> raise <| errExpected "symbol" |
35 | | _ -> raise <| Core.errArity () | |
36 | ||
0756d620 PS |
37 | and setBinding env first second = |
38 | let s = match first with | |
39 | | Symbol(s) -> s | |
40 | | _ -> raise <| errExpected "symbol" | |
41 | let form = eval env second | |
42 | Env.set env s form | |
1e4687b4 | 43 | |
8862f80e | 44 | and letStarForm outer = function |
6a4627fb | 45 | | [bindings; form] -> |
8862f80e PS |
46 | let inner = Env.makeNew outer [] [] |
47 | let binder = setBinding inner | |
1e4687b4 | 48 | match bindings with |
a836d8f3 PS |
49 | | List(lst) -> lst |> iterPairs binder |
50 | | Vector(vec) -> vec |> iterPairs binder | |
1e4687b4 | 51 | | _ -> raise <| errExpected "list or vector" |
8862f80e | 52 | inner, form |
1e4687b4 | 53 | | _ -> raise <| Core.errArity () |
37bb752e | 54 | |
6a4627fb PS |
55 | and ifForm env = function |
56 | | [condForm; trueForm; falseForm] -> ifForm3 env condForm trueForm falseForm | |
57 | | [condForm; trueForm] -> ifForm3 env condForm trueForm Nil | |
58 | | _ -> raise <| Core.errArity () | |
59 | ||
60 | and ifForm3 env condForm trueForm falseForm = | |
61 | match eval env condForm with | |
8862f80e PS |
62 | | Bool(false) | Nil -> falseForm |
63 | | _ -> trueForm | |
6a4627fb PS |
64 | |
65 | and doForm env = function | |
8862f80e | 66 | | [a] -> a |
6a4627fb PS |
67 | | a::rest -> |
68 | eval env a |> ignore | |
69 | doForm env rest | |
70 | | _ -> raise <| Core.errArity () | |
71 | ||
a97c3028 PS |
72 | and fnStarForm outer nodes = |
73 | let makeFunc binds body = | |
8862f80e PS |
74 | let f = fun nodes -> |
75 | let inner = Env.makeNew outer binds nodes | |
76 | eval inner body | |
77 | Env.makeFunc f body binds outer | |
a97c3028 PS |
78 | |
79 | match nodes with | |
80 | | [List(binds); body] -> makeFunc binds body | |
81 | | [Vector(binds); body] -> makeFunc (List.ofArray binds) body | |
82 | | [_; _] -> raise <| errExpected "bindings of list or vector" | |
83 | | _ -> raise <| Core.errArity () | |
84 | ||
8f1ee487 | 85 | and eval env = function |
6a4627fb | 86 | | List(Symbol("def!")::rest) -> defBangForm env rest |
8862f80e PS |
87 | | List(Symbol("let*")::rest) -> |
88 | let inner, form = letStarForm env rest | |
89 | form |> eval inner | |
90 | | List(Symbol("if")::rest) -> ifForm env rest |> eval env | |
91 | | List(Symbol("do")::rest) -> doForm env rest |> eval env | |
a97c3028 | 92 | | List(Symbol("fn*")::rest) -> fnStarForm env rest |
8f1ee487 PS |
93 | | List(_) as node -> |
94 | let resolved = node |> eval_ast env | |
95 | match resolved with | |
8862f80e PS |
96 | | List(Func(_, f, _, _, [])::rest) -> f rest |
97 | | List(Func(_, _, body, binds, outer)::rest) -> | |
98 | let inner = Env.makeNew outer binds rest | |
99 | body |> eval inner | |
1e4687b4 | 100 | | _ -> raise <| errExpected "function" |
8f1ee487 | 101 | | node -> node |> eval_ast env |