Add get_entrypoint...

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
 
 

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

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") @@

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 ] -> (

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'
   *)

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 ;

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)

src/test/integration_tests.ml

@@ -1175,6 +1175,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_ ;
@@ -1259,4 +1264,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 ;
   ]