aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ocaml/Makefile2
-rw-r--r--ocaml/core.ml22
-rw-r--r--ocaml/step7_quote.ml108
3 files changed, 131 insertions, 1 deletions
diff --git a/ocaml/Makefile b/ocaml/Makefile
index ced6df4..be51a88 100644
--- a/ocaml/Makefile
+++ b/ocaml/Makefile
@@ -1,5 +1,5 @@
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
+ step4_if_fn_do.ml step5_tco.ml step6_file.ml step7_quote.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 f901228..a5131ce 100644
--- a/ocaml/core.ml
+++ b/ocaml/core.ml
@@ -9,6 +9,13 @@ let num_fun t f = T.Fn
let mk_int x = T.Int x
let mk_bool x = T.Bool x
+let seq = function
+ | T.List { T.value = xs } -> xs
+ | T.Vector { T.value = xs } -> xs
+ | T.Map { T.value = xs } ->
+ Types.MalMap.fold (fun k v list -> k :: v :: list) xs []
+ | _ -> []
+
let init env = begin
Env.set env (Types.symbol "+") (num_fun mk_int ( + ));
Env.set env (Types.symbol "-") (num_fun mk_int ( - ));
@@ -54,5 +61,20 @@ let init env = begin
(T.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));
+
+ Env.set env (Types.symbol "read-string")
+ (T.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));
+
+ Env.set env (Types.symbol "cons")
+ (T.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));
end
diff --git a/ocaml/step7_quote.ml b/ocaml/step7_quote.ml
new file mode 100644
index 0000000..d8b4518
--- /dev/null
+++ b/ocaml/step7_quote.ml
@@ -0,0 +1,108 @@
+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 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 ast 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 = "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] } ->
+ T.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 _ ->
+ (match eval_ast ast env with
+ | T.List { T.value = ((T.Fn f) :: args) } -> f args
+ | _ -> raise (Invalid_argument "Cannot invoke non-function"))
+ | _ -> 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")
+ (T.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);
+
+ 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
+ done
+ with End_of_file -> ()
generated by cgit v1.2.3 (git 2.25.1) at 2026-01-06 09:17:51 +0000