OCaml: Add Step 8

9 files changed, 183 insertions, 40 deletions

diff --git a/ocaml/Makefile b/ocaml/Makefile
index be51a88..b52c69b 100644
--- a/ocaml/Makefile
+++ b/ocaml/Makefile
@@ -1,5 +1,6 @@
 STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml step3_env.ml \
-        step4_if_fn_do.ml step5_tco.ml step6_file.ml step7_quote.ml
+        step4_if_fn_do.ml step5_tco.ml step6_file.ml step7_quote.ml \
+	step8_macros.ml
 MODULES = types.ml reader.ml printer.ml env.ml core.ml
 LIBS = str.cmxa
 MAL_LIB = mal_lib.cmxa
diff --git a/ocaml/core.ml b/ocaml/core.ml
index a5131ce..98f8c8c 100644
--- a/ocaml/core.ml
+++ b/ocaml/core.ml
@@ -1,7 +1,7 @@
 module T = Types.Types
 let ns = Env.make None
 
-let num_fun t f = T.Fn
+let num_fun t f = Types.fn
   (function
     | [(T.Int a); (T.Int b)] -> t (f a b)
     | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin"))
@@ -26,55 +26,66 @@ let init env = begin
   Env.set env (Types.symbol ">")  (num_fun mk_bool ( >  ));
   Env.set env (Types.symbol ">=") (num_fun mk_bool ( >= ));
 
-  Env.set env (Types.symbol "list") (T.Fn (function xs -> Types.list xs));
+  Env.set env (Types.symbol "list") (Types.fn (function xs -> Types.list xs));
   Env.set env (Types.symbol "list?")
-    (T.Fn (function [T.List _] -> T.Bool true | _ -> T.Bool false));
+    (Types.fn (function [T.List _] -> T.Bool true | _ -> T.Bool false));
   Env.set env (Types.symbol "empty?")
-    (T.Fn (function [T.List {T.value = []}] -> T.Bool true | _ -> T.Bool false));
+    (Types.fn (function [T.List {T.value = []}] -> T.Bool true | _ -> T.Bool false));
   Env.set env (Types.symbol "count")
-    (T.Fn (function [T.List {T.value = xs}] -> T.Int (List.length xs) | _ -> T.Int 0));
+    (Types.fn (function [T.List {T.value = xs}] -> T.Int (List.length xs) | _ -> T.Int 0));
   Env.set env (Types.symbol "=")
-    (T.Fn (function
-            | [T.List a; T.Vector b] -> T.Bool (a = b)
-            | [T.Vector a; T.List b] -> T.Bool (a = b)
-            | [a; b] -> T.Bool (a = b)
-            | _ -> T.Bool false));
+    (Types.fn (function
+                | [T.List a; T.Vector b] -> T.Bool (a = b)
+                | [T.Vector a; T.List b] -> T.Bool (a = b)
+                | [a; b] -> T.Bool (a = b)
+                | _ -> T.Bool false));
 
   Env.set env (Types.symbol "pr-str")
-    (T.Fn (function xs ->
+    (Types.fn (function xs ->
       T.String (String.concat " " (List.map (fun s -> Printer.pr_str s true) xs))));
   Env.set env (Types.symbol "str")
-    (T.Fn (function xs ->
+    (Types.fn (function xs ->
       T.String (String.concat "" (List.map (fun s -> Printer.pr_str s false) xs))));
   Env.set env (Types.symbol "prn")
-    (T.Fn (function xs ->
+    (Types.fn (function xs ->
       print_endline (String.concat " " (List.map (fun s -> Printer.pr_str s true) xs));
       T.Nil));
   Env.set env (Types.symbol "println")
-    (T.Fn (function xs ->
+    (Types.fn (function xs ->
       print_endline (String.concat " " (List.map (fun s -> Printer.pr_str s false) xs));
       T.Nil));
 
   Env.set env (Types.symbol "compare")
-    (T.Fn (function [a; b] -> T.Int (compare a b) | _ -> T.Nil));
+    (Types.fn (function [a; b] -> T.Int (compare a b) | _ -> T.Nil));
   Env.set env (Types.symbol "with-meta")
-    (T.Fn (function [a; b] -> Reader.with_meta a b | _ -> T.Nil));
+    (Types.fn (function [a; b] -> Reader.with_meta a b | _ -> T.Nil));
   Env.set env (Types.symbol "meta")
-    (T.Fn (function [x] -> Printer.meta x | _ -> T.Nil));
+    (Types.fn (function [x] -> Printer.meta x | _ -> T.Nil));
 
   Env.set env (Types.symbol "read-string")
-    (T.Fn (function [T.String x] -> Reader.read_str x | _ -> T.Nil));
+    (Types.fn (function [T.String x] -> Reader.read_str x | _ -> T.Nil));
   Env.set env (Types.symbol "slurp")
-    (T.Fn (function [T.String x] -> T.String (Reader.slurp x) | _ -> T.Nil));
+    (Types.fn (function [T.String x] -> T.String (Reader.slurp x) | _ -> T.Nil));
 
   Env.set env (Types.symbol "cons")
-    (T.Fn (function [x; xs] -> Types.list (x :: (seq xs)) | _ -> T.Nil));
+    (Types.fn (function [x; xs] -> Types.list (x :: (seq xs)) | _ -> T.Nil));
   Env.set env (Types.symbol "concat")
-    (T.Fn (let rec concat =
-             function
-               | x :: y :: more -> concat ((Types.list ((seq x) @ (seq y))) :: more)
-               | [x] -> x
-               | [] -> Types.list []
-           in concat));
+    (Types.fn (let rec concat =
+                 function
+                 | x :: y :: more -> concat ((Types.list ((seq x) @ (seq y))) :: more)
+                 | [x] -> x
+                 | [] -> Types.list []
+               in concat));
+
+  Env.set env (Types.symbol "nth")
+    (Types.fn (function [xs; T.Int i] -> List.nth (seq xs) i | _ -> T.Nil));
+  Env.set env (Types.symbol "first")
+    (Types.fn (function
+                | [xs] -> (match seq xs with x :: _ -> x | _ -> T.Nil)
+                | _ -> T.Nil));
+  Env.set env (Types.symbol "rest")
+    (Types.fn (function
+                | [xs] -> Types.list (match seq xs with _ :: xs -> xs | _ -> [])
+                | _ -> T.Nil));
 end
 
diff --git a/ocaml/step2_eval.ml b/ocaml/step2_eval.ml
index 50751f9..62de875 100644
--- a/ocaml/step2_eval.ml
+++ b/ocaml/step2_eval.ml
@@ -9,7 +9,7 @@ module Env =
     end)*)
     )
 
-let num_fun f = T.Fn
+let num_fun f = Types.fn
   (function
     | [(T.Int a); (T.Int b)] -> T.Int (f a b)
     | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin"))
@@ -40,7 +40,7 @@ let rec eval_ast ast env =
 and eval ast env =
   let result = eval_ast ast env in
     match result with
-      | T.List { T.value = ((T.Fn f) :: args) } -> (f args)
+      | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> (f args)
       | _ -> result
 
 let read str = Reader.read_str str
diff --git a/ocaml/step3_env.ml b/ocaml/step3_env.ml
index 856a786..442b4e4 100644
--- a/ocaml/step3_env.ml
+++ b/ocaml/step3_env.ml
@@ -1,6 +1,6 @@
 module T = Types.Types
 
-let num_fun f = T.Fn
+let num_fun f = Types.fn
   (function
     | [(T.Int a); (T.Int b)] -> T.Int (f a b)
     | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin"))
@@ -47,7 +47,7 @@ and eval ast env =
           eval body sub_env)
     | T.List _ ->
       (match eval_ast ast env with
-         | T.List { T.value = ((T.Fn f) :: args) } -> f args
+         | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args
          | _ -> raise (Invalid_argument "Cannot invoke non-function"))
     | _ -> eval_ast ast env
 
diff --git a/ocaml/step4_if_fn_do.ml b/ocaml/step4_if_fn_do.ml
index a16649a..7172070 100644
--- a/ocaml/step4_if_fn_do.ml
+++ b/ocaml/step4_if_fn_do.ml
@@ -41,7 +41,7 @@ and eval ast env =
         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] } ->
-        T.Fn
+        Types.fn
           (function args ->
             let sub_env = Env.make (Some env) in
               let rec bind_args a b =
@@ -56,7 +56,7 @@ and eval ast env =
               eval expr sub_env)
     | T.List _ ->
       (match eval_ast ast env with
-         | T.List { T.value = ((T.Fn f) :: args) } -> f args
+         | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args
          | _ -> raise (Invalid_argument "Cannot invoke non-function"))
     | _ -> eval_ast ast env
 
diff --git a/ocaml/step6_file.ml b/ocaml/step6_file.ml
index af87eb0..6eedd71 100644
--- a/ocaml/step6_file.ml
+++ b/ocaml/step6_file.ml
@@ -41,7 +41,7 @@ and eval ast env =
         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] } ->
-        T.Fn
+        Types.fn
           (function args ->
             let sub_env = Env.make (Some env) in
               let rec bind_args a b =
@@ -56,7 +56,7 @@ and eval ast env =
               eval expr sub_env)
     | T.List _ ->
       (match eval_ast ast env with
-         | T.List { T.value = ((T.Fn f) :: args) } -> f args
+         | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args
          | _ -> raise (Invalid_argument "Cannot invoke non-function"))
     | _ -> eval_ast ast env
 
@@ -72,7 +72,7 @@ let rec main =
                          then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv))))
                          else []));
     Env.set repl_env (Types.symbol "eval")
-            (T.Fn (function [ast] -> eval ast repl_env | _ -> T.Nil));
+            (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil));
     let code = "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
     in print_endline code; ignore (rep code repl_env);
     ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env);
diff --git a/ocaml/step7_quote.ml b/ocaml/step7_quote.ml
index d8b4518..e9907cc 100644
--- a/ocaml/step7_quote.ml
+++ b/ocaml/step7_quote.ml
@@ -53,7 +53,7 @@ and eval ast env =
         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] } ->
-        T.Fn
+        Types.fn
           (function args ->
             let sub_env = Env.make (Some env) in
               let rec bind_args a b =
@@ -71,7 +71,7 @@ and eval ast env =
        eval (quasiquote ast) env
     | T.List _ ->
       (match eval_ast ast env with
-         | T.List { T.value = ((T.Fn f) :: args) } -> f args
+         | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args
          | _ -> raise (Invalid_argument "Cannot invoke non-function"))
     | _ -> eval_ast ast env
 
@@ -87,7 +87,7 @@ let rec main =
                          then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv))))
                          else []));
     Env.set repl_env (Types.symbol "eval")
-            (T.Fn (function [ast] -> eval ast repl_env | _ -> T.Nil));
+            (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil));
     let code = "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
     in ignore (rep code repl_env);
     ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env);
diff --git a/ocaml/step8_macros.ml b/ocaml/step8_macros.ml
new file mode 100644
index 0000000..5febf6c
--- /dev/null
+++ b/ocaml/step8_macros.ml
@@ -0,0 +1,129 @@
+module T = Types.Types
+
+let repl_env = Env.make (Some Core.ns)
+
+let rec quasiquote ast =
+  match ast with
+    | T.List   { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast
+    | T.Vector { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast
+    | T.List   { T.value = T.List { T.value = [T.Symbol {T.value = "splice-unquote"}; head]} :: tail }
+    | T.Vector { T.value = T.List { T.value = [T.Symbol {T.value = "splice-unquote"}; head]} :: tail } ->
+       Types.list [Types.symbol "concat"; head; quasiquote (Types.list tail)]
+    | T.List   { T.value = head :: tail }
+    | T.Vector { T.value = head :: tail } ->
+       Types.list [Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ]
+    | ast -> Types.list [Types.symbol "quote"; ast]
+
+let rec macroexpand ast env =
+  match ast with
+  | T.List { T.value = s :: args } ->
+     (match (try Env.get env s with _ -> T.Nil) with
+      | T.Fn { T.f = f; T.is_macro = true } -> macroexpand (f args) env
+      | _ -> ast)
+  | _ -> ast
+
+let rec eval_ast ast env =
+  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); T.meta = meta }
+    | T.Vector { T.value = xs; T.meta = meta }
+      -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+    | T.Map { T.value = xs; T.meta = meta }
+      -> T.Map {T.meta = meta;
+                T.value = (Types.MalMap.fold
+                             (fun k v m
+                              -> Types.MalMap.add (eval k env) (eval v env) m)
+                             xs
+                             Types.MalMap.empty)}
+    | _ -> ast
+and eval ast env =
+  match macroexpand ast env with
+    | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } ->
+        let value = (eval expr env) in
+          Env.set env key value; value
+    | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } ->
+       (match (eval expr env) with
+          | T.Fn { T.f = f } ->
+             let fn = T.Fn { T.f = f; is_macro = true } in
+             Env.set env key fn; fn
+          | _ -> raise (Invalid_argument "devmacro! value must be a fn"))
+    | 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
+          let rec bind_pairs = (function
+            | sym :: expr :: more ->
+                Env.set sub_env sym (eval expr sub_env);
+                bind_pairs more
+            | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms")
+            | [] -> ())
+            in bind_pairs bindings;
+          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] } ->
+        Types.fn
+          (function args ->
+            let sub_env = Env.make (Some env) in
+              let rec bind_args a b =
+                (match a, b with
+                  | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args);
+                  | (name :: names), (arg :: args) ->
+                      Env.set sub_env name arg;
+                      bind_args names args;
+                  | [], [] -> ()
+                  | _ -> raise (Invalid_argument "Bad param count in fn call"))
+              in bind_args arg_names args;
+              eval expr sub_env)
+    | T.List { T.value = [T.Symbol { T.value = "quote" }; ast] } -> ast
+    | T.List { T.value = [T.Symbol { T.value = "quasiquote" }; ast] } ->
+       eval (quasiquote ast) env
+    | T.List { T.value = [T.Symbol { T.value = "macroexpand" }; ast] } ->
+       macroexpand ast env
+    | T.List _ as ast ->
+      (match eval_ast ast env with
+         | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args
+         | _ -> raise (Invalid_argument "Cannot invoke non-function"))
+    | ast -> 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)
+
+let rec main =
+  try
+    Core.init Core.ns;
+    Env.set repl_env (Types.symbol "*ARGV*")
+            (Types.list (if Array.length Sys.argv > 1
+                         then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv))))
+                         else []));
+    Env.set repl_env (Types.symbol "eval")
+            (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil));
+
+    ignore (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" repl_env);
+    ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env);
+    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);
+    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);
+
+    if Array.length Sys.argv > 1 then
+      ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env)
+    else
+      while true do
+        print_string "user> ";
+        let line = read_line () in
+        try
+          print_endline (rep line repl_env);
+        with End_of_file -> ()
+           | Invalid_argument x ->
+              output_string stderr ("Invalid_argument exception: " ^ x ^ "\n");
+              flush stderr
+           | _ ->
+              output_string stderr ("Erroringness!\n");
+              flush stderr
+      done
+  with End_of_file -> ()
diff --git a/ocaml/types.ml b/ocaml/types.ml
index 287cc88..1cec691 100644
--- a/ocaml/types.ml
+++ b/ocaml/types.ml
@@ -1,6 +1,7 @@
 module rec Types
   : sig
   type 'a with_meta = { value : 'a; meta : t }
+  and fn_rec = { f : (t list -> t); is_macro : bool }
   and t =
     | List of t list with_meta
     | Vector of t list with_meta
@@ -11,7 +12,7 @@ module rec Types
     | Nil
     | Bool of bool
     | String of string
-    | Fn of (t list -> t)
+    | Fn of fn_rec
   end = Types
 
 and MalValue
@@ -38,6 +39,7 @@ let list   x = Types.List   { Types.value = x; meta = Types.Nil }
 let map    x = Types.Map    { Types.value = x; meta = Types.Nil }
 let vector x = Types.Vector { Types.value = x; meta = Types.Nil }
 let symbol x = Types.Symbol { Types.value = x; meta = Types.Nil }
+let fn f = Types.Fn { Types.f = f; Types.is_macro = false }
 
 let rec list_into_map target source =
   match source with