From 705c29aeed45fcd9ae02713e065efbfdf8bc339e Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Mon, 25 May 2020 19:01:15 +0200 Subject: [PATCH 1/4] remove old cases in transpiler --- src/passes/10-transpiler/transpiler.ml | 36 +++++--------------------- src/stages/5-mini_c/combinators.ml | 9 +++++++ src/stages/5-mini_c/combinators.mli | 2 ++ 3 files changed, 18 insertions(+), 29 deletions(-) diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 9c1973f0d..756c984d3 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -42,14 +42,6 @@ them. please report this to the developers." in ] in error ~data title content - let unsupported_iterator location = - let title () = "unsupported iterator" in - let content () = "only lambda are supported as iterators" in - let data = [ - row_loc location ; - ] in - error ~data title content - let not_functional_main location = let title () = "not functional main" in let content () = "main should be a function" in @@ -511,28 +503,14 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = return @@ E_record_update (record, path, update) | E_constant {cons_name=name; arguments=lst} -> ( let iterator_generator iterator_name = - let lambda_to_iterator_body (f : AST.expression) (l : AST.lambda) = - let%bind body' = transpile_annotated_expression l.result in - let%bind (input , _) = AST.get_t_function f.type_expression in - let%bind input' = transpile_type input in - ok ((l.binder , input') , body') - in let expression_to_iterator_body (f : AST.expression) = - match f.expression_content with - | E_lambda l -> lambda_to_iterator_body f l - | E_variable v -> ( - let%bind elt = - trace_option (corner_case ~loc:__LOC__ "missing var") @@ - AST.Environment.get_opt v f.environment in - match elt.definition with - | ED_declaration { expr = f ; free_variables = _ } -> ( - match f.expression_content with - | E_lambda l -> lambda_to_iterator_body f l - | _ -> fail @@ unsupported_iterator f.location - ) - | _ -> fail @@ unsupported_iterator f.location - ) - | _ -> fail @@ unsupported_iterator f.location + let%bind (input , output) = AST.get_t_function f.type_expression in + let%bind f' = transpile_annotated_expression f in + let%bind input' = transpile_type input in + let%bind output' = transpile_type output in + let binder = Var.fresh ~name:"iterated" () in + let application = Mini_c.Combinators.e_application f' output' (Mini_c.Combinators.e_var binder input') in + ok ((binder , input'), application) in fun (lst : AST.expression list) -> match (lst , iterator_name) with | [f ; i] , C_ITER | [f ; i] , C_MAP -> ( diff --git a/src/stages/5-mini_c/combinators.ml b/src/stages/5-mini_c/combinators.ml index ff421421c..f01eda745 100644 --- a/src/stages/5-mini_c/combinators.ml +++ b/src/stages/5-mini_c/combinators.ml @@ -183,6 +183,15 @@ let e_let_in ?loc v tv inline expr body : expression = Expression.(make_tpl ?loc E_let_in ((v , tv) , inline, expr , body) , get_type body )) +let e_application ?loc f t arg: expression = Expression.(make_tpl ?loc( + E_application (f,arg) , + t + )) +let e_var ?loc vname t: expression = Expression.(make_tpl ?loc( + E_variable vname , + t + )) + let ez_e_sequence ?loc a b : expression = Expression.(make_tpl (E_sequence (make_tpl ?loc (a , t_unit ()) , b) , get_type b)) diff --git a/src/stages/5-mini_c/combinators.mli b/src/stages/5-mini_c/combinators.mli index f198e8b8e..3a9aab3ed 100644 --- a/src/stages/5-mini_c/combinators.mli +++ b/src/stages/5-mini_c/combinators.mli @@ -78,3 +78,5 @@ val d_unit : value val environment_wrap : environment -> environment -> environment_wrap val id_environment_wrap : environment -> environment_wrap +val e_var : ?loc:Location.t -> var_name -> type_expression -> expression +val e_application : ?loc:Location.t -> expression -> type_expression -> expression -> expression From 2de18b87272621ddbff83231d8fe0ccb1ab4e19e Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Mon, 25 May 2020 19:22:49 +0200 Subject: [PATCH 2/4] solve bug in environment recomputing --- src/passes/9-self_ast_typed/recompute_environment.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/passes/9-self_ast_typed/recompute_environment.ml b/src/passes/9-self_ast_typed/recompute_environment.ml index 4124038c2..bed098190 100644 --- a/src/passes/9-self_ast_typed/recompute_environment.ml +++ b/src/passes/9-self_ast_typed/recompute_environment.ml @@ -34,9 +34,9 @@ let rec expression : environment -> expression -> expression = fun env expr -> return @@ E_lambda { c with result } ) | E_let_in c -> ( - let env' = Environment.add_ez_declaration c.let_binder c.rhs env in - let let_result = self ~env' c.let_result in let rhs = self c.rhs in + let env' = Environment.add_ez_declaration c.let_binder rhs env in + let let_result = self ~env' c.let_result in return @@ E_let_in { c with rhs ; let_result } ) (* rec fun_name binder -> result *) @@ -152,7 +152,7 @@ let program : environment -> program -> program = fun init_env prog -> let aux (pre_env , rev_decls) decl_wrapped = let (Declaration_constant c) = Location.unwrap decl_wrapped in let expr = expression pre_env c.expr in - let post_env = Environment.add_ez_declaration c.binder c.expr pre_env in + let post_env = Environment.add_ez_declaration c.binder expr pre_env in let post_env' = merge c.post_env post_env in let wrap_content = Declaration_constant { c with expr ; post_env = post_env' } in let decl_wrapped' = { decl_wrapped with wrap_content } in From f455fa237672a65c4bea4936cb81b3db5e4ec854 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Mon, 25 May 2020 19:30:25 +0200 Subject: [PATCH 3/4] add a test case for double fold env recomputing --- src/bin/expect_tests/michelson_converter.ml | 22 ++++++ .../contracts/double_fold_converter.religo | 72 +++++++++++++++++++ 2 files changed, 94 insertions(+) create mode 100644 src/test/contracts/double_fold_converter.religo diff --git a/src/bin/expect_tests/michelson_converter.ml b/src/bin/expect_tests/michelson_converter.ml index f1437f44f..cc055ee24 100644 --- a/src/bin/expect_tests/michelson_converter.ml +++ b/src/bin/expect_tests/michelson_converter.ml @@ -184,6 +184,28 @@ let%expect_test _ = let%expect_test _ = run_ligo_good [ "compile-contract" ; (contract "michelson_converter_mixed_pair_or.mligo") ; "main2" ] ; + [%expect {| + { parameter + (or (pair %option1 (string %bar) (nat %baz)) (pair %option2 (string %bar) (nat %baz))) ; + storage nat ; + code { DUP ; + CAR ; + IF_LEFT + { DUP ; LEFT (pair (string %bar) (nat %baz)) ; DIP { DROP } } + { DUP ; RIGHT (pair (string %bar) (nat %baz)) ; DIP { DROP } } ; + DUP ; + IF_LEFT + { DUP ; LEFT (pair (string %bar) (nat %baz)) ; DIP { DROP } } + { DUP ; RIGHT (pair (string %bar) (nat %baz)) ; DIP { DROP } } ; + DIP { DROP } ; + DUP ; + IF_LEFT + { DUP ; CDR ; NIL operation ; PAIR ; DIP { DROP } } + { DUP ; CDR ; NIL operation ; PAIR ; DIP { DROP } } ; + DIP { DROP 2 } } } |}] + +let%expect_test _ = + run_ligo_good [ "compile-contract" ; (contract "double_fold_converter.religo") ; "main" ] ; [%expect {| { parameter (or (pair %option1 (string %bar) (nat %baz)) (pair %option2 (string %bar) (nat %baz))) ; diff --git a/src/test/contracts/double_fold_converter.religo b/src/test/contracts/double_fold_converter.religo new file mode 100644 index 000000000..01245222b --- /dev/null +++ b/src/test/contracts/double_fold_converter.religo @@ -0,0 +1,72 @@ +type tokenId = nat; +type tokenOwner = address; +type tokenAmount = nat; +type transferContents = { + to_: tokenOwner, + token_id: tokenId, + amount: tokenAmount +}; +type transfer = { + from_: tokenOwner, + txs: list(transferContents) +}; +type transferContentsMichelson = michelson_pair_right_comb(transferContents); +type transferAuxiliary = { + from_: tokenOwner, + txs: list(transferContentsMichelson) +}; +type transferMichelson = michelson_pair_right_comb(transferAuxiliary); +type transferParameter = list(transferMichelson); +type parameter = +| Transfer(transferParameter) +type storage = big_map(tokenId, tokenOwner); +type entrypointParameter = (parameter, storage); +type entrypointReturn = (list(operation), storage); +let errorTokenUndefined = "TOKEN_UNDEFINED"; +let errorNotOwner = "NOT_OWNER"; +let errorInsufficientBalance = "INSUFFICIENT_BALANCE"; +type transferContentsIteratorAccumulator = (storage, tokenOwner); +let transferContentsIterator = ((accumulator, transferContentsMichelson): (transferContentsIteratorAccumulator, transferContentsMichelson)): transferContentsIteratorAccumulator => { + let (storage, from_) = accumulator; + let transferContents: transferContents = Layout.convert_from_right_comb(transferContentsMichelson); + let tokenOwner: option(tokenOwner) = Map.find_opt(transferContents.token_id, storage); + let tokenOwner = switch (tokenOwner) { + | None => (failwith(errorTokenUndefined): tokenOwner) + | Some(tokenOwner) => if (tokenOwner == from_) { + tokenOwner + } else { + (failwith(errorInsufficientBalance): tokenOwner); + } + }; + let storage = Map.update( + transferContents.token_id, + Some(transferContents.to_), + storage + ); + (storage, from_) +}; +let allowOnlyOwnTransfer = (from: tokenOwner): unit => { + if (from != Tezos.sender) { + failwith(errorNotOwner) + } else { (); } +} +let transferIterator = ((storage, transferMichelson): (storage, transferMichelson)): storage => { + let transferAuxiliary2: transferAuxiliary = Layout.convert_from_right_comb(transferMichelson); + let from_: tokenOwner = transferAuxiliary2.from_; + allowOnlyOwnTransfer(from_); + let (storage, _) = List.fold( + transferContentsIterator, + transferAuxiliary2.txs, + (storage, from_) + ); + storage +}; +let transfer = ((transferParameter, storage): (transferParameter, storage)): entrypointReturn => { + let storage = List.fold(transferIterator, transferParameter, storage); + (([]: list(operation)), storage); +}; +let main = ((parameter, storage): entrypointParameter): entrypointReturn => { + switch (parameter) { + | Transfer(transferParameter) => transfer((transferParameter, storage)) + } +} \ No newline at end of file From 66c1e51cb25e2f61b0595b9c96b510ce51ddc9b0 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Tue, 26 May 2020 15:38:41 +0200 Subject: [PATCH 4/4] updating tests --- src/bin/expect_tests/michelson_converter.ml | 121 +++++++++++++++++--- 1 file changed, 108 insertions(+), 13 deletions(-) diff --git a/src/bin/expect_tests/michelson_converter.ml b/src/bin/expect_tests/michelson_converter.ml index cc055ee24..b8a6cd90e 100644 --- a/src/bin/expect_tests/michelson_converter.ml +++ b/src/bin/expect_tests/michelson_converter.ml @@ -208,20 +208,115 @@ let%expect_test _ = run_ligo_good [ "compile-contract" ; (contract "double_fold_converter.religo") ; "main" ] ; [%expect {| { parameter - (or (pair %option1 (string %bar) (nat %baz)) (pair %option2 (string %bar) (nat %baz))) ; - storage nat ; + (list (pair (address %from_) + (list %txs (pair (address %to_) (pair (nat %token_id) (nat %amount)))))) ; + storage (big_map nat address) ; code { DUP ; + CDR ; + DIG 1 ; + DUP ; + DUG 2 ; CAR ; - IF_LEFT - { DUP ; LEFT (pair (string %bar) (nat %baz)) ; DIP { DROP } } - { DUP ; RIGHT (pair (string %bar) (nat %baz)) ; DIP { DROP } } ; + ITER { SWAP ; + PAIR ; + DUP ; + CDR ; + DUP ; + CAR ; + SENDER ; + DIG 1 ; + DUP ; + DUG 2 ; + COMPARE ; + NEQ ; + IF { PUSH string "NOT_OWNER" ; FAILWITH } { PUSH unit Unit } ; + DIG 1 ; + DUP ; + DUG 2 ; + DIG 4 ; + DUP ; + DUG 5 ; + CAR ; + PAIR ; + DIG 3 ; + DUP ; + DUG 4 ; + CDR ; + ITER { SWAP ; + PAIR ; + DUP ; + CAR ; + DIG 1 ; + DUP ; + DUG 2 ; + CDR ; + DIG 1 ; + DUP ; + DUG 2 ; + CAR ; + DIG 2 ; + DUP ; + DUG 3 ; + CDR ; + DIG 2 ; + DUP ; + DUG 3 ; + CDR ; + CAR ; + DIG 3 ; + DUP ; + DUG 4 ; + CAR ; + DIG 4 ; + DUP ; + DUG 5 ; + CDR ; + CDR ; + PAIR ; + PAIR ; + DIG 2 ; + DUP ; + DUG 3 ; + DIG 1 ; + DUP ; + DUG 2 ; + CDR ; + GET ; + IF_NONE + { PUSH string "TOKEN_UNDEFINED" ; FAILWITH } + { DIG 2 ; + DUP ; + DUG 3 ; + DIG 1 ; + DUP ; + DUG 2 ; + COMPARE ; + EQ ; + IF { DUP } { PUSH string "INSUFFICIENT_BALANCE" ; FAILWITH } ; + DIP { DROP } } ; + DIG 2 ; + DUP ; + DUG 3 ; + DIG 4 ; + DUP ; + DUG 5 ; + DIG 3 ; + DUP ; + DUG 4 ; + CAR ; + CDR ; + SOME ; + DIG 4 ; + DUP ; + DUG 5 ; + CDR ; + UPDATE ; + PAIR ; + DIP { DROP 7 } } ; + DUP ; + CAR ; + DIP { DROP 5 } } ; DUP ; - IF_LEFT - { DUP ; LEFT (pair (string %bar) (nat %baz)) ; DIP { DROP } } - { DUP ; RIGHT (pair (string %bar) (nat %baz)) ; DIP { DROP } } ; - DIP { DROP } ; - DUP ; - IF_LEFT - { DUP ; CDR ; NIL operation ; PAIR ; DIP { DROP } } - { DUP ; CDR ; NIL operation ; PAIR ; DIP { DROP } } ; + NIL operation ; + PAIR ; DIP { DROP 2 } } } |}] \ No newline at end of file