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