HCoop Git - jackhill/mal.git/blob - ocaml/step4_if_fn

1 module T = Types.Types

 let repl_env = Env.make (Some Core.ns)

5 let rec eval_ast ast env =

6 match ast with

     | T.Symbol s -> Env.get env ast

     | T.List { T.value = xs; T.meta = meta }

       -> T.List { T.value = (List.map (fun x -> eval x env) xs);

10 T.meta = meta }

     | T.Vector { T.value = xs; T.meta = meta }

       -> T.Vector { T.value = (List.map (fun x -> eval x env) xs);

13 T.meta = meta }

     | T.Map { T.value = xs; T.meta = meta }

       -> T.Map {T.meta = meta;

                 T.value = (Types.MalMap.fold

17 (fun k v m

                               -> Types.MalMap.add (eval k env) (eval v env) m)

19 xs

                              Types.MalMap.empty)}

21 | _ -> ast

22 and eval ast env =

23 match ast with

     | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } ->

25 let value = (eval expr env) in

           Env.set env key value; value

     | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] }

     | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List   { T.value = bindings }); body] } ->

         (let sub_env = Env.make (Some env) in

30 let rec bind_pairs = (function

31 | sym :: expr :: more ->

                 Env.set sub_env sym (eval expr sub_env);

33 bind_pairs more

             | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms")

35 | [] -> ())

36 in bind_pairs bindings;

37 eval body sub_env)

     | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } ->

         List.fold_left (fun x expr -> eval expr env) T.Nil body

     | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } ->

         if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env)

     | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } ->

         if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil

     | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] }

     | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List   { T.value = arg_names }; expr] } ->

46 Types.fn

47 (function args ->

             let sub_env = Env.make (Some env) in

49 let rec bind_args a b =

50 (match a, b with

                   | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args);

                   | (name :: names), (arg :: args) ->

53 Env.set sub_env name arg;

54 bind_args names args;

55 | [], [] -> ()

                   | _ -> raise (Invalid_argument "Bad param count in fn call"))

57 in bind_args arg_names args;

58 eval expr sub_env)

59 | T.List _ ->

60 (match eval_ast ast env with

          | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args

          | _ -> raise (Invalid_argument "Cannot invoke non-function"))

63 | _ -> eval_ast ast env

 let read str = Reader.read_str str

 let print exp = Printer.pr_str exp true

 let rep str env = print (eval (read str) env)

69 let rec main =

70 try

     Core.init Core.ns;

     ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env);

73 while true do

74 print_string "user> ";

       let line = read_line () in

76 try

77 print_endline (rep line repl_env);

78 with End_of_file -> ()

79 | Invalid_argument x ->

              output_string stderr ("Invalid_argument exception: " ^ x ^ "\n");

81 flush stderr

82 done

83 with End_of_file -> ()