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/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.