diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index cc22a7410..443102d80 100644 --- a/src/bin/expect_tests/contract_tests.ml +++ b/src/bin/expect_tests/contract_tests.ml @@ -2,6 +2,8 @@ open Cli_expect let contract basename = "../../test/contracts/" ^ basename +let bad_contract basename = + "../../test/contracts/negative/" ^ basename let%expect_test _ = run_ligo_good [ "measure-contract" ; contract "coase.ligo" ; "main" ] ; @@ -1024,3 +1026,15 @@ let%expect_test _ = [%expect {| failwith("This contract always fails") |}] +let%expect_test _ = + run_ligo_bad [ "compile-contract" ; bad_contract "self_in_lambda.mligo" ; "main" ] ; + [%expect {| + ligo: Wrong SELF_ADDRESS location: SELF_ADDRESS is only allowed at top-level + + If you're not sure how to fix this error, you can + do one of the following: + + * Visit our documentation: https://ligolang.org/docs/intro/what-and-why/ + * Ask a question on our Discord: https://discord.gg/9rhYaEt + * Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new + * Check the changelog by running 'ligo changelog' |}] \ No newline at end of file diff --git a/src/main/compile/of_michelson.ml b/src/main/compile/of_michelson.ml index 0b070fb79..87cfbb5a7 100644 --- a/src/main/compile/of_michelson.ml +++ b/src/main/compile/of_michelson.ml @@ -5,10 +5,9 @@ open Trace module Errors = struct (* TODO: those errors should have been caught in the earlier stages on the ligo pipeline - Here, in case of contract not typechecking, we should write a warning with a "please report" - on stderr and print the ill-typed michelson code; + build_contract is a kind of security net *) - let title_type_check_msg () = "Invalid contract (This might be a compiler bug, please report) " + let title_type_check_msg () = "generated Michelson contract failed to typecheck" let bad_parameter c () = let message () = let code = Format.asprintf "%a" Michelson.pp c in @@ -22,7 +21,7 @@ module Errors = struct let bad_contract c () = let message () = let code = Format.asprintf "%a" Michelson.pp c in - "bad contract type (contract entry point is expected to be of the form \"parameter * storage -> list(operation) * storage\"):\n"^code in + "bad contract type\n"^code in error title_type_check_msg message let unknown () = let message () = diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml index 3b48d3921..4d99be97a 100644 --- a/src/main/compile/of_mini_c.ml +++ b/src/main/compile/of_mini_c.ml @@ -3,6 +3,7 @@ open Proto_alpha_utils open Trace let compile_contract : expression -> Compiler.compiled_expression result = fun e -> + let%bind e = Self_mini_c.contract_check e in let%bind (input_ty , _) = get_t_function e.type_value in let%bind body = get_function e in let%bind body = Compiler.Program.translate_function_body body [] input_ty in diff --git a/src/passes/3-self_ast_simplified/self_ast_simplified.ml b/src/passes/3-self_ast_simplified/self_ast_simplified.ml index a1ce4b580..f0ecd5183 100644 --- a/src/passes/3-self_ast_simplified/self_ast_simplified.ml +++ b/src/passes/3-self_ast_simplified/self_ast_simplified.ml @@ -6,14 +6,6 @@ let all = [ Literals.peephole_expression ; ] -let rec bind_chain : ('a -> 'a result) list -> 'a -> 'a result = fun fs x -> - match fs with - | [] -> ok x - | hd :: tl -> ( - let aux : 'a -> 'a result = fun x -> bind (bind_chain tl) (hd x) in - bind aux (ok x) - ) - let all_program = let all_p = List.map Helpers.map_program all in bind_chain all_p diff --git a/src/passes/7-self_mini_c/helpers.ml b/src/passes/7-self_mini_c/helpers.ml index ea7756a35..f5638cbe5 100644 --- a/src/passes/7-self_mini_c/helpers.ml +++ b/src/passes/7-self_mini_c/helpers.ml @@ -163,3 +163,11 @@ let rec map_expression : mapper -> expression -> expression result = fun f e -> let%bind updates = bind_map_list (fun (p,e) -> let%bind e = self e in ok(p,e)) updates in return @@ E_update(r,updates) ) + +let map_sub_level_expression : mapper -> expression -> expression result = fun f e -> + match e.content with + | E_closure {binder ; body} -> + let%bind body = map_expression f body in + let content = E_closure {binder; body} in + ok @@ { e with content } + | _ -> ok e \ No newline at end of file diff --git a/src/passes/7-self_mini_c/michelson_restrictions.ml b/src/passes/7-self_mini_c/michelson_restrictions.ml new file mode 100644 index 000000000..7f9e14169 --- /dev/null +++ b/src/passes/7-self_mini_c/michelson_restrictions.ml @@ -0,0 +1,26 @@ +open Mini_c +open Trace + +module Errors = struct + + let bad_self_address cst () = + let title = thunk @@ + Format.asprintf "Wrong %alocation" Mini_c.PP.expression' cst in + let message = thunk @@ + Format.asprintf "%ais only allowed at top-level" Mini_c.PP.expression' cst in + error title message () + +end +open Errors + +let self_in_lambdas : expression -> expression result = + fun e -> + match e.content with + | E_closure {binder=_ ; body} -> + let%bind _self_in_lambdas = Helpers.map_expression + (fun e -> match e.content with + | E_constant (C_SELF_ADDRESS, _) as c -> fail (bad_self_address c) + | _ -> ok e) + body in + ok e + | _ -> ok e diff --git a/src/passes/7-self_mini_c/self_mini_c.ml b/src/passes/7-self_mini_c/self_mini_c.ml index 329dad692..da2c66fa6 100644 --- a/src/passes/7-self_mini_c/self_mini_c.ml +++ b/src/passes/7-self_mini_c/self_mini_c.ml @@ -250,6 +250,11 @@ let betas : bool ref -> expression -> expression = fun changed -> map_expression (beta changed) +let contract_check = + let all = [Michelson_restrictions.self_in_lambdas] in + let all_e = List.map Helpers.map_sub_level_expression all in + bind_chain all_e + let rec all_expression : expression -> expression = fun e -> let changed = ref false in diff --git a/src/test/contracts/negative/self_in_lambda.mligo b/src/test/contracts/negative/self_in_lambda.mligo new file mode 100644 index 000000000..493047199 --- /dev/null +++ b/src/test/contracts/negative/self_in_lambda.mligo @@ -0,0 +1,5 @@ +let foo (u: unit) : address = + Current.self_address + +let main (ps: unit * address): (operation list * address) = + ( ([] : operation list) , foo) \ No newline at end of file diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index dc80894d4..969de430d 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -718,6 +718,14 @@ let bind_fold_map_pair f acc (a, b) = let bind_map_triple f (a, b, c) = bind_and3 (f a, f b, f c) +let rec bind_chain : ('a -> 'a result) list -> 'a -> 'a result = fun fs x -> + match fs with + | [] -> ok x + | hd :: tl -> ( + let aux : 'a -> 'a result = fun x -> bind (bind_chain tl) (hd x) in + bind aux (ok x) + ) + (** Wraps a call that might trigger an exception in a result.