balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

compiler: compile CREATE_CONTRACT

Browse Source
This commit is contained in:
Lesenechal Remi 2020-02-28 18:11:02 +01:00
parent 4e48026daa
commit ad7024c62b
3 changed files with 21 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
src/passes/8-compiler/compiler_program.ml
View File

@ -27,7 +27,7 @@ end
open Errors open Errors
(* This does not makes sense to me *) (* 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 match Operators.Compiler.get_operators s with
| Ok (x,_) -> ok x | Ok (x,_) -> ok x
| Error _ -> ( | Error _ -> (
@ -114,10 +114,23 @@ let get_operator : constant' -> type_value -> expression list -> predicate resul
i_drop ; (* drop the entrypoint... *) i_drop ; (* drop the entrypoint... *)
prim ~annot:[entry] ~children:[r_ty] I_CONTRACT ; 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) | 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_bool b -> ok @@ prim (if b then D_True else D_False)
| D_int n -> ok @@ int (Z.of_int n) | D_int n -> ok @@ int (Z.of_int n)
| D_nat 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 ; pre_code ;
f ; f ;
] ]
| Tetrary f, 4 -> ok @@ seq [
pre_code ;
f ;
]
| _ -> simple_fail (Format.asprintf "bad arity for %a" PP.constant str) | _ -> simple_fail (Format.asprintf "bad arity for %a" PP.constant str)
in in
let error = let error =

2
src/stages/mini_c/combinators.ml
View File

@ -152,7 +152,7 @@ let get_t_contract t = match t with
| _ -> fail @@ wrong_type "contract" t | _ -> fail @@ wrong_type "contract" t
let get_t_operation t = match t with let get_t_operation t = match t with
| T_base TC_operation -> ok () | T_base TC_operation -> ok t
| _ -> fail @@ wrong_type "operation" t | _ -> fail @@ wrong_type "operation" t
let get_operation (v:value) = match v with let get_operation (v:value) = match v with

2
src/stages/mini_c/combinators.mli
View File

@ -49,7 +49,7 @@ val wrong_type : string -> type_value -> unit -> error
val get_t_left : type_value -> type_value result val get_t_left : type_value -> type_value result
val get_t_right : 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_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 get_operation : value -> Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation result
val t_int : type_value val t_int : type_value