2015-01-26 07:30:37 +03:00
|
|
|
module T = Types.Types
|
|
|
|
|
2014-01-30 05:05:05 +04:00
|
|
|
let num_fun f = Types.fn
|
2015-01-23 16:17:35 +03:00
|
|
|
(function
|
2015-01-26 07:30:37 +03:00
|
|
|
| [(T.Int a); (T.Int b)] -> T.Int (f a b)
|
2015-01-23 16:17:35 +03:00
|
|
|
| _ -> raise (Invalid_argument "Numeric args required for this Mal builtin"))
|
|
|
|
|
|
|
|
let repl_env = Env.make None
|
|
|
|
|
|
|
|
let init_repl env = begin
|
2022-01-10 02:15:40 +03:00
|
|
|
Env.set env "+" (num_fun ( + ));
|
|
|
|
Env.set env "-" (num_fun ( - ));
|
|
|
|
Env.set env "*" (num_fun ( * ));
|
|
|
|
Env.set env "/" (num_fun ( / ));
|
2015-01-23 16:17:35 +03:00
|
|
|
end
|
|
|
|
|
2022-01-10 02:15:40 +03:00
|
|
|
let rec eval ast env =
|
|
|
|
(match Env.get env "DEBUG-EVAL" with
|
|
|
|
| None -> ()
|
|
|
|
| Some T.Nil -> ()
|
|
|
|
| Some (T.Bool false) -> ()
|
|
|
|
| Some _ ->
|
|
|
|
output_string stderr ("EVAL: " ^ (Printer.pr_str ast true) ^ "\n");
|
|
|
|
flush stderr);
|
2015-01-23 16:17:35 +03:00
|
|
|
match ast with
|
2022-01-10 02:15:40 +03:00
|
|
|
| T.Symbol s -> (match Env.get env s with
|
|
|
|
| Some v -> v
|
|
|
|
| None -> raise (Invalid_argument ("'" ^ s ^ "' not found")))
|
2015-01-27 07:05:13 +03:00
|
|
|
| T.Vector { T.value = xs; T.meta = meta }
|
2015-01-30 07:29:54 +03:00
|
|
|
-> T.Vector { T.value = (List.map (fun x -> eval x env) xs);
|
2015-01-30 17:10:24 +03:00
|
|
|
T.meta = meta }
|
2015-01-27 07:05:13 +03:00
|
|
|
| T.Map { T.value = xs; T.meta = meta }
|
|
|
|
-> T.Map {T.meta = meta;
|
|
|
|
T.value = (Types.MalMap.fold
|
|
|
|
(fun k v m
|
2021-08-21 20:08:17 +03:00
|
|
|
-> Types.MalMap.add k (eval v env) m)
|
2015-01-27 07:05:13 +03:00
|
|
|
xs
|
|
|
|
Types.MalMap.empty)}
|
2022-01-10 02:15:40 +03:00
|
|
|
| T.List { T.value = [T.Symbol "def!"; T.Symbol key; expr] } ->
|
2015-01-23 16:17:35 +03:00
|
|
|
let value = (eval expr env) in
|
|
|
|
Env.set env key value; value
|
2022-01-10 02:15:40 +03:00
|
|
|
| T.List { T.value = [T.Symbol "let*"; (T.Vector { T.value = bindings }); body] }
|
|
|
|
| T.List { T.value = [T.Symbol "let*"; (T.List { T.value = bindings }); body] } ->
|
2015-01-23 16:17:35 +03:00
|
|
|
(let sub_env = Env.make (Some env) in
|
|
|
|
let rec bind_pairs = (function
|
2022-01-10 02:15:40 +03:00
|
|
|
| T.Symbol sym :: expr :: more ->
|
2015-01-23 16:17:35 +03:00
|
|
|
Env.set sub_env sym (eval expr sub_env);
|
|
|
|
bind_pairs more
|
2022-01-10 02:15:40 +03:00
|
|
|
| _ :: _ :: _ -> raise (Invalid_argument "let* keys must be symbols")
|
2015-01-23 16:17:35 +03:00
|
|
|
| _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms")
|
|
|
|
| [] -> ())
|
|
|
|
in bind_pairs bindings;
|
|
|
|
eval body sub_env)
|
2022-01-10 02:15:40 +03:00
|
|
|
| T.List { T.value = (a0 :: args) } ->
|
|
|
|
(match eval a0 env with
|
|
|
|
| T.Fn { T.value = f } -> f (List.map (fun x -> eval x env) args)
|
2015-01-23 16:17:35 +03:00
|
|
|
| _ -> raise (Invalid_argument "Cannot invoke non-function"))
|
2022-01-10 02:15:40 +03:00
|
|
|
| _ -> ast
|
2015-01-23 16:17:35 +03:00
|
|
|
|
|
|
|
let read str = Reader.read_str str
|
2015-01-24 04:05:03 +03:00
|
|
|
let print exp = Printer.pr_str exp true
|
2015-01-23 16:17:35 +03:00
|
|
|
let rep str env = print (eval (read str) env)
|
|
|
|
|
|
|
|
let rec main =
|
|
|
|
try
|
|
|
|
init_repl repl_env;
|
|
|
|
while true do
|
|
|
|
print_string "user> ";
|
|
|
|
let line = read_line () in
|
|
|
|
try
|
|
|
|
print_endline (rep line repl_env);
|
|
|
|
with End_of_file -> ()
|
|
|
|
| Invalid_argument x ->
|
|
|
|
output_string stderr ("Invalid_argument exception: " ^ x ^ "\n");
|
|
|
|
flush stderr
|
|
|
|
done
|
|
|
|
with End_of_file -> ()
|