shithub: martian9

ref: 24cf0e8cd6799c80652dd2f7ecf41e0209dfe159
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