diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 6ab46b7f6..5540d8ea1 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -150,11 +150,6 @@ let measure_contract = let compile_parameter = let f source_file entry_point expression syntax display_format michelson_format = toplevel ~display_format @@ - (* - TODO: - source_to_michelson_contract will fail if the entry_point does not point to a michelson contract - but we do not check that the type of the parameter matches the type of the given expression - *) let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind typed_prg,state = Compile.Of_simplified.compile simplified in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in @@ -169,6 +164,7 @@ let compile_parameter = let%bind (typed_param,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_param in let%bind mini_c_param = Compile.Of_typed.compile_expression typed_param in let%bind compiled_param = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_param in + let%bind () = Compile.Of_mini_c.assert_equal_michelson_type Check_parameter michelson_prg compiled_param in let%bind value = Run.evaluate_expression compiled_param.expr compiled_param.expr_ty in ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value in @@ -210,11 +206,6 @@ let interpret = let compile_storage = let f source_file entry_point expression syntax display_format michelson_format = toplevel ~display_format @@ - (* - TODO: - source_to_michelson_contract will fail if the entry_point does not point to a michelson contract - but we do not check that the type of the storage matches the type of the given expression - *) let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind typed_prg,state = Compile.Of_simplified.compile simplified in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in @@ -229,6 +220,7 @@ let compile_storage = let%bind (typed_param,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_param in let%bind mini_c_param = Compile.Of_typed.compile_expression typed_param in let%bind compiled_param = Compile.Of_mini_c.compile_expression mini_c_param in + let%bind () = Compile.Of_mini_c.assert_equal_michelson_type Check_storage michelson_prg compiled_param in let%bind value = Run.evaluate_expression compiled_param.expr compiled_param.expr_ty in ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value in diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml index 0ed53895f..32572ae13 100644 --- a/src/main/compile/of_mini_c.ml +++ b/src/main/compile/of_mini_c.ml @@ -47,3 +47,17 @@ let build_contract : Compiler.compiled_expression -> Michelson.michelson result Trace.trace_tzresult_lwt (simple_error "Invalid contract: Contract did not typecheck") @@ Proto_alpha_utils.Memory_proto_alpha.typecheck_contract contract in ok contract + +type check_type = Check_parameter | Check_storage +let assert_equal_michelson_type : check_type -> Compiler.compiled_expression -> Compiler.compiled_expression -> unit result = + fun c compiled_prg compiled_param -> + let%bind (Ex_ty expected_ty) = + let%bind (c_param_ty,c_storage_ty) = Self_michelson.fetch_contract_inputs compiled_prg.expr_ty in + match c with + | Check_parameter -> ok c_param_ty + | Check_storage -> ok c_storage_ty in + let (Ex_ty actual_ty) = compiled_param.expr_ty in + let%bind _ = + Trace.trace_tzresult (simple_error "Passed parameter does not match the contract type") @@ + Proto_alpha_utils.Memory_proto_alpha.assert_equal_michelson_type expected_ty actual_ty in + ok () \ No newline at end of file diff --git a/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml b/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml index 99887c721..460494379 100644 --- a/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml +++ b/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml @@ -1105,6 +1105,10 @@ let typecheck_contract contract = Script_ir_translator.typecheck_code dummy_environment.tezos_context contract' >>=?? fun _ -> return () +let assert_equal_michelson_type ty1 ty2 = + (* alpha_wrap (Script_ir_translator.ty_eq tezos_context a b) >>? fun (Eq, _) -> *) + alpha_wrap (Script_ir_translator.ty_eq dummy_environment.tezos_context ty1 ty2) + type 'a interpret_res = | Succeed of 'a stack | Fail of Script_repr.expr