ref: cee3c78840d9cde8172fb8f167a75f20ecf6451c
dir: martian9/eval.ml
module T = Types.Types
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 = "unquote-splicing" }; head ] } :: tail }
| T.Vector { T.value = T.List { T.value = [ T.Symbol { T.value = "unquote-splicing" }; 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 =
(* print_endline ("EVAL_AST: " ^ Printer.print ast true); *)
match ast with
| T.Symbol s -> Env.get env ast
(* | T.Symbol s -> let foo = Env.get env ast in(\* (match Env.get env ast with *\)
* print_endline ("EVAL_AST: " ^ Printer.print foo true);
* (match foo with
* | T.Macro { T.value = sym; meta } -> raise (Reader.Syntax_error ("EVAL_AST MACRO: ast: " ^ Printer.print ast true))
* | T.List { T.value = xs; meta } -> raise (Reader.Syntax_error "EVAL_AST LIST")
* | _ as x -> print_endline ("EVAL_AST UNKNOWN: " ^ Printer.print ast true ^ ":" ^ Printer.print x true); foo)
*)
| T.List { T.value = xs; T.meta } ->
(match
try Env.get env (List.hd xs) with
| _ -> T.Nil
with
| T.Macro { T.value = sym; meta } as om ->
print_endline (" EVAL_AST: the rest: " ^ Printer.dump (List.tl xs));
print_endline (" EVAL_AST: AST: " ^ Printer.print ast true);
let foo = Macro.expand ast env (List.tl xs) sym meta in
print_endline (" expanded: " ^ Printer.print foo true);
T.List { T.value = [ om; foo ]; T.meta }
(* T.List { T.value = [foo]; T.meta } *)
(* T.List { T.value = [ Types.symbol (Printer.print sym true); foo; T.List { T.value = (List.tl xs); T.meta } ]; T.meta } *)
(* T.List { T.value = [eval foo env]; T.meta } *)
(* eval foo env *)
(* raise (Reader.Syntax_error ("EVAL_AST MACRO: ast: " ^ Printer.print ast true)) *)
| _ -> T.List { T.value = List.map (fun x -> eval x env) xs; T.meta })
(* | T.List { T.value = xs; T.meta } -> T.List { T.value = List.map (fun x -> eval x env) xs; T.meta } *)
| T.Vector { T.value = xs; T.meta } -> T.Vector { T.value = List.map (fun x -> eval x env) xs; T.meta }
| _ -> ast
(* and preparse ast env =
* print_endline ("preparse: " ^ Printer.print ast true);
* match ast with
* | T.List { T.value = s :: args } ->
* (match
* try Env.get env s with
* | _ -> T.Nil
* with
* | T.Macro { T.value = sym; meta } ->
* let foo = Macro.expand ast env args sym meta in
* print_endline (" expanded: " ^ Printer.print foo true);
* eval foo env
* | _ -> ast)
* | _ -> ast *)
and eval ast env =
print_endline ("AST: " ^ Printer.print ast true);
match ast with
| T.List { T.value = [] } -> ast
(* Can this be replaced with a define-syntax thing? *)
| T.List { T.value = [ T.Symbol { T.value = "define" }; T.List { T.value = arg_list }; body ] } ->
let sym = List.hd arg_list in
let rest = List.tl arg_list in
let func =
eval (Reader.read ("(lambda (" ^ Printer.stringify rest false ^ ") " ^ Printer.print body true ^ ")")) env
in
Env.set env sym func;
func
| T.List { T.value = [ T.Symbol { T.value = "define" }; key; expr ] } ->
let value = eval expr env in
Env.set env key value;
value
| T.List { T.value = [ T.Symbol { T.value = "define-syntax" }; keyword; T.List { T.value = macro } ] } ->
(match macro with
| _ :: literals :: groups ->
let macro_entry = Types.macro (Printer.print keyword true) literals (Types.list groups) in
Env.set env keyword macro_entry;
macro_entry
| _ -> T.Nil)
| T.List { T.value = [ T.Symbol { T.value = "lambda" }; T.Vector { T.value = arg_names }; expr ] }
| T.List { T.value = [ T.Symbol { T.value = "lambda" }; T.List { T.value = arg_names }; expr ] } ->
Types.proc (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 (Reader.Syntax_error "wrong parameter count for lambda")
in
bind_args arg_names args;
eval expr sub_env)
(* Can these be replace with define-syntax stuff? *)
| 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
| T.List { T.value = [ T.Symbol { T.value = sym }; expr ] } :: more ->
let value = eval expr env in
Env.set env (Types.symbol sym) value;
bind_pairs more
| _ -> ()
in
bind_pairs bindings;
eval body sub_env
| T.List { T.value = T.Symbol { T.value = "begin" } :: body } ->
List.fold_left (fun x expr -> eval expr env) T.Nil body
| T.List { T.value = [ T.Symbol { T.value = "if" }; cond; then_expr; else_expr ] } ->
if Types.to_bool (eval cond env) then eval then_expr env else eval else_expr env
| T.List { T.value = [ T.Symbol { T.value = "if" }; cond; then_expr ] } ->
if Types.to_bool (eval cond env) then eval then_expr env else T.Nil
| 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.Proc { T.value = f } :: args } -> f args
| T.List { T.value = T.Macro { T.value = _ } :: macro :: _ } ->
print_endline "MACRO EVALUATION";
eval macro env
(* | T.List { T.value = T.Macro { T.value = sym; meta } :: args } ->
* (\* eval (Macro.expand ast env args sym meta) env *\)
* let foo = Macro.expand ast env args sym meta in
* print_endline (":::: " ^ Printer.print foo true);
* eval foo env *)
| _ as x -> raise (Reader.Syntax_error ("'" ^ Printer.print x true ^ "' not a function")))
| _ -> eval_ast ast env
;;