From ad7024c62b442f19a88ce6461f971aa7fb4502fe Mon Sep 17 00:00:00 2001
From: Lesenechal Remi <lesenechal.remi@gmail.com>
Date: Fri, 28 Feb 2020 18:11:02 +0100
Subject: [PATCH] compiler: compile CREATE_CONTRACT

---
 src/passes/8-compiler/compiler_program.ml | 21 +++++++++++++++++++--
 src/stages/mini_c/combinators.ml          |  2 +-
 src/stages/mini_c/combinators.mli         |  2 +-
 3 files changed, 21 insertions(+), 4 deletions(-)

diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml
index a93b58299..a4ffbd0e0 100644
--- a/src/passes/8-compiler/compiler_program.ml
+++ b/src/passes/8-compiler/compiler_program.ml
@@ -27,7 +27,7 @@ end
 open Errors
 
 (* This does not makes sense to me *)
-let get_operator : constant' -> type_value -> expression list -> predicate result = fun s ty lst ->
+let rec get_operator : constant' -> type_value -> expression list -> predicate result = fun s ty lst ->
   match Operators.Compiler.get_operators s with
   | Ok (x,_) -> ok x
   | Error _ -> (
@@ -114,10 +114,23 @@ let get_operator : constant' -> type_value -> expression list -> predicate resul
             i_drop ; (* drop the entrypoint... *)
             prim ~annot:[entry] ~children:[r_ty] I_CONTRACT ;
           ]
+      | C_CREATE_CONTRACT ->
+        let%bind ch = match lst with
+          | { content= E_closure {body;binder} ; type_value = T_function (T_pair ((_,p),(_,s)) as tin,_)} :: _ ->
+            let%bind closure = translate_function_body {body;binder} [] tin in
+            let%bind (p',s') = bind_map_pair Compiler_type.type_ (p,s) in
+            ok @@ contract p' s' closure
+          | _ -> fail @@ corner_case ~loc:__LOC__ "mini_c . CREATE_CONTRACT"
+        in
+        ok @@ simple_tetrary @@ seq [
+          i_drop ;
+          prim ~children:[ch] I_CREATE_CONTRACT ;
+          i_pair ;
+        ]
       | x -> simple_fail (Format.asprintf "predicate \"%a\" doesn't exist" PP.constant x)
     )
 
-let rec translate_value (v:value) ty : michelson result = match v with
+and translate_value (v:value) ty : michelson result = match v with
   | D_bool b -> ok @@ prim (if b then D_True else D_False)
   | D_int n -> ok @@ int (Z.of_int n)
   | D_nat n -> ok @@ int (Z.of_int n)
@@ -249,6 +262,10 @@ and translate_expression (expr:expression) (env:environment) : michelson result
             pre_code ;
             f ;
           ]
+        | Tetrary f, 4 -> ok @@ seq [
+            pre_code ;
+            f ;
+          ]
         | _ -> simple_fail (Format.asprintf "bad arity for %a" PP.constant str)
       in
       let error =
diff --git a/src/stages/mini_c/combinators.ml b/src/stages/mini_c/combinators.ml
index 2912aec93..019a111be 100644
--- a/src/stages/mini_c/combinators.ml
+++ b/src/stages/mini_c/combinators.ml
@@ -152,7 +152,7 @@ let get_t_contract t = match t with
   | _ -> fail @@ wrong_type "contract" t
 
 let get_t_operation t = match t with
-  | T_base TC_operation -> ok ()
+  | T_base TC_operation -> ok t
   | _ -> fail @@ wrong_type "operation" t
 
 let get_operation (v:value) = match v with
diff --git a/src/stages/mini_c/combinators.mli b/src/stages/mini_c/combinators.mli
index 3f9b1552e..d61620589 100644
--- a/src/stages/mini_c/combinators.mli
+++ b/src/stages/mini_c/combinators.mli
@@ -49,7 +49,7 @@ val wrong_type : string -> type_value -> unit -> error
 val get_t_left : type_value -> type_value result
 val get_t_right : type_value -> type_value result
 val get_t_contract : type_value -> type_value result
-val get_t_operation : type_value -> unit result
+val get_t_operation : type_value -> type_value result
 val get_operation : value -> Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation result
 
 val t_int : type_value