shithub: martian9

ref: dd3012ec25538fc83f12e81520f0470fcc9020fa
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
;;