Commit | Line | Data |
---|---|---|
fd3adc52 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 | |
8 | | T.Vector { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast | |
9 | | T.List { T.value = T.List { T.value = [T.Symbol {T.value = "splice-unquote"}; head]} :: tail } | |
10 | | T.Vector { T.value = T.List { T.value = [T.Symbol {T.value = "splice-unquote"}; head]} :: tail } -> | |
11 | Types.list [Types.symbol "concat"; head; quasiquote (Types.list tail)] | |
12 | | T.List { T.value = head :: tail } | |
13 | | T.Vector { T.value = head :: tail } -> | |
14 | Types.list [Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ] | |
15 | | ast -> Types.list [Types.symbol "quote"; ast] | |
16 | ||
2b8e0ea4 | 17 | let is_macro_call ast env = |
fd3adc52 C |
18 | match ast with |
19 | | T.List { T.value = s :: args } -> | |
20 | (match (try Env.get env s with _ -> T.Nil) with | |
2b8e0ea4 | 21 | | T.Fn { T.meta = T.Map { T.value = meta } } |
d90be1a9 | 22 | -> Types.MalMap.mem Core.kw_macro meta && Types.to_bool (Types.MalMap.find Core.kw_macro meta) |
2b8e0ea4 C |
23 | | _ -> false) |
24 | | _ -> false | |
25 | ||
26 | let rec macroexpand ast env = | |
27 | if is_macro_call ast env | |
28 | then match ast with | |
29 | | T.List { T.value = s :: args } -> | |
30 | (match (try Env.get env s with _ -> T.Nil) with | |
31 | | T.Fn { T.value = f } -> macroexpand (f args) env | |
32 | | _ -> ast) | |
33 | | _ -> ast | |
34 | else ast | |
fd3adc52 C |
35 | |
36 | let rec eval_ast ast env = | |
37 | match ast with | |
38 | | T.Symbol s -> Env.get env ast | |
39 | | T.List { T.value = xs; T.meta = meta } | |
40 | -> T.List { T.value = (List.map (fun x -> eval x env) xs); | |
2b8e0ea4 | 41 | T.meta = meta } |
fd3adc52 C |
42 | | T.Vector { T.value = xs; T.meta = meta } |
43 | -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); | |
2b8e0ea4 | 44 | T.meta = meta } |
fd3adc52 C |
45 | | T.Map { T.value = xs; T.meta = meta } |
46 | -> T.Map {T.meta = meta; | |
fd3adc52 C |
47 | T.value = (Types.MalMap.fold |
48 | (fun k v m | |
49 | -> Types.MalMap.add (eval k env) (eval v env) m) | |
50 | xs | |
51 | Types.MalMap.empty)} | |
52 | | _ -> ast | |
53 | and eval ast env = | |
54 | match macroexpand ast env with | |
127b36c1 | 55 | | T.List { T.value = [] } -> ast |
fd3adc52 C |
56 | | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> |
57 | let value = (eval expr env) in | |
58 | Env.set env key value; value | |
59 | | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } -> | |
60 | (match (eval expr env) with | |
61 | | T.Fn { T.value = f; T.meta = meta } -> | |
d90be1a9 | 62 | let fn = T.Fn { T.value = f; meta = Core.assoc [meta; Core.kw_macro; (T.Bool true)]} |
2b8e0ea4 | 63 | in Env.set env key fn; fn |
fd3adc52 C |
64 | | _ -> raise (Invalid_argument "devmacro! value must be a fn")) |
65 | | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } | |
66 | | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> | |
67 | (let sub_env = Env.make (Some env) in | |
68 | let rec bind_pairs = (function | |
69 | | sym :: expr :: more -> | |
70 | Env.set sub_env sym (eval expr sub_env); | |
71 | bind_pairs more | |
72 | | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") | |
73 | | [] -> ()) | |
74 | in bind_pairs bindings; | |
75 | eval body sub_env) | |
76 | | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> | |
77 | List.fold_left (fun x expr -> eval expr env) T.Nil body | |
78 | | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> | |
79 | if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) | |
80 | | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> | |
81 | if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil | |
82 | | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } | |
83 | | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> | |
84 | Types.fn | |
85 | (function args -> | |
86 | let sub_env = Env.make (Some env) in | |
87 | let rec bind_args a b = | |
88 | (match a, b with | |
89 | | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); | |
90 | | (name :: names), (arg :: args) -> | |
91 | Env.set sub_env name arg; | |
92 | bind_args names args; | |
93 | | [], [] -> () | |
94 | | _ -> raise (Invalid_argument "Bad param count in fn call")) | |
95 | in bind_args arg_names args; | |
96 | eval expr sub_env) | |
97 | | T.List { T.value = [T.Symbol { T.value = "quote" }; ast] } -> ast | |
98 | | T.List { T.value = [T.Symbol { T.value = "quasiquote" }; ast] } -> | |
99 | eval (quasiquote ast) env | |
100 | | T.List { T.value = [T.Symbol { T.value = "macroexpand" }; ast] } -> | |
101 | macroexpand ast env | |
102 | | T.List { T.value = [T.Symbol { T.value = "try*" }; scary ; | |
103 | T.List { T.value = [T.Symbol { T.value = "catch*" }; | |
104 | local ; handler]}]} -> | |
105 | (try (eval scary env) | |
106 | with exn -> | |
107 | let value = match exn with | |
108 | | Types.MalExn value -> value | |
109 | | Invalid_argument msg -> T.String msg | |
110 | | _ -> (T.String "OCaml exception") in | |
111 | let sub_env = Env.make (Some env) in | |
112 | Env.set sub_env local value; | |
113 | eval handler sub_env) | |
114 | | T.List _ as ast -> | |
115 | (match eval_ast ast env with | |
116 | | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args | |
117 | | _ -> raise (Invalid_argument "Cannot invoke non-function")) | |
118 | | ast -> eval_ast ast env | |
119 | ||
120 | let read str = Reader.read_str str | |
121 | let print exp = Printer.pr_str exp true | |
122 | let rep str env = print (eval (read str) env) | |
123 | ||
124 | let rec main = | |
125 | try | |
126 | Core.init Core.ns; | |
127 | Env.set repl_env (Types.symbol "*ARGV*") | |
128 | (Types.list (if Array.length Sys.argv > 1 | |
129 | then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) | |
130 | else [])); | |
131 | Env.set repl_env (Types.symbol "eval") | |
132 | (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); | |
133 | ||
134 | ignore (rep "(def! *host-language* \"ocaml\")" repl_env); | |
135 | ignore (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" repl_env); | |
136 | ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); | |
137 | ignore (rep "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" repl_env); | |
48572759 DM |
138 | ignore (rep "(def! *gensym-counter* (atom 0))" repl_env); |
139 | ignore (rep "(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))" repl_env); | |
140 | ignore (rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))" repl_env); | |
fd3adc52 C |
141 | |
142 | if Array.length Sys.argv > 1 then | |
19950b9f DM |
143 | try |
144 | ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env); | |
145 | with | |
146 | | Types.MalExn exc -> | |
147 | output_string stderr ("Exception: " ^ (print exc) ^ "\n"); | |
148 | flush stderr | |
1ac37587 C |
149 | else begin |
150 | ignore (rep "(println (str \"Mal [\" *host-language* \"]\"))" repl_env); | |
151 | while true do | |
152 | print_string "user> "; | |
153 | let line = read_line () in | |
154 | try | |
155 | print_endline (rep line repl_env); | |
156 | with End_of_file -> () | |
19950b9f DM |
157 | | Types.MalExn exc -> |
158 | output_string stderr ("Exception: " ^ (print exc) ^ "\n"); | |
159 | flush stderr | |
1ac37587 C |
160 | | Invalid_argument x -> |
161 | output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); | |
162 | flush stderr | |
163 | | _ -> | |
164 | output_string stderr ("Erroringness!\n"); | |
165 | flush stderr | |
166 | done | |
167 | end | |
fd3adc52 | 168 | with End_of_file -> () |