Commit | Line | Data |
---|---|---|
37bb752e PS |
1 | module Env |
2 | ||
3 | open Types | |
4 | ||
5 | type Env = System.Collections.Generic.Dictionary<string, Node> | |
6 | type EnvChain = Env list | |
7 | ||
8 | let errSymbolNotFound s = EvalError(sprintf "'%s' not found" s) | |
9 | let errNoEnvironment () = EvalError("no environment") | |
a97c3028 PS |
10 | let errTooManyValues () = EvalError("too many values") |
11 | let errNotEnoughValues () = EvalError("not enough values") | |
12 | let errExpectedSymbol () = EvalError("expected symbol") | |
13 | let errOnlyOneSymbol () = EvalError("only one symbol after &") | |
37bb752e PS |
14 | |
15 | let makeEmpty () = Env() | |
16 | ||
17 | let ofList lst = | |
18 | let env = makeEmpty () | |
19 | let accumulate (e : Env) (k, v) = e.Add(k, v); e | |
20 | List.fold accumulate env lst | |
21 | ||
22 | let set (env : EnvChain) key node = | |
23 | match env with | |
24 | | head::_ -> head.[key] <- node | |
25 | | _ -> raise <| errNoEnvironment () | |
26 | ||
27 | let rec find (chain : EnvChain) key = | |
28 | match chain with | |
29 | | [] -> None | |
30 | | env::rest -> | |
31 | match env.TryGetValue(key) with | |
32 | | true, v -> Some(v) | |
33 | | false, _ -> find rest key | |
34 | ||
35 | let get chain key = | |
36 | match find chain key with | |
37 | | Some(v) -> v | |
38 | | None -> raise <| errSymbolNotFound key | |
39 | ||
a836d8f3 PS |
40 | let makeFunc = |
41 | let counter = ref 0 | |
42 | let getNext () = System.Threading.Interlocked.Increment(counter) | |
7822be33 | 43 | fun f -> Func(getNext (), f) |
a836d8f3 | 44 | |
37bb752e | 45 | let makeRootEnv () = |
a836d8f3 | 46 | let wrap name f = name, makeFunc f |
37bb752e | 47 | let env = |
a836d8f3 PS |
48 | [ wrap "+" Core.add; |
49 | wrap "-" Core.subtract; | |
50 | wrap "*" Core.multiply; | |
51 | wrap "/" Core.divide; | |
52 | wrap "list" Core.list; | |
53 | wrap "list?" Core.isList; | |
54 | wrap "empty?" Core.isEmpty; | |
55 | wrap "count" Core.count; | |
56 | wrap "=" Core.eq; | |
57 | wrap "<" Core.lt; | |
58 | wrap "<=" Core.le; | |
59 | wrap ">=" Core.ge; | |
6a4627fb PS |
60 | wrap ">" Core.gt; |
61 | wrap "pr-str" Core.pr_str; | |
62 | wrap "str" Core.str; | |
63 | wrap "prn" Core.prn; | |
64 | wrap "println" Core.println ] | |
37bb752e PS |
65 | |> ofList |
66 | [ env ] | |
67 | ||
a97c3028 PS |
68 | let makeNew outer symbols nodes = |
69 | let env = (makeEmpty ())::outer | |
70 | let rec loop symbols nodes = | |
71 | match symbols, nodes with | |
72 | | [Symbol("&"); Symbol(s)], nodes -> | |
73 | set env s (List nodes) | |
74 | env | |
75 | | Symbol("&")::_, _ -> raise <| errOnlyOneSymbol () | |
76 | | Symbol(s)::symbols, n::nodes -> | |
77 | set env s n | |
78 | loop symbols nodes | |
79 | | [], [] -> env | |
80 | | _, [] -> raise <| errNotEnoughValues () | |
81 | | [], _ -> raise <| errTooManyValues () | |
82 | | _, _ -> raise <| errExpectedSymbol () | |
83 | loop symbols nodes |