ref: bdb99b496ec68880effa7df50fb4b05e7c1799bc
dir: /eval.ml/
module T = Types.Types
let rec quasiquote ast =
match ast with
| T.List {T.value= [T.Symbol {T.value= "unquote"; meta= _}; ast]; meta= _} -> ast
| T.Vector {T.value= [T.Symbol {T.value= "unquote"; meta= _}; ast]; meta= _} -> ast
| T.List {T.value= T.List {T.value= [T.Symbol {T.value= "unquote-splicing"; meta= _}; head]; meta= _} :: tail; meta= _}
|T.Vector
{T.value= T.List {T.value= [T.Symbol {T.value= "unquote-splicing"; meta= _}; head]; meta= _} :: tail; meta= _} ->
Types.list [Types.symbol "concat"; head; quasiquote (Types.list tail)]
| T.List {T.value= head :: tail; meta= _} | T.Vector {T.value= head :: tail; meta= _} ->
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 _ -> Env.get env ast
| T.List {T.value= xs; T.meta} -> (
match try Env.get env (List.hd xs) with _ -> T.Nil with
| _ -> 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 eval ast env =
print_endline ("AST: " ^ Printer.print ast true) ;
match ast with
| T.List {T.value= []; meta= _} -> ast
(* Can this be replaced with a define-syntax thing? *)
| T.List {T.value= [T.Symbol {T.value= "define"; meta= _}; T.List {T.value= arg_list; meta= _}; body]; meta= _} ->
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
print_endline ("DEFINE: " ^ Printer.print sym true) ;
print_endline
( " => " ^ "(define " ^ Printer.print sym true ^ " (lambda (" ^ Printer.stringify rest false ^ ") "
^ Printer.print body true ^ ")" ) ;
Env.set env sym func ;
func
| T.List {T.value= [T.Symbol {T.value= "define"; meta= _}; key; expr]; meta= _} ->
let value = eval expr env in
Env.set env key value ; value
| T.List {T.value= [T.Symbol {T.value= "lambda"; meta= _}; T.Vector {T.value= arg_names; meta= _}; expr]; meta= _}
|T.List {T.value= [T.Symbol {T.value= "lambda"; meta= _}; T.List {T.value= arg_names; meta= _}; expr]; meta= _} ->
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= "."; meta= _}; 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
(Utils.Syntax_error
( "wrong parameter count for lambda: arg_names:[" ^ Printer.dump arg_names ^ "] args:["
^ Printer.dump args ^ "]" ) ) 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"; meta= _}; T.Vector {T.value= bindings; meta= _}; body]; meta= _}
|T.List {T.value= [T.Symbol {T.value= "let"; meta= _}; T.List {T.value= bindings; meta= _}; body]; meta= _} ->
let sub_env = Env.make (Some env) in
let rec bind_pairs = function
| T.List {T.value= [T.Symbol {T.value= sym; meta= _}; expr]; meta= _} :: 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"; meta= _} :: body; meta= _} ->
List.fold_left (fun _ expr -> eval expr env) T.Nil body
| T.List {T.value= [T.Symbol {T.value= "if"; meta= _}; cond; then_expr; else_expr]; meta= _} ->
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"; meta= _}; cond; then_expr]; meta= _} ->
if Types.to_bool (eval cond env) then eval then_expr env else T.Nil
| T.List {T.value= [T.Symbol {T.value= "quote"; meta= _}; ast]; meta= _} -> ast
| T.List {T.value= [T.Symbol {T.value= "quasiquote"; meta= _}; ast]; meta= _} -> eval (quasiquote ast) env
| T.List _ -> (
match eval_ast ast env with
| T.List {T.value= T.Proc {T.value= f; meta= _} :: args; meta= _} -> f args
| T.List {T.value= T.Macro {T.value= _; meta= _} :: macro :: _; meta= _} ->
print_endline "MACRO EVALUATION" ; eval macro env
| _ as x -> raise (Utils.Syntax_error ("'" ^ Printer.print x true ^ "' not a function")) )
| _ -> eval_ast ast env