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