aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChouser <chouser@n01se.net>2015-01-29 23:29:54 -0500
committerChouser <chouser@n01se.net>2015-01-30 12:54:43 -0500
commitecd3b6d8e551dd87934142b0323d9b75134bbea9 (patch)
tree99210e84137d52105593c6327a29e038f43166f9
parentfb21afa71b4f73fa9c05c47e6b1c0f45d2144069 (diff)
downloadmal-ecd3b6d8e551dd87934142b0323d9b75134bbea9.tar.gz
mal-ecd3b6d8e551dd87934142b0323d9b75134bbea9.zip
OCaml: Add step 9
-rw-r--r--ocaml/Makefile2
-rw-r--r--ocaml/core.ml107
-rw-r--r--ocaml/env.ml2
-rw-r--r--ocaml/printer.ml6
-rw-r--r--ocaml/reader.ml9
-rw-r--r--ocaml/step2_eval.ml11
-rw-r--r--ocaml/step3_env.ml11
-rw-r--r--ocaml/step4_if_fn_do.ml11
-rw-r--r--ocaml/step6_file.ml11
-rw-r--r--ocaml/step7_quote.ml11
-rw-r--r--ocaml/step8_macros.ml17
-rw-r--r--ocaml/step9_try.ml148
-rw-r--r--ocaml/types.ml18
13 files changed, 326 insertions, 38 deletions
diff --git a/ocaml/Makefile b/ocaml/Makefile
index b52c69b..a7c78fd 100644
--- a/ocaml/Makefile
+++ b/ocaml/Makefile
@@ -1,6 +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 \
- step8_macros.ml
+ step8_macros.ml step9_try.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 98f8c8c..49041d8 100644
--- a/ocaml/core.ml
+++ b/ocaml/core.ml
@@ -16,6 +16,38 @@ let seq = function
Types.MalMap.fold (fun k v list -> k :: v :: list) xs []
| _ -> []
+let rec assoc = function
+ | c :: k :: v :: (_ :: _ as xs) -> assoc ((assoc [c; k; v]) :: xs)
+ | [T.Map { T.value = m; T.meta = meta }; k; v]
+ -> T.Map { T.value = (Types.MalMap.add k v m);
+ T.meta = meta;
+ T.is_macro = false}
+ | _ -> T.Nil
+
+let rec dissoc = function
+ | c :: x :: (_ :: _ as xs) -> dissoc ((dissoc [c; x]) :: xs)
+ | [T.Map { T.value = m; T.meta = meta }; k]
+ -> T.Map { T.value = (Types.MalMap.remove k m);
+ T.meta = meta;
+ T.is_macro = false}
+ | _ -> T.Nil
+
+let rec conj = function
+ | c :: x :: (_ :: _ as xs) -> conj ((conj [c; x]) :: xs)
+ | [T.Map { T.value = c; T.meta = meta }; T.Vector { T.value = [k; v] }]
+ -> T.Map { T.value = (Types.MalMap.add k v c);
+ T.meta = meta;
+ T.is_macro = false}
+ | [T.List { T.value = c; T.meta = meta }; x ]
+ -> T.List { T.value = x :: c;
+ T.meta = meta;
+ T.is_macro = false}
+ | [T.Vector { T.value = c; T.meta = meta }; x ]
+ -> T.Vector { T.value = c @ [x];
+ T.meta = meta;
+ T.is_macro = false}
+ | _ -> T.Nil
+
let init env = begin
Env.set env (Types.symbol "+") (num_fun mk_int ( + ));
Env.set env (Types.symbol "-") (num_fun mk_int ( - ));
@@ -29,6 +61,9 @@ let init env = begin
Env.set env (Types.symbol "list") (Types.fn (function xs -> Types.list xs));
Env.set env (Types.symbol "list?")
(Types.fn (function [T.List _] -> T.Bool true | _ -> T.Bool false));
+ Env.set env (Types.symbol "vector") (Types.fn (function xs -> Types.vector xs));
+ Env.set env (Types.symbol "vector?")
+ (Types.fn (function [T.Vector _] -> T.Bool true | _ -> T.Bool false));
Env.set env (Types.symbol "empty?")
(Types.fn (function [T.List {T.value = []}] -> T.Bool true | _ -> T.Bool false));
Env.set env (Types.symbol "count")
@@ -87,5 +122,75 @@ let init env = begin
(Types.fn (function
| [xs] -> Types.list (match seq xs with _ :: xs -> xs | _ -> [])
| _ -> T.Nil));
-end
+ Env.set env (Types.symbol "symbol")
+ (Types.fn (function [T.String x] -> Types.symbol x | _ -> T.Nil));
+ Env.set env (Types.symbol "symbol?")
+ (Types.fn (function [T.Symbol _] -> T.Bool true | _ -> T.Bool false));
+ Env.set env (Types.symbol "keyword")
+ (Types.fn (function [T.String x] -> T.Keyword x | _ -> T.Nil));
+ Env.set env (Types.symbol "keyword?")
+ (Types.fn (function [T.Keyword _] -> T.Bool true | _ -> T.Bool false));
+ Env.set env (Types.symbol "nil?")
+ (Types.fn (function [T.Nil] -> T.Bool true | _ -> T.Bool false));
+ Env.set env (Types.symbol "true?")
+ (Types.fn (function [T.Bool true] -> T.Bool true | _ -> T.Bool false));
+ Env.set env (Types.symbol "false?")
+ (Types.fn (function [T.Bool false] -> T.Bool true | _ -> T.Bool false));
+ Env.set env (Types.symbol "sequential?")
+ (Types.fn (function [T.List _] | [T.Vector _] -> T.Bool true | _ -> T.Bool false));
+ Env.set env (Types.symbol "apply")
+ (Types.fn (function
+ | (T.Fn { T.value = f } :: apply_args) ->
+ (match List.rev apply_args with
+ | last_arg :: rev_args ->
+ f ((List.rev rev_args) @ (seq last_arg))
+ | [] -> f [])
+ | _ -> raise (Invalid_argument "First arg to apply must be a fn")));
+ Env.set env (Types.symbol "map")
+ (Types.fn (function
+ | [T.Fn { T.value = f }; xs] ->
+ Types.list (List.map (fun x -> f [x]) (seq xs))
+ | _ -> T.Nil));
+ Env.set env (Types.symbol "readline")
+ (Types.fn (function
+ | [T.String x] -> print_string x; T.String (read_line ())
+ | _ -> T.String (read_line ())));
+
+ Env.set env (Types.symbol "map?")
+ (Types.fn (function [T.Map _] -> T.Bool true | _ -> T.Bool false));
+ Env.set env (Types.symbol "hash-map")
+ (Types.fn (function xs -> Types.list_into_map Types.MalMap.empty xs));
+ Env.set env (Types.symbol "assoc") (Types.fn assoc);
+ Env.set env (Types.symbol "dissoc") (Types.fn dissoc);
+ Env.set env (Types.symbol "get")
+ (Types.fn (function
+ | [T.Map { T.value = m }; k]
+ -> (try Types.MalMap.find k m with _ -> T.Nil)
+ | _ -> T.Nil));
+ Env.set env (Types.symbol "keys")
+ (Types.fn (function
+ | [T.Map { T.value = m }]
+ -> Types.list (Types.MalMap.fold (fun k _ c -> k :: c) m [])
+ | _ -> T.Nil));
+ Env.set env (Types.symbol "vals")
+ (Types.fn (function
+ | [T.Map { T.value = m }]
+ -> Types.list (Types.MalMap.fold (fun _ v c -> v :: c) m [])
+ | _ -> T.Nil));
+ Env.set env (Types.symbol "contains?")
+ (Types.fn (function
+ | [T.Map { T.value = m }; k] -> T.Bool (Types.MalMap.mem k m)
+ | _ -> T.Bool false));
+ Env.set env (Types.symbol "conj") (Types.fn conj);
+
+ Env.set env (Types.symbol "atom")
+ (Types.fn (function [x] -> T.Atom (ref x) | _ -> T.Nil));
+ Env.set env (Types.symbol "deref")
+ (Types.fn (function [T.Atom x] -> !x | _ -> T.Nil));
+ Env.set env (Types.symbol "reset!")
+ (Types.fn (function [T.Atom x; v] -> x := v; v | _ -> T.Nil));
+ Env.set env (Types.symbol "swap!")
+ (Types.fn (function T.Atom x :: T.Fn { T.value = f } :: args
+ -> let v = f (!x :: args) in x := v; v | _ -> T.Nil));
+end
diff --git a/ocaml/env.ml b/ocaml/env.ml
index 97f9cc8..cb32360 100644
--- a/ocaml/env.ml
+++ b/ocaml/env.ml
@@ -29,5 +29,5 @@ let get env sym =
| T.Symbol { T.value = key } ->
(match find env sym with
| Some found_env -> Data.find key !(found_env.data)
- | None -> raise (Invalid_argument ("Symbol '" ^ key ^ "' not found")))
+ | None -> raise (Invalid_argument ("'" ^ key ^ "' not found")))
| _ -> raise (Invalid_argument "get requires a Symbol for its key")
diff --git a/ocaml/printer.ml b/ocaml/printer.ml
index fe025af..135c3ce 100644
--- a/ocaml/printer.ml
+++ b/ocaml/printer.ml
@@ -6,6 +6,7 @@ let meta obj =
| T.Map { T.meta = meta } -> meta
| T.Vector { T.meta = meta } -> meta
| T.Symbol { T.meta = meta } -> meta
+ | T.Fn { T.meta = meta } -> meta
| _ -> T.Nil
let rec pr_str mal_obj print_readably =
@@ -30,7 +31,8 @@ let rec pr_str mal_obj print_readably =
| T.Vector { T.value = xs } ->
"[" ^ (String.concat " " (List.map (fun s -> pr_str s r) xs)) ^ "]"
| T.Map { T.value = xs } ->
- (Types.MalMap.fold (fun k v s -> s ^ (if s = "" then "{" else ", ") ^ (pr_str k r)
- ^ " " ^ (pr_str v r)) xs "")
+ "{" ^ (Types.MalMap.fold (fun k v s -> s ^ (if s = "" then "" else ", ") ^ (pr_str k r)
+ ^ " " ^ (pr_str v r)) xs "")
^ "}"
| T.Fn f -> "#<fn>"
+ | T.Atom x -> "(atom " ^ (pr_str !x r) ^ ")"
diff --git a/ocaml/reader.ml b/ocaml/reader.ml
index 36f0b2a..cf8c141 100644
--- a/ocaml/reader.ml
+++ b/ocaml/reader.ml
@@ -48,10 +48,11 @@ let read_atom token =
let with_meta obj meta =
match obj with
- | T.List { T.value = value } -> T.List { T.value = value; T.meta = meta };
- | T.Map { T.value = value } -> T.Map { T.value = value; T.meta = meta };
- | T.Vector { T.value = value } -> T.Vector { T.value = value; T.meta = meta };
- | T.Symbol { T.value = value } -> T.Symbol { T.value = value; T.meta = meta };
+ | T.List { T.value = v } -> T.List { T.value = v; T.meta = meta; T.is_macro = false };
+ | T.Map { T.value = v } -> T.Map { T.value = v; T.meta = meta; T.is_macro = false };
+ | T.Vector { T.value = v } -> T.Vector { T.value = v; T.meta = meta; T.is_macro = false };
+ | T.Symbol { T.value = v } -> T.Symbol { T.value = v; T.meta = meta; T.is_macro = false };
+ | T.Fn { T.value = v } -> T.Fn { T.value = v; T.meta = meta; T.is_macro = false };
| _ -> raise (Invalid_argument "metadata not supported on this type")
let rec read_list eol list_reader =
diff --git a/ocaml/step2_eval.ml b/ocaml/step2_eval.ml
index 62de875..b7f0793 100644
--- a/ocaml/step2_eval.ml
+++ b/ocaml/step2_eval.ml
@@ -26,11 +26,16 @@ let rec eval_ast ast env =
(try Env.find s !env
with Not_found -> raise (Invalid_argument ("Symbol '" ^ s ^ "' not found")))
| T.List { T.value = xs; T.meta = meta }
- -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+ -> T.List { T.value = (List.map (fun x -> eval x env) xs);
+ T.meta = meta;
+ T.is_macro = false}
| T.Vector { T.value = xs; T.meta = meta }
- -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+ -> T.Vector { T.value = (List.map (fun x -> eval x env) xs);
+ T.meta = meta;
+ T.is_macro = false}
| T.Map { T.value = xs; T.meta = meta }
-> T.Map {T.meta = meta;
+ T.is_macro = false;
T.value = (Types.MalMap.fold
(fun k v m
-> Types.MalMap.add (eval k env) (eval v env) m)
@@ -40,7 +45,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 { T.f = f }) :: args) } -> (f args)
+ | T.List { T.value = ((T.Fn { T.value = 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 442b4e4..4334c39 100644
--- a/ocaml/step3_env.ml
+++ b/ocaml/step3_env.ml
@@ -18,11 +18,16 @@ 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.List { T.value = (List.map (fun x -> eval x env) xs);
+ T.meta = meta;
+ T.is_macro = false}
| T.Vector { T.value = xs; T.meta = meta }
- -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+ -> T.Vector { T.value = (List.map (fun x -> eval x env) xs);
+ T.meta = meta;
+ T.is_macro = false}
| T.Map { T.value = xs; T.meta = meta }
-> T.Map {T.meta = meta;
+ T.is_macro = false;
T.value = (Types.MalMap.fold
(fun k v m
-> Types.MalMap.add (eval k env) (eval v env) m)
@@ -47,7 +52,7 @@ and eval ast env =
eval body sub_env)
| T.List _ ->
(match eval_ast ast env with
- | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args
+ | T.List { T.value = ((T.Fn { T.value = 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 7172070..abbcdab 100644
--- a/ocaml/step4_if_fn_do.ml
+++ b/ocaml/step4_if_fn_do.ml
@@ -6,11 +6,16 @@ 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.List { T.value = (List.map (fun x -> eval x env) xs);
+ T.meta = meta;
+ T.is_macro = false}
| T.Vector { T.value = xs; T.meta = meta }
- -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+ -> T.Vector { T.value = (List.map (fun x -> eval x env) xs);
+ T.meta = meta;
+ T.is_macro = false}
| T.Map { T.value = xs; T.meta = meta }
-> T.Map {T.meta = meta;
+ T.is_macro = false;
T.value = (Types.MalMap.fold
(fun k v m
-> Types.MalMap.add (eval k env) (eval v env) m)
@@ -56,7 +61,7 @@ and eval ast env =
eval expr sub_env)
| T.List _ ->
(match eval_ast ast env with
- | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args
+ | T.List { T.value = ((T.Fn { T.value = 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 6eedd71..09ef28a 100644
--- a/ocaml/step6_file.ml
+++ b/ocaml/step6_file.ml
@@ -6,11 +6,16 @@ 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.List { T.value = (List.map (fun x -> eval x env) xs);
+ T.meta = meta;
+ T.is_macro = false}
| T.Vector { T.value = xs; T.meta = meta }
- -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+ -> T.Vector { T.value = (List.map (fun x -> eval x env) xs);
+ T.meta = meta;
+ T.is_macro = false}
| T.Map { T.value = xs; T.meta = meta }
-> T.Map {T.meta = meta;
+ T.is_macro = false;
T.value = (Types.MalMap.fold
(fun k v m
-> Types.MalMap.add (eval k env) (eval v env) m)
@@ -56,7 +61,7 @@ and eval ast env =
eval expr sub_env)
| T.List _ ->
(match eval_ast ast env with
- | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args
+ | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args
| _ -> raise (Invalid_argument "Cannot invoke non-function"))
| _ -> eval_ast ast env
diff --git a/ocaml/step7_quote.ml b/ocaml/step7_quote.ml
index e9907cc..5807b28 100644
--- a/ocaml/step7_quote.ml
+++ b/ocaml/step7_quote.ml
@@ -18,11 +18,16 @@ 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.List { T.value = (List.map (fun x -> eval x env) xs);
+ T.meta = meta;
+ T.is_macro = false}
| T.Vector { T.value = xs; T.meta = meta }
- -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+ -> T.Vector { T.value = (List.map (fun x -> eval x env) xs);
+ T.meta = meta;
+ T.is_macro = false}
| T.Map { T.value = xs; T.meta = meta }
-> T.Map {T.meta = meta;
+ T.is_macro = false;
T.value = (Types.MalMap.fold
(fun k v m
-> Types.MalMap.add (eval k env) (eval v env) m)
@@ -71,7 +76,7 @@ and eval ast env =
eval (quasiquote ast) env
| T.List _ ->
(match eval_ast ast env with
- | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args
+ | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args
| _ -> raise (Invalid_argument "Cannot invoke non-function"))
| _ -> eval_ast ast env
diff --git a/ocaml/step8_macros.ml b/ocaml/step8_macros.ml
index 5febf6c..6077b76 100644
--- a/ocaml/step8_macros.ml
+++ b/ocaml/step8_macros.ml
@@ -18,7 +18,7 @@ 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
+ | T.Fn { T.value = f; T.is_macro = true } -> macroexpand (f args) env
| _ -> ast)
| _ -> ast
@@ -26,11 +26,16 @@ 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.List { T.value = (List.map (fun x -> eval x env) xs);
+ T.meta = meta;
+ T.is_macro = false}
| T.Vector { T.value = xs; T.meta = meta }
- -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta }
+ -> T.Vector { T.value = (List.map (fun x -> eval x env) xs);
+ T.meta = meta;
+ T.is_macro = false}
| T.Map { T.value = xs; T.meta = meta }
-> T.Map {T.meta = meta;
+ T.is_macro = false;
T.value = (Types.MalMap.fold
(fun k v m
-> Types.MalMap.add (eval k env) (eval v env) m)
@@ -44,8 +49,8 @@ and eval ast env =
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
+ | T.Fn { T.value = f; T.meta = meta } ->
+ let fn = T.Fn { T.value = f; is_macro = true; meta = meta } 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] }
@@ -87,7 +92,7 @@ and eval ast env =
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
+ | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args
| _ -> raise (Invalid_argument "Cannot invoke non-function"))
| ast -> eval_ast ast env
diff --git a/ocaml/step9_try.ml b/ocaml/step9_try.ml
new file mode 100644
index 0000000..462ab3a
--- /dev/null
+++ b/ocaml/step9_try.ml
@@ -0,0 +1,148 @@
+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.value = 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.is_macro = false}
+ | T.Vector { T.value = xs; T.meta = meta }
+ -> T.Vector { T.value = (List.map (fun x -> eval x env) xs);
+ T.meta = meta;
+ T.is_macro = false}
+ | T.Map { T.value = xs; T.meta = meta }
+ -> T.Map {T.meta = meta;
+ T.is_macro = false;
+ 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.value = f; T.meta = meta } ->
+ let fn = T.Fn { T.value = f; is_macro = true; meta = meta } 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 { T.value = [T.Symbol { T.value = "throw" }; ast] } ->
+ raise (Types.MalExn (eval ast env))
+ | T.List { T.value = [T.Symbol { T.value = "try*" }; scary ;
+ T.List { T.value = [T.Symbol { T.value = "catch*" };
+ local ; handler]}]} ->
+ (try (eval scary env)
+ with exn ->
+ let value = match exn with
+ | Types.MalExn value -> value
+ | Invalid_argument msg -> T.String msg
+ | _ -> (T.String "OCaml exception") in
+ let sub_env = Env.make (Some env) in
+ Env.set sub_env local value;
+ eval handler sub_env)
+ | T.List _ as ast ->
+ (match eval_ast ast env with
+ | T.List { T.value = ((T.Fn { T.value = 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 1cec691..75fade7 100644
--- a/ocaml/types.ml
+++ b/ocaml/types.ml
@@ -1,7 +1,6 @@
module rec Types
: sig
- type 'a with_meta = { value : 'a; meta : t }
- and fn_rec = { f : (t list -> t); is_macro : bool }
+ type 'a with_meta = { value : 'a; meta : t; is_macro : bool }
and t =
| List of t list with_meta
| Vector of t list with_meta
@@ -12,7 +11,8 @@ module rec Types
| Nil
| Bool of bool
| String of string
- | Fn of fn_rec
+ | Fn of (t list -> t) with_meta
+ | Atom of t ref
end = Types
and MalValue
@@ -29,17 +29,19 @@ and MalMap
: Map.S with type key = MalValue.t
= Map.Make(MalValue)
+exception MalExn of Types.t
+
let to_bool x = match x with
| Types.Nil | Types.Bool false -> false
| _ -> true
type mal_type = MalValue.t
-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 list x = Types.List { Types.value = x; meta = Types.Nil; Types.is_macro = false }
+let map x = Types.Map { Types.value = x; meta = Types.Nil; Types.is_macro = false }
+let vector x = Types.Vector { Types.value = x; meta = Types.Nil; Types.is_macro = false }
+let symbol x = Types.Symbol { Types.value = x; meta = Types.Nil; Types.is_macro = false }
+let fn f = Types.Fn { Types.value = f; meta = Types.Nil; Types.is_macro = false }
let rec list_into_map target source =
match source with