diff --git a/ocaml/core.ml b/ocaml/core.ml index 19763fa1b5..6d7b014203 100644 --- a/ocaml/core.ml +++ b/ocaml/core.ml @@ -18,34 +18,30 @@ let seq = function let rec assoc = function | c :: k :: v :: (_ :: _ as xs) -> assoc ((assoc [c; k; v]) :: xs) + | [T.Nil; k; v] -> Types.map (Types.MalMap.add k v Types.MalMap.empty) | [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.meta = meta } | _ -> 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.meta = meta } | _ -> 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.meta = meta } | [T.List { T.value = c; T.meta = meta }; x ] -> T.List { T.value = x :: c; - T.meta = meta; - T.is_macro = false} + T.meta = meta } | [T.Vector { T.value = c; T.meta = meta }; x ] -> T.Vector { T.value = c @ [x]; - T.meta = meta; - T.is_macro = false} + T.meta = meta } | _ -> T.Nil let init env = begin diff --git a/ocaml/reader.ml b/ocaml/reader.ml index cf8c141a13..7456cf8e1c 100644 --- a/ocaml/reader.ml +++ b/ocaml/reader.ml @@ -48,11 +48,12 @@ let read_atom token = let with_meta obj meta = match obj with - | 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 }; + | T.List { T.value = v } + -> T.List { T.value = v; T.meta = meta }; | T.Map { T.value = v } + -> T.Map { T.value = v; T.meta = meta }; | T.Vector { T.value = v } + -> T.Vector { T.value = v; T.meta = meta }; | T.Symbol { T.value = v } + -> T.Symbol { T.value = v; T.meta = meta }; | T.Fn { T.value = v } + -> T.Fn { T.value = v; T.meta = meta }; | _ -> 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 b7f0793b20..3778292073 100644 --- a/ocaml/step2_eval.ml +++ b/ocaml/step2_eval.ml @@ -27,15 +27,12 @@ let rec eval_ast ast 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.is_macro = false} + 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.is_macro = false} + T.meta = meta } | 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) diff --git a/ocaml/step3_env.ml b/ocaml/step3_env.ml index 4334c39363..73d4236dd9 100644 --- a/ocaml/step3_env.ml +++ b/ocaml/step3_env.ml @@ -19,15 +19,12 @@ let rec eval_ast ast env = | 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.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.is_macro = false} + T.meta = meta } | 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) diff --git a/ocaml/step4_if_fn_do.ml b/ocaml/step4_if_fn_do.ml index abbcdaba8f..f08aa55223 100644 --- a/ocaml/step4_if_fn_do.ml +++ b/ocaml/step4_if_fn_do.ml @@ -7,15 +7,12 @@ let rec eval_ast ast env = | 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.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.is_macro = false} + T.meta = meta } | 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) diff --git a/ocaml/step6_file.ml b/ocaml/step6_file.ml index 09ef28ac31..e9d48d3ffe 100644 --- a/ocaml/step6_file.ml +++ b/ocaml/step6_file.ml @@ -7,15 +7,12 @@ let rec eval_ast ast env = | 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.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.is_macro = false} + T.meta = meta } | 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) diff --git a/ocaml/step7_quote.ml b/ocaml/step7_quote.ml index 5807b28a3b..3291f48fba 100644 --- a/ocaml/step7_quote.ml +++ b/ocaml/step7_quote.ml @@ -19,15 +19,12 @@ let rec eval_ast ast env = | 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.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.is_macro = false} + T.meta = meta } | 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) diff --git a/ocaml/step8_macros.ml b/ocaml/step8_macros.ml index 6077b76a7e..7f61c597ca 100644 --- a/ocaml/step8_macros.ml +++ b/ocaml/step8_macros.ml @@ -14,28 +14,38 @@ let rec quasiquote ast = Types.list [Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ] | ast -> Types.list [Types.symbol "quote"; ast] -let rec macroexpand ast env = +let kw_macro = T.Keyword "macro" + +let is_macro_call 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 + | T.Fn { T.meta = T.Map { T.value = meta } } + -> Types.MalMap.mem kw_macro meta && Types.to_bool (Types.MalMap.find kw_macro meta) + | _ -> false) + | _ -> false + +let rec macroexpand ast env = + if is_macro_call ast env + then match ast with + | T.List { T.value = s :: args } -> + (match (try Env.get env s with _ -> T.Nil) with + | T.Fn { T.value = f } -> macroexpand (f args) env + | _ -> ast) + | _ -> ast + else 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.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.is_macro = false} + T.meta = meta } | 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) @@ -50,9 +60,9 @@ and eval ast env = | 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")) + let fn = T.Fn { T.value = f; meta = Core.assoc [meta; kw_macro; (T.Bool true)]} + in Env.set env key fn; fn + | _ -> raise (Invalid_argument "defmacro! 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 diff --git a/ocaml/step9_try.ml b/ocaml/step9_try.ml index 37c41acf3e..dd220db1fa 100644 --- a/ocaml/step9_try.ml +++ b/ocaml/step9_try.ml @@ -14,28 +14,38 @@ let rec quasiquote ast = Types.list [Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ] | ast -> Types.list [Types.symbol "quote"; ast] -let rec macroexpand ast env = +let kw_macro = T.Keyword "macro" + +let is_macro_call 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 + | T.Fn { T.meta = T.Map { T.value = meta } } + -> Types.MalMap.mem kw_macro meta && Types.to_bool (Types.MalMap.find kw_macro meta) + | _ -> false) + | _ -> false + +let rec macroexpand ast env = + if is_macro_call ast env + then match ast with + | T.List { T.value = s :: args } -> + (match (try Env.get env s with _ -> T.Nil) with + | T.Fn { T.value = f } -> macroexpand (f args) env + | _ -> ast) + | _ -> ast + else 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.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.is_macro = false} + T.meta = meta } | 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) @@ -50,8 +60,8 @@ and eval ast env = | 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 + let fn = T.Fn { T.value = f; meta = Core.assoc [meta; kw_macro; (T.Bool 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] } -> diff --git a/ocaml/stepA_interop.ml b/ocaml/stepA_interop.ml index 1b2e98d837..e159de4f34 100644 --- a/ocaml/stepA_interop.ml +++ b/ocaml/stepA_interop.ml @@ -14,28 +14,38 @@ let rec quasiquote ast = Types.list [Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ] | ast -> Types.list [Types.symbol "quote"; ast] -let rec macroexpand ast env = +let kw_macro = T.Keyword "macro" + +let is_macro_call 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 + | T.Fn { T.meta = T.Map { T.value = meta } } + -> Types.MalMap.mem kw_macro meta && Types.to_bool (Types.MalMap.find kw_macro meta) + | _ -> false) + | _ -> false + +let rec macroexpand ast env = + if is_macro_call ast env + then match ast with + | T.List { T.value = s :: args } -> + (match (try Env.get env s with _ -> T.Nil) with + | T.Fn { T.value = f } -> macroexpand (f args) env + | _ -> ast) + | _ -> ast + else 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.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.is_macro = false} + T.meta = meta } | 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) @@ -50,8 +60,8 @@ and eval ast env = | 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 + let fn = T.Fn { T.value = f; meta = Core.assoc [meta; kw_macro; (T.Bool 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] } -> diff --git a/ocaml/types.ml b/ocaml/types.ml index 75fade787e..9df9761042 100644 --- a/ocaml/types.ml +++ b/ocaml/types.ml @@ -1,6 +1,6 @@ module rec Types : sig - type 'a with_meta = { value : 'a; meta : t; is_macro : bool } + type 'a with_meta = { value : 'a; meta : t } and t = | List of t list with_meta | Vector of t list with_meta @@ -37,11 +37,11 @@ let to_bool x = match x with type mal_type = MalValue.t -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 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.value = f; meta = Types.Nil } let rec list_into_map target source = match source with