ocaml/step8_macros.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 "defmacro! 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 _ as ast ->
 104       (match eval_ast ast env with
 105          | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args
 106          | _ -> raise (Invalid_argument "Cannot invoke non-function"))
 107     | ast -> eval_ast ast env
 108
 109 let read str = Reader.read_str str
 110 let print exp = Printer.pr_str exp true
 111 let rep str env = print (eval (read str) env)
 112
 113 let rec main =
 114   try
 115     Core.init Core.ns;
 116     Env.set repl_env (Types.symbol "*ARGV*")
 117             (Types.list (if Array.length Sys.argv > 1
 118                          then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv))))
 119                          else []));
 120     Env.set repl_env (Types.symbol "eval")
 121             (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil));
 122
 123     ignore (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" repl_env);
 124     ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env);
 125     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);
 126     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);
 127
 128     if Array.length Sys.argv > 1 then
 129       ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env)
 130     else
 131       while true do
 132         print_string "user> ";
 133         let line = read_line () in
 134         try
 135           print_endline (rep line repl_env);
 136         with End_of_file -> ()
 137            | Invalid_argument x ->
 138               output_string stderr ("Invalid_argument exception: " ^ x ^ "\n");
 139               flush stderr
 140            | _ ->
 141               output_string stderr ("Erroringness!\n");
 142               flush stderr
 143       done
 144   with End_of_file -> ()