shithub: martian9

ref: db23aa72a4d43083867fc28c5ec1664a3442645b
dir: /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 =
  match ast with
  | T.Symbol s -> Env.get env ast
  | 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 =
  (* match preparse ast env with *)
  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 = 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
;;