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