Commit | Line | Data |
---|---|---|
efb850b5 C |
1 | module T = Types.Types |
2 | ||
3 | let repl_env = Env.make (Some Core.ns) | |
4 | ||
5 | let rec quasiquote ast = | |
6 | match ast with | |
7 | | T.List { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast | |
fbfe6784 NB |
8 | | T.List {T.value = xs} -> List.fold_right qq_folder xs (Types.list []) |
9 | | T.Vector {T.value = xs} -> Types.list [Types.symbol "vec"; | |
10 | List.fold_right qq_folder xs (Types.list [])] | |
11 | | T.Map _ -> Types.list [Types.symbol "quote"; ast] | |
12 | | T.Symbol _ -> Types.list [Types.symbol "quote"; ast] | |
13 | | _ -> ast | |
14 | and qq_folder elt acc = | |
15 | match elt with | |
16 | | T.List {T.value = [T.Symbol {T.value = "splice-unquote"}; x]} -> Types.list [Types.symbol "concat"; x; acc] | |
17 | | _ -> Types.list [Types.symbol "cons"; quasiquote elt; acc] | |
efb850b5 C |
18 | |
19 | let rec eval_ast ast env = | |
20 | match ast with | |
21 | | T.Symbol s -> Env.get env ast | |
22 | | T.List { T.value = xs; T.meta = meta } | |
ecd3b6d8 | 23 | -> T.List { T.value = (List.map (fun x -> eval x env) xs); |
2b8e0ea4 | 24 | T.meta = meta } |
efb850b5 | 25 | | T.Vector { T.value = xs; T.meta = meta } |
ecd3b6d8 | 26 | -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); |
2b8e0ea4 | 27 | T.meta = meta } |
efb850b5 C |
28 | | T.Map { T.value = xs; T.meta = meta } |
29 | -> T.Map {T.meta = meta; | |
30 | T.value = (Types.MalMap.fold | |
31 | (fun k v m | |
32 | -> Types.MalMap.add (eval k env) (eval v env) m) | |
33 | xs | |
34 | Types.MalMap.empty)} | |
35 | | _ -> ast | |
36 | and eval ast env = | |
37 | match ast with | |
127b36c1 | 38 | | T.List { T.value = [] } -> ast |
efb850b5 C |
39 | | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> |
40 | let value = (eval expr env) in | |
41 | Env.set env key value; value | |
42 | | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } | |
43 | | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> | |
44 | (let sub_env = Env.make (Some env) in | |
45 | let rec bind_pairs = (function | |
46 | | sym :: expr :: more -> | |
47 | Env.set sub_env sym (eval expr sub_env); | |
48 | bind_pairs more | |
49 | | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") | |
50 | | [] -> ()) | |
51 | in bind_pairs bindings; | |
52 | eval body sub_env) | |
53 | | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> | |
54 | List.fold_left (fun x expr -> eval expr env) T.Nil body | |
55 | | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> | |
56 | if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) | |
57 | | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> | |
58 | if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil | |
59 | | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } | |
60 | | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> | |
fb21afa7 | 61 | Types.fn |
efb850b5 C |
62 | (function args -> |
63 | let sub_env = Env.make (Some env) in | |
64 | let rec bind_args a b = | |
65 | (match a, b with | |
66 | | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); | |
67 | | (name :: names), (arg :: args) -> | |
68 | Env.set sub_env name arg; | |
69 | bind_args names args; | |
70 | | [], [] -> () | |
71 | | _ -> raise (Invalid_argument "Bad param count in fn call")) | |
72 | in bind_args arg_names args; | |
73 | eval expr sub_env) | |
74 | | T.List { T.value = [T.Symbol { T.value = "quote" }; ast] } -> ast | |
fbfe6784 NB |
75 | | T.List { T.value = [T.Symbol { T.value = "quasiquoteexpand" }; ast] } -> |
76 | quasiquote ast | |
efb850b5 C |
77 | | T.List { T.value = [T.Symbol { T.value = "quasiquote" }; ast] } -> |
78 | eval (quasiquote ast) env | |
79 | | T.List _ -> | |
80 | (match eval_ast ast env with | |
ecd3b6d8 | 81 | | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args |
efb850b5 C |
82 | | _ -> raise (Invalid_argument "Cannot invoke non-function")) |
83 | | _ -> eval_ast ast env | |
84 | ||
85 | let read str = Reader.read_str str | |
86 | let print exp = Printer.pr_str exp true | |
87 | let rep str env = print (eval (read str) env) | |
88 | ||
89 | let rec main = | |
90 | try | |
91 | Core.init Core.ns; | |
92 | Env.set repl_env (Types.symbol "*ARGV*") | |
93 | (Types.list (if Array.length Sys.argv > 1 | |
94 | then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) | |
95 | else [])); | |
96 | Env.set repl_env (Types.symbol "eval") | |
fb21afa7 | 97 | (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); |
e6d41de4 | 98 | ignore (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" repl_env); |
efb850b5 C |
99 | ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); |
100 | ||
101 | if Array.length Sys.argv > 1 then | |
102 | ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env) | |
103 | else | |
104 | while true do | |
105 | print_string "user> "; | |
106 | let line = read_line () in | |
107 | try | |
108 | print_endline (rep line repl_env); | |
109 | with End_of_file -> () | |
110 | | Invalid_argument x -> | |
111 | output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); | |
112 | flush stderr | |
113 | done | |
114 | with End_of_file -> () |