lua_stdlib_basic.ml — Coverage report

open Ast
open Ast.Value

let () = Random.self_init ()

let get_table_value name env =
  match Ast_utils.get_table_value name env with
  | Ok v -> v
  | Error () ->
    let msg =
      Format.sprintf "Lua_stdlib_basic.get_table_value.error: %s" name
    in
    Lua_stdlib_common.error msg

let rec tostring_value v env =
  match v with
  | Vnil () -> ("nil", env)
  | Vboolean b -> (string_of_bool b, env)
  | Vnumber (Ninteger i) -> (string_of_int i, env)
  | Vnumber (Nfloat f) -> (string_of_float f, env)
  | Vstring s -> (s, env)
  | Vtable tbl as t ->
    begin match LuaTable.get_metatable_field "__tostring" tbl with
    | Some (Vfunction (_, _, _) as f) ->
      let _, v2, env =
        match
          Interpret.interpret_fct f [ (Ast.empty_location (), Evalue t) ] env
        with
        | Error (_, msg) -> Lua_stdlib_common.error msg
        | Ok v -> v
      in
      tostring_value v2 env
    | Some _ ->
      Lua_stdlib_common.typing_error
        "metatable.__tostring: attempt to call a non function value"
    | None -> (LuaTable.to_string tbl, env)
    end
  | Vfunction (i, _, _) | VfunctionStdLib (i, _) ->
    (Format.sprintf "function: %i" (Int32.to_int i), env)
  | VfunctionReturn vl | Vvariadic vl -> (
    match vl with
    | [] -> ("", env)
    | [ v ] -> tostring_value v env
    | v :: tl ->
      let s1, env = tostring_value v env in
      let s2, env = tostring_value (VfunctionReturn tl) env in
      (Format.sprintf "%s, %s" s1 s2, env) )
  | Vref (VarName v) ->
    begin match Env.get_value v env with
    | Ok v -> tostring_value v env
    | Error (_, msg) -> Lua_stdlib_common.error msg
    end
  | Vref (VarTableField (_, _)) -> assert false (* TODO *)

let asert v env =
  begin match v with
  | Vnil () :: [ Vstring msg ] | Vboolean false :: [ Vstring msg ] ->
    assert (
      print_endline (Format.sprintf "assert: %s" msg);
      false )
  | [ Vnil () ] | [ Vboolean false ] -> assert false
  | _ -> assert true
  end;
  ([ Vnil () ], env)

let rec next v env =
  try
    match v with
    | [ Vtable tbl ] | [ Vtable tbl; Vnil () ] ->
      begin match LuaTable.next None tbl with
      | Some (k, v) -> ([ k; v ], env)
      | None -> ([ Vnil () ], env)
      end
    | [ Vtable tbl; v ] ->
      begin match LuaTable.next (Some v) tbl with
      | Some (k, v) -> ([ k; v ], env)
      | None -> ([ Vnil () ], env)
      end
    | [ Vref (VarName n) ] ->
      let vt = get_table_value n env in
      next [ vt ] env
    | [ Vref (VarName n); v ] ->
      let vt = get_table_value n env in
      next [ vt; v ] env
    | _ -> assert false
  with LuaTable.Table_error msg -> Lua_stdlib_common.error msg

let rec pairs v env =
  match v with
  | [ (Vtable tbl as t) ] ->
    begin match LuaTable.get_metatable_field "__pairs" tbl with
    | Some (Vfunction (_, _, _) as f) ->
      let _, v, env =
        match
          Interpret.interpret_fct f [ (Ast.empty_location (), Evalue t) ] env
        with
        | Error (_, msg) -> Lua_stdlib_common.error msg
        | Ok v -> v
      in
      ([ v; t; Vnil () ], env)
    | Some _ ->
      Lua_stdlib_common.typing_error
        "metatable.__pairs: attempt to call a non function value"
    | None -> ([ VfunctionStdLib (Random.bits32 (), next); t; Vnil () ], env)
    end
  | [ Vref (VarName n) ] ->
    let vt = get_table_value n env in
    pairs [ vt ] env
  | _ ->
    Lua_stdlib_common.typing_error
      "bad argument #1 to 'for iterator' (table expected)"

let rec inext v env =
  match v with
  | [ Vtable tbl ] | [ Vtable tbl; Vnil () ] ->
    begin match LuaTable.inext 0 tbl with
    | Some (i, v) -> ([ Vnumber (Ninteger i); v ], env)
    | None -> ([ Vnil () ], env)
    end
  | [ Vtable tbl; Vnumber (Ninteger i) ] when i > 0 ->
    begin match LuaTable.inext i tbl with
    | Some (i, v) -> ([ Vnumber (Ninteger i); v ], env)
    | None -> ([ Vnil () ], env)
    end
  | [ Vref (VarName n) ] ->
    let vt = get_table_value n env in
    inext [ vt ] env
  | [ Vref (VarName n); v ] ->
    let vt = get_table_value n env in
    inext [ vt; v ] env
  | _ -> assert false

let rec ipairs v env =
  match v with
  | [ Vtable tbl ] ->
    ([ VfunctionStdLib (Random.bits32 (), inext); Vtable tbl; Vnil () ], env)
  | [ Vref (VarName n) ] ->
    let vt = get_table_value n env in
    ipairs [ vt ] env
  | _ ->
    Lua_stdlib_common.typing_error
      "bad argument #1 to 'for iterator' (table expected)"

let print v env =
  let sl =
    List.map
      (fun v ->
        let s, _env = tostring_value v env in
        s )
      v
  in
  Format.pp_print_list ~pp_sep Format.pp_print_string Format.std_formatter sl;
  Format.fprintf Format.std_formatter "@.";
  ([ Vnil () ], env)

let rec typ v env =
  match v with
  | [ Vnil () ] -> ([ Vstring "nil" ], env)
  | [ Vboolean _ ] -> ([ Vstring "boolean" ], env)
  | [ Vnumber _ ] -> ([ Vstring "number" ], env)
  | [ Vstring _ ] -> ([ Vstring "string" ], env)
  | [ Vtable _ ] -> ([ Vstring "table" ], env)
  | [ Vfunction _ ] | [ VfunctionStdLib _ ] -> ([ Vstring "function" ], env)
  | [ Vref (VarName n) ] ->
    let vt = get_table_value n env in
    typ [ vt ] env
  | [ v ] ->
    Ast.print_value Format.err_formatter v;
    assert false
  | _ -> assert false

let tostring v env =
  match v with
  | [ v ] ->
    let s, env = tostring_value v env in
    ([ Vstring s ], env)
  | _ -> assert false

let rec getmetatable v env =
  match v with
  | [ Vtable tbl ] ->
    begin match LuaTable.get_metatable tbl with
    | Some mt ->
      begin match LuaTable.get (Vstring "__metatable") mt with
      | Ok v -> ([ v ], env)
      | Error _ -> ([ Vtable mt ], env)
      end
    | None -> ([ Vnil () ], env)
    end
  | [ Vref (VarName n) ] ->
    let vt = get_table_value n env in
    getmetatable [ vt ] env
  | _ -> ([ Vnil () ], env)

let rec setmetatable v env =
  let update_env name vl env =
    match vl with
    | [ (Vtable _ as vtbl) ] ->
      begin match Env.update_value name vtbl env with
      | Ok () -> (vl, env)
      | Error (_, msg) -> Lua_stdlib_common.error msg
      end
    | _ ->
      Lua_stdlib_common.typing_error
        "bad return value for 'setmetatable' ([table] expected)"
  in
  match v with
  | Vtable tbl :: Vnil () :: _tl ->
    let tbl = LuaTable.remove_metatable tbl in
    ([ Vtable tbl ], env)
  | Vtable tbl :: Vtable meta_tbl :: _tl ->
    begin match LuaTable.get_metatable_field "__metatable" tbl with
    | Some _ -> Lua_stdlib_common.error "cannot change a protected metatable"
    | None ->
      let tbl = LuaTable.set_metatable meta_tbl tbl in
      ([ Vtable tbl ], env)
    end
  | Vref (VarName n) :: Vnil () :: _tl ->
    let vt = get_table_value n env in
    let vl, env = setmetatable [ vt; Vnil () ] env in
    update_env n vl env
  | Vref (VarName n) :: Vtable meta_tbl :: _tl ->
    let vt = get_table_value n env in
    let vl, env = setmetatable [ vt; Vtable meta_tbl ] env in
    update_env n vl env
  | Vtable tbl :: Vref (VarName n) :: _tl ->
    let vt = get_table_value n env in
    setmetatable [ Vtable tbl; vt ] env
  | Vref (VarName n_tbl) :: Vref (VarName n_meta_tbl) :: _tl ->
    let vtbl = get_table_value n_tbl env in
    let vmtbl = get_table_value n_meta_tbl env in
    let vl, env = setmetatable [ vtbl; vmtbl ] env in
    update_env n_tbl vl env
  | Vtable _ :: _tl ->
    Lua_stdlib_common.typing_error
      "bad argument #2 to 'setmetatable' (nil or table expected)"
  | _ :: _tl ->
    Lua_stdlib_common.typing_error
      "bad argument #1 to 'setmetatable' (nil or table expected)"
  | [] ->
    Lua_stdlib_common.typing_error
      "bad argument #1 to 'setmetatable' (nil or table expected)"

let require v env =
  match v with
  | [ Vstring modul ] ->
    let modul = Format.sprintf "%s.lua" modul in
    begin match Interpreter.process modul false env with
    | Ok (vl, env) -> (vl, env)
    | Error (_, msg) ->
      let msg = Format.sprintf "error loading module %s: %s" modul msg in
      Lua_stdlib_common.error msg
    end
  | _ -> assert false
src/lua_stdlib_basic.ml

5.77%
