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