ocaml/stepA_mal.ml

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