diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml index 9851d2d36..5606adf54 100644 --- a/src/main/compile/of_mini_c.ml +++ b/src/main/compile/of_mini_c.ml @@ -51,8 +51,7 @@ let compile_contract_entry = fun program name -> in let%bind param_michelson = Compiler.Type.type_ param_ty in let%bind storage_michelson = Compiler.Type.type_ storage_ty in - let body = Michelson.strip_annots compiled.body in - let contract = Michelson.contract param_michelson storage_michelson body in + let contract = Michelson.contract param_michelson storage_michelson compiled.body in ok contract diff --git a/src/main/run/of_michelson.ml b/src/main/run/of_michelson.ml index 41e49c7f3..e044781be 100644 --- a/src/main/run/of_michelson.ml +++ b/src/main/run/of_michelson.ml @@ -24,7 +24,6 @@ let run ?options (* ?(is_input_value = false) *) (program:compiled_program) (inp Trace.trace_tzresult_lwt (simple_error "error parsing input") @@ Memory_proto_alpha.parse_michelson_data input_michelson input_ty in - let body = Michelson.strip_annots body in let%bind descr = Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@ Memory_proto_alpha.parse_michelson body diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml index 4916dab73..e8358ce22 100644 --- a/src/passes/8-compiler/compiler_program.ml +++ b/src/passes/8-compiler/compiler_program.ml @@ -4,6 +4,28 @@ open Michelson open Memory_proto_alpha.Protocol.Script_ir_translator open Operators.Compiler +module Errors = struct + let corner_case ~loc message = + let title () = "corner case" in + let content () = "we don't have a good error message for this case. we are +striving find ways to better report them and find the use-cases that generate +them. please report this to the developers." in + let data = [ + ("location" , fun () -> loc) ; + ("message" , fun () -> message) ; + ] in + error ~data title content + + let contract_entrypoint_must_be_literal ~loc = + let title () = "contract entrypoint must be literal" in + let content () = "For get_entrypoint, entrypoint must be given as a literal string" in + let data = + [ ("location", fun () -> loc) ; + ] in + error ~data title content +end +open Errors + let get_operator : string -> type_value -> expression list -> predicate result = fun s ty lst -> match Map.String.find_opt s Operators.Compiler.operators with | Some x -> ok x @@ -50,14 +72,26 @@ let get_operator : string -> type_value -> expression list -> predicate result = let%bind l_ty = Compiler_type.type_ l in ok @@ simple_unary @@ prim ~children:[l_ty] I_RIGHT | "CONTRACT" -> - let%bind r = match lst with - | [ _ ] -> get_t_contract ty - | _ -> simple_fail "mini_c . CONTRACT" in + let%bind r = get_t_contract ty in let%bind r_ty = Compiler_type.type_ r in ok @@ simple_unary @@ seq [ prim ~children:[r_ty] I_CONTRACT ; i_assert_some_msg (i_push_string "bad address for get_contract") ; ] + | "CONTRACT_ENTRYPOINT" -> + let%bind r = get_t_contract ty in + let%bind r_ty = Compiler_type.type_ r in + let%bind entry = match lst with + | [ { content = E_literal (D_string entry); type_value = _ } ; _addr ] -> ok entry + | [ _entry ; _addr ] -> + fail @@ contract_entrypoint_must_be_literal ~loc:__LOC__ + | _ -> + fail @@ corner_case ~loc:__LOC__ "mini_c . CONTRACT_ENTRYPOINT" in + ok @@ simple_binary @@ seq [ + i_drop ; (* drop the entrypoint... *) + prim ~annot:[entry] ~children:[r_ty] I_CONTRACT ; + i_assert_some_msg (i_push_string @@ Format.sprintf "bad address for get_entrypoint (%s)" entry) ; + ] | x -> simple_fail ("predicate \"" ^ x ^ "\" doesn't exist") ) @@ -193,7 +227,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result pre_code ; f ; ] - | _ -> simple_fail "bad arity" + | _ -> simple_fail ("bad arity for " ^ str) in let error = let title () = "error compiling constant" in @@ -446,20 +480,6 @@ let translate_entry (p:anon_function) ty : compiled_program result = let%bind output = Compiler_type.Ty.type_ output in ok ({input;output;body}:compiled_program) -module Errors = struct - let corner_case ~loc message = - let title () = "corner case" in - let content () = "we don't have a good error message for this case. we are -striving find ways to better report them and find the use-cases that generate -them. please report this to the developers." in - let data = [ - ("location" , fun () -> loc) ; - ("message" , fun () -> message) ; - ] in - error ~data title content -end -open Errors - let translate_contract : anon_function -> _ -> michelson result = fun f ty -> let%bind compiled_program = trace_strong (corner_case ~loc:__LOC__ "compiling") @@ diff --git a/src/passes/operators/helpers.ml b/src/passes/operators/helpers.ml index 46ffc302b..28b6fb20e 100644 --- a/src/passes/operators/helpers.ml +++ b/src/passes/operators/helpers.ml @@ -61,6 +61,15 @@ module Typer = struct | _ -> fail @@ wrong_param_number s 2 lst let typer_2 name f : typer = (name , typer'_2 name f) + let typer'_2_opt : name -> (type_value -> type_value -> type_value option -> type_value result) -> typer' = fun s f lst tv_opt -> + match lst with + | [ a ; b ] -> ( + let%bind tv' = f a b tv_opt in + ok (s , tv') + ) + | _ -> fail @@ wrong_param_number s 2 lst + let typer_2_opt name f : typer = (name , typer'_2_opt name f) + let typer'_3 : name -> (type_value -> type_value -> type_value -> type_value result) -> typer' = fun s f lst _ -> match lst with | [ a ; b ; c ] -> ( diff --git a/src/passes/operators/helpers.mli b/src/passes/operators/helpers.mli index 63b9b49c6..b34242fa0 100644 --- a/src/passes/operators/helpers.mli +++ b/src/passes/operators/helpers.mli @@ -27,6 +27,7 @@ module Typer : sig val typer'_2 : name -> (type_value -> type_value -> type_value result) -> typer' *) val typer_2 : name -> (type_value -> type_value -> type_value result) -> typer + val typer_2_opt : name -> (type_value -> type_value -> type_value option -> type_value result) -> typer (* val typer'_3 : name -> (type_value -> type_value -> type_value -> type_value result) -> typer' *) diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index 2546357cb..fed495a6e 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -60,6 +60,7 @@ module Simplify = struct ("get_force" , "MAP_GET_FORCE") ; ("transaction" , "CALL") ; ("get_contract" , "CONTRACT") ; + ("get_entrypoint" , "CONTRACT_ENTRYPOINT") ; ("size" , "SIZE") ; ("int" , "INT") ; ("abs" , "ABS") ; @@ -201,6 +202,7 @@ module Simplify = struct ("Operation.transaction" , "CALL") ; ("Operation.get_contract" , "CONTRACT") ; + ("Operation.get_entrypoint" , "CONTRACT_ENTRYPOINT") ; ("int" , "INT") ; ("abs" , "ABS") ; ("unit" , "UNIT") ; @@ -487,6 +489,20 @@ module Typer = struct get_t_contract tv in ok @@ t_contract tv' () + let get_entrypoint = typer_2_opt "CONTRACT_ENTRYPOINT" @@ fun entry_tv addr_tv tv_opt -> + if not (type_value_eq (entry_tv, t_string ())) + then fail @@ simple_error (Format.asprintf "get_entrypoint expects a string entrypoint label for first argument, got %a" PP.type_value entry_tv) + else + if not (type_value_eq (addr_tv, t_address ())) + then fail @@ simple_error (Format.asprintf "get_entrypoint expects an address for second argument, got %a" PP.type_value addr_tv) + else + let%bind tv = + trace_option (simple_error "get_entrypoint needs a type annotation") tv_opt in + let%bind tv' = + trace_strong (simple_error "get_entrypoint has a not-contract annotation") @@ + get_t_contract tv in + ok @@ t_contract tv' () + let set_delegate = typer_1 "SET_DELEGATE" @@ fun delegate_opt -> let%bind () = assert_eq_1 delegate_opt (t_option (t_key_hash ()) ()) in ok @@ t_operation () @@ -756,6 +772,7 @@ module Typer = struct amount ; transaction ; get_contract ; + get_entrypoint ; neg ; abs ; cons ; diff --git a/src/test/contracts/entrypoints.ligo b/src/test/contracts/entrypoints.ligo new file mode 100644 index 000000000..0464c98c7 --- /dev/null +++ b/src/test/contracts/entrypoints.ligo @@ -0,0 +1,4 @@ +function cb(const a : address; const s : unit) : list(operation) * unit is + const c : contract(unit) = get_entrypoint("%cb", a) ; + block { skip } + with (list transaction(unit, 0mutez, c) end, s) diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index c615dca86..d11e01f30 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -1218,6 +1218,11 @@ let deep_access_ligo () : unit result = let make_expected = e_int 2 in expect_eq program "main" make_input make_expected +let entrypoints_ligo () : unit result = + let%bind _program = type_file "./contracts/entrypoints.ligo" in + (* hmm... *) + ok () + let main = test_suite "Integration (End to End)" [ test "type alias" type_alias ; test "function" function_ ; @@ -1305,4 +1310,5 @@ let main = test_suite "Integration (End to End)" [ test "balance constant (mligo)" balance_constant_mligo ; test "simple_access (ligo)" simple_access_ligo; test "deep_access (ligo)" deep_access_ligo; + test "entrypoints (ligo)" entrypoints_ligo ; ]