diff --git a/devtools/get_contracts/get_contracts_alpha.ml b/devtools/get_contracts/get_contracts_alpha.ml index 9c04ef4be89d5517ef881090252c66659f9c0d10..2033d329029dbe2d0c71fb1abb93cb8bfe0f4fc9 100644 --- a/devtools/get_contracts/get_contracts_alpha.ml +++ b/devtools/get_contracts/get_contracts_alpha.ml @@ -135,7 +135,7 @@ module Proto = struct let+ data, updated_ctxt = Lwt.map wrap_tzresult @@ Script_ir_translator.parse_data - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:true ctxt) ctxt ~allow_forged ty @@ -187,7 +187,7 @@ module Proto = struct Lwt.map wrap_tzresult @@ Script_ir_translator.parse_code ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:true ctxt) ~code in parsed_code diff --git a/src/proto_alpha/lib_benchmark/test/test_helpers.ml b/src/proto_alpha/lib_benchmark/test/test_helpers.ml index 0f73aa711b068a374a149dd1406f98c5ccf5b4b5..bf0a8c36a89503ea164cc541c86941e03eb36e82 100644 --- a/src/proto_alpha/lib_benchmark/test/test_helpers.ml +++ b/src/proto_alpha/lib_benchmark/test/test_helpers.ml @@ -84,7 +84,7 @@ let typecheck_by_tezos = Protocol.Script_tc_context.data ctxt ~elab_conf: - (Protocol.Script_ir_translator_config.make ~legacy:false ()) + (Protocol.Script_ir_translator_config.make ~legacy:false ctxt) (Micheline.root node) bef >|= Environment.wrap_tzresult diff --git a/src/proto_alpha/lib_benchmarks_proto/cache_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/cache_benchmarks.ml index 57c9cd4a52cc00bfb7d1d1d274e313a2fb04a105..9ce67cb5878d9b5a71cd024f3361867abd10f22e 100644 --- a/src/proto_alpha/lib_benchmarks_proto/cache_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/cache_benchmarks.ml @@ -68,7 +68,8 @@ let dummy_script : Cache.cached_contract = let ex_script, _ = Script_ir_translator.parse_script throwaway_context - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) + ~elab_conf: + (Script_ir_translator_config.make ~legacy:true throwaway_context) ~allow_forged_in_storage:false script |> assert_ok_lwt diff --git a/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml index ed15db1546c96b226e1d64ccdabbcbd8e4e01de4..42a423883b397fbae815d08d7fa9ce17962b4e3b 100644 --- a/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml @@ -1105,7 +1105,7 @@ module Registration_section = struct Script_tc_context.data ctxt ~elab_conf: - (Script_ir_translator_config.make ~legacy:false ()) + (Script_ir_translator_config.make ~legacy:false ctxt) node stack_ty in diff --git a/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml index c8a63e2241603778186c44fcc82b60dc8dab3ec7..b8ad6f254f91664efc05216f5c52551ca0a07a12 100644 --- a/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml @@ -37,7 +37,7 @@ let fv s = Free_variable.of_namespace (ns s) let local_model_name = "script_typed_ir_size" -let strict = Script_ir_translator_config.make ~legacy:false () +let strict ctxt = Script_ir_translator_config.make ~legacy:false ctxt module Size_benchmarks_shared_config = struct include Translator_benchmarks.Config @@ -93,7 +93,7 @@ module Value_size_benchmark : Tezos_benchmark.Benchmark.S = struct Lwt_main.run (Script_ir_translator.parse_data ctxt - ~elab_conf:strict + ~elab_conf:(strict ctxt) ~allow_forged:false ty (Micheline.root node)) @@ -213,7 +213,7 @@ module Kinstr_size_benchmark : Tezos_benchmark.Benchmark.S = struct (Script_ir_translator.parse_instr Script_tc_context.data ctxt - ~elab_conf:strict + ~elab_conf:(strict ctxt) node bef) with diff --git a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml index 3244f5dd882eafa9ee9a8aced4a37d1d6c80e358..d15fb2a579d854beb7d7a1af7a23554a8847617b 100644 --- a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml @@ -192,7 +192,7 @@ let bad_code benchmark_name micheline expected_stack_type phase = (* ----------------------------------------------------------------------- *) (* Typechecking data (Micheline data -> typed data) *) -let strict = Script_ir_translator_config.make ~legacy:false () +let strict ctxt = Script_ir_translator_config.make ~legacy:false ctxt module Typechecking_data : Benchmark.S = struct include Config @@ -232,7 +232,7 @@ module Typechecking_data : Benchmark.S = struct Lwt_main.run (Script_ir_translator.parse_data ctxt - ~elab_conf:strict + ~elab_conf:(strict ctxt) ~allow_forged:false ty (Micheline.root node)) @@ -311,7 +311,7 @@ module Unparsing_data : Benchmark.S = struct let*! result = Script_ir_translator.parse_data ctxt - ~elab_conf:strict + ~elab_conf:(strict ctxt) ~allow_forged:false ty (Micheline.root node) @@ -404,7 +404,7 @@ module Typechecking_code : Benchmark.S = struct (Script_ir_translator.parse_instr Script_tc_context.data ctxt - ~elab_conf:strict + ~elab_conf:(strict ctxt) (Micheline.root node) bef) in @@ -488,7 +488,7 @@ module Unparsing_code : Benchmark.S = struct Script_ir_translator.parse_instr Script_tc_context.data ctxt - ~elab_conf:strict + ~elab_conf:(strict ctxt) (Micheline.root node) bef in diff --git a/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml b/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml index 09212c347c96d052d6f318f7ce8d941e145446e1..88b50e91adf1fa86c01fd9200777bfaac406fa64 100644 --- a/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml +++ b/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml @@ -117,7 +117,7 @@ let data_typechecker_workload ctxt t_kind micheline_node ex_ty = (let* res = Script_ir_translator.parse_data ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:false ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:false ctxt) ~allow_forged:false ty micheline_node @@ -161,7 +161,7 @@ let code_typechecker_workload (ctxt : Protocol.Alpha_context.context) Script_ir_translator.parse_instr Script_tc_context.data ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:false ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:false ctxt) code stack_ty |> Lwt.map Environment.wrap_tzresult diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 8cfbba3c464cae7331cb11d798cea0023b638150..20b9a1aea174a5e6b473157393a33cae857840fe 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -711,7 +711,7 @@ module Scripts = struct in Script_ir_translator.parse_data ctxt - ~elab_conf:(elab_conf ~legacy ()) + ~elab_conf:(elab_conf ~legacy ctxt) ~allow_forged exp_ty (Micheline.root data)) @@ -830,7 +830,7 @@ module Scripts = struct ty_node in let*? (Ex_ty ty) = res in - let elab_conf = elab_conf ~legacy () in + let elab_conf = elab_conf ~legacy ctxt in let* x, ctxt = Script_ir_translator.parse_data ctxt @@ -1621,7 +1621,7 @@ module Scripts = struct | None -> Gas.set_unlimited ctxt | Some gas -> Gas.set_limit ctxt gas in - let elab_conf = elab_conf ~legacy () in + let elab_conf = elab_conf ~legacy ctxt in let code = Script.lazy_expr expr in let* ( Ex_code (Code @@ -1684,7 +1684,7 @@ module Scripts = struct let* data, ctxt = parse_data ctxt - ~elab_conf:(elab_conf ~legacy:true ()) + ~elab_conf:(elab_conf ~legacy:true ctxt) ~allow_forged:true typ (Micheline.root expr) @@ -1705,7 +1705,7 @@ module Scripts = struct let* data, ctxt = parse_data ctxt - ~elab_conf:(elab_conf ~legacy ()) + ~elab_conf:(elab_conf ~legacy ctxt) ~allow_forged:true typ (Micheline.root expr) @@ -2054,7 +2054,7 @@ module Contract = struct let* Ex_script (Script {storage; storage_type; _}), ctxt = parse_script ctxt - ~elab_conf:(elab_conf ~legacy:true ()) + ~elab_conf:(elab_conf ~legacy:true ctxt) ~allow_forged_in_storage:true script in @@ -2123,7 +2123,7 @@ module Contract = struct let* Ex_script (Script {storage; storage_type; _}), ctxt = Script_ir_translator.parse_script ctxt - ~elab_conf:(elab_conf ~legacy:true ()) + ~elab_conf:(elab_conf ~legacy:true ctxt) ~allow_forged_in_storage:true script in @@ -2242,7 +2242,7 @@ module Big_map = struct let* value, ctxt = parse_data ctxt - ~elab_conf:(elab_conf ~legacy:true ()) + ~elab_conf:(elab_conf ~legacy:true ctxt) ~allow_forged:true value_type (Micheline.root value) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 189ef64c005abab0b1e0bd110552ccc3cb7051d5..7198bfff63ea2cd2f062ed92b5c1b9768610cd7c 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1059,7 +1059,7 @@ let apply_manager_operation : ctxt parameters in - let elab_conf = Script_ir_translator_config.make ~legacy:false () in + let elab_conf = Script_ir_translator_config.make ~legacy:false ctxt in let+ ctxt, res, ops = match Entrypoint.to_string entrypoint with | "default" -> @@ -1290,7 +1290,7 @@ let apply_manager_operation : let* Ex_script parsed_script, ctxt = Script_ir_translator.parse_script ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:false ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:false ctxt) ~allow_forged_in_storage:false script in @@ -1298,7 +1298,7 @@ let apply_manager_operation : let views_result = Script_ir_translator.parse_views ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:false ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:false ctxt) storage_type views in diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 115979be4778ece8c529ef00ef1ee3d46160c4f6..4ec4d9eece40162c965ab2bcf53f291fa9a7aa47 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -54,7 +54,7 @@ let info_encoding = (opt "script" Script.encoding) (opt "counter" Manager_counter.encoding_for_RPCs) -let legacy = Script_ir_translator_config.make ~legacy:true () +let legacy ctxt = Script_ir_translator_config.make ~legacy:true ctxt module S = struct open Data_encoding @@ -311,7 +311,7 @@ module S = struct let*! tzresult = Script_ir_translator.parse_script ctxt - ~elab_conf:legacy + ~elab_conf:(legacy ctxt) ~allow_forged_in_storage:true script in @@ -421,7 +421,7 @@ let register () = let* value, ctxt = parse_data ctxt - ~elab_conf:legacy + ~elab_conf:(legacy ctxt) ~allow_forged:true value_type (Micheline.root value) @@ -450,7 +450,7 @@ let register () = let* value, ctxt = parse_data ctxt - ~elab_conf:legacy + ~elab_conf:(legacy ctxt) ~allow_forged:true value_type (Micheline.root value) @@ -523,7 +523,7 @@ let register () = let* Ex_script (Script {storage; storage_type; _}), ctxt = parse_script ctxt - ~elab_conf:legacy + ~elab_conf:(legacy ctxt) ~allow_forged_in_storage:true script in @@ -659,7 +659,7 @@ let register () = let* Ex_script (Script script), ctxt = parse_script ctxt - ~elab_conf:legacy + ~elab_conf:(legacy ctxt) ~allow_forged_in_storage:true script in diff --git a/src/proto_alpha/lib_protocol/main.ml b/src/proto_alpha/lib_protocol/main.ml index e3595b2c2acd7975d42758d5a4785cb083ab0d25..780dc6075e9f1e45179e4cf9a501e4488d403b69 100644 --- a/src/proto_alpha/lib_protocol/main.ml +++ b/src/proto_alpha/lib_protocol/main.ml @@ -374,7 +374,7 @@ let init chain_id ctxt block_header = let* Ex_script (Script parsed_script), ctxt = Script_ir_translator.parse_script ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:true ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:true ctxt) ~allow_forged_in_storage script in diff --git a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml index a8082f48e8e0c78b997cf13763e89d8c109cf32b..7d1ab001044c7132ac1b9db7d7586a4a7e9492d3 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml @@ -76,7 +76,7 @@ let make_transaction ctxt ~parameters_ty ~unparsed_parameters ~destination let+ parameters, ctxt = Script_ir_translator.parse_data ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:false ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:false ctxt) ~allow_forged:true parameters_ty (Micheline.root unparsed_parameters) diff --git a/src/proto_alpha/lib_protocol/script_big_map.ml b/src/proto_alpha/lib_protocol/script_big_map.ml index b0fe7ca2ec4b12b4d110345488120ad239bfd021..5d1dd2b499c4af8bbef7fd5f0734c1635aa71b45 100644 --- a/src/proto_alpha/lib_protocol/script_big_map.ml +++ b/src/proto_alpha/lib_protocol/script_big_map.ml @@ -62,7 +62,7 @@ let get_by_hash ctxt key (Big_map {id; diff; value_type; _}) = let+ x, ctxt = parse_data ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:true ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:true ctxt) ~allow_forged:true value_type (Micheline.root value) diff --git a/src/proto_alpha/lib_protocol/script_cache.ml b/src/proto_alpha/lib_protocol/script_cache.ml index 472a49fbb685248de2be6696cb898f02a34b8c15..8d77e3109223b5c48656344630c01c35e80ab35d 100644 --- a/src/proto_alpha/lib_protocol/script_cache.ml +++ b/src/proto_alpha/lib_protocol/script_cache.ml @@ -48,7 +48,7 @@ let load_and_elaborate ctxt addr = parse_script ctxt script - ~elab_conf:Script_ir_translator_config.(make ~legacy:true ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:true ctxt) ~allow_forged_in_storage:true in (* We consume gas after the fact in order to not have to instrument diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index fee974aeb0c0cd8adcf7182d57dc9d574f301392..7904f66eeebef53ccbb025614a49fd7ad15be9af 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -562,7 +562,7 @@ module Raw = struct let gas, ctxt = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack in - let legacy = Script_ir_translator_config.make ~legacy:true () in + let legacy = Script_ir_translator_config.make ~legacy:true ctxt in match addr.destination with | Contract (Implicit _) | Sc_rollup _ | Zk_rollup _ -> (return_none [@ocaml.tailcall]) ctxt @@ -1769,7 +1769,7 @@ let lift_execution_arg (type a ac) ctxt ~internal (entrypoint_ty : (a, ac) ty) let arg = Micheline.root arg in parse_data ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:false ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:false ctxt) ~allow_forged:internal entrypoint_ty arg @@ -1805,7 +1805,7 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal Script_ir_translator_config.make ~legacy:true ~keep_extra_types_for_interpreter_logging:(Option.is_some logger) - () + ctxt in let* ( Ex_script (Script diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 0b176469fd6b6b5e956472fc98aa29474e192e9c..94c92585ac998bf57582f927c0c3cc897a2b7701 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -785,7 +785,7 @@ let unpack ctxt ~ty ~bytes = let*! value_opt = parse_data ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:false ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:false ctxt) ~allow_forged:false ty (Micheline.root expr) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 2fcb84fe85c07821d954e6b168777df154cef830..fbfcc745feae23ada0afa9efbae19a5b3a6d69a6 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -190,11 +190,10 @@ let check_dupable_comparable_ty : type a. a comparable_ty -> unit = function | Pair_t _ | Or_t _ | Option_t _ -> () -let check_dupable_ty ctxt loc ty = - let open Result_syntax in - let rec aux : type a ac. location -> (a, ac) ty -> (unit, error) Gas_monad.t = - fun loc ty -> - let open Gas_monad.Syntax in +let rec check_dupable_ty : + type a ac. location -> (a, ac) ty -> (unit, error trace) Gas_monad.t = + let open Gas_monad.Syntax in + fun loc ty -> let*$ () = Typecheck_costs.check_dupable_cycle in match ty with | Unit_t -> return_unit @@ -221,13 +220,13 @@ let check_dupable_ty ctxt loc ty = | Sapling_transaction_deprecated_t _ -> return_unit | Chest_t -> return_unit | Chest_key_t -> return_unit - | Ticket_t _ -> fail @@ Unexpected_ticket loc + | Ticket_t _ -> tzfail @@ Unexpected_ticket loc | Pair_t (ty_a, ty_b, _, _) -> - let* () = aux loc ty_a in - aux loc ty_b + let* () = check_dupable_ty loc ty_a in + check_dupable_ty loc ty_b | Or_t (ty_a, ty_b, _, _) -> - let* () = aux loc ty_a in - aux loc ty_b + let* () = check_dupable_ty loc ty_a in + check_dupable_ty loc ty_b | Lambda_t (_, _, _) -> (* Lambda are dupable as long as: @@ -238,21 +237,17 @@ let check_dupable_ty ctxt loc ty = Hence non-dupable should imply non-packable. *) return_unit - | Option_t (ty, _, _) -> aux loc ty - | List_t (ty, _) -> aux loc ty + | Option_t (ty, _, _) -> check_dupable_ty loc ty + | List_t (ty, _) -> check_dupable_ty loc ty | Set_t (key_ty, _) -> let () = check_dupable_comparable_ty key_ty in return_unit | Map_t (key_ty, val_ty, _) -> let () = check_dupable_comparable_ty key_ty in - aux loc val_ty + check_dupable_ty loc val_ty | Big_map_t (key_ty, val_ty, _) -> let () = check_dupable_comparable_ty key_ty in - aux loc val_ty - in - let gas = aux loc ty in - let* res, ctxt = Gas_monad.run ctxt gas in - match res with Ok () -> return ctxt | Error e -> tzfail e + check_dupable_ty loc val_ty let type_metadata_eq : type error_trace. @@ -451,23 +446,23 @@ let ty_eq : let rec stack_eq : type ta tb ts tu. Script.location -> - context -> int -> (ta, ts) stack_ty -> (tb, tu) stack_ty -> - (((ta, ts) stack_ty, (tb, tu) stack_ty) eq * context) tzresult = - let open Result_syntax in - fun loc ctxt lvl stack1 stack2 -> + (((ta, ts) stack_ty, (tb, tu) stack_ty) eq, error trace) Gas_monad.t = + let open Gas_monad.Syntax in + fun loc lvl stack1 stack2 -> match (stack1, stack2) with - | Bot_t, Bot_t -> return (Eq, ctxt) + | Bot_t, Bot_t -> return Eq | Item_t (ty1, rest1), Item_t (ty2, rest2) -> - let* eq, ctxt = - Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) ty1 ty2 - |> record_trace (Bad_stack_item lvl) + let* Eq = + let error_details = Informative loc in + ty_eq ~error_details ty1 ty2 + |> Gas_monad.record_trace_eval ~error_details (fun _loc -> + Bad_stack_item lvl) in - let* Eq = eq in - let+ Eq, ctxt = stack_eq loc ctxt (lvl + 1) rest1 rest2 in - ((Eq : ((ta, ts) stack_ty, (tb, tu) stack_ty) eq), ctxt) + let+ Eq = stack_eq loc (lvl + 1) rest1 rest2 in + (Eq : ((ta, ts) stack_ty, (tb, tu) stack_ty) eq) | _, _ -> tzfail Bad_stack_length (* ---- Type checker results -------------------------------------------------*) @@ -490,32 +485,32 @@ type ('a, 's, 'b, 'u, 'c, 'v) branch = { let merge_branches : type a s b u c v. - context -> Script.location -> (a, s) judgement -> (b, u) judgement -> (a, s, b, u, c, v) branch -> - ((c, v) judgement * context) tzresult = - let open Result_syntax in - fun ctxt loc btr bfr {branch} -> + ((c, v) judgement, error trace) Gas_monad.t = + let open Gas_monad.Syntax in + fun loc btr bfr {branch} -> match (btr, bfr) with | Typed ({aft = aftbt; _} as dbt), Typed ({aft = aftbf; _} as dbf) -> let unmatched_branches () = - let aftbt = serialize_stack_for_error ctxt aftbt in - let aftbf = serialize_stack_for_error ctxt aftbf in + let aftbt = serialize_stack_for_error aftbt in + let aftbf = serialize_stack_for_error aftbf in Unmatched_branches (loc, aftbt, aftbf) in - record_trace_eval + Gas_monad.record_trace_eval + ~error_details:(Informative ()) unmatched_branches - (let+ Eq, ctxt = stack_eq loc ctxt 1 aftbt aftbf in - (Typed (branch dbt dbf), ctxt)) + (let+ Eq = stack_eq loc 1 aftbt aftbf in + Typed (branch dbt dbf)) | Failed {descr = descrt}, Failed {descr = descrf} -> let descr ret = branch (descrt ret) (descrf ret) in - return (Failed {descr}, ctxt) + return (Failed {descr}) | Typed dbt, Failed {descr = descrf} -> - return (Typed (branch dbt (descrf dbt.aft)), ctxt) + return (Typed (branch dbt (descrf dbt.aft))) | Failed {descr = descrt}, Typed dbf -> - return (Typed (branch (descrt dbf.aft) dbf), ctxt) + return (Typed (branch (descrt dbf.aft) dbf)) let parse_memo_size (n : (location, _) Micheline.node) : Sapling.Memo_size.t tzresult = @@ -1148,7 +1143,6 @@ type (_, _, _) dug_proof_argument = type (_, _) dipn_proof_argument = | Dipn_proof_argument : ('fa, 'fs, 'fb, 'fu, 'a, 's, 'b, 'u) stack_prefix_preservation_witness - * context * ('fa, 'fs, 'fb, 'fu) descr * ('b, 'u) stack_ty -> ('a, 's) dipn_proof_argument @@ -1216,7 +1210,6 @@ let rec make_comb_get_proof_argument : let rec make_comb_set_proof_argument : type value valuec before beforec a s. - context -> (a, s) stack_ty -> location -> int -> @@ -1224,7 +1217,7 @@ let rec make_comb_set_proof_argument : (before, beforec) ty -> (value, before) comb_set_proof_argument tzresult = let open Result_syntax in - fun ctxt stack_ty loc n value_ty ty -> + fun stack_ty loc n value_ty ty -> match (n, ty) with | 0, _ -> return (Comb_set_proof_argument (Comb_set_zero, value_ty)) | 1, Pair_t (_hd_ty, tl_ty, _, _) -> @@ -1232,13 +1225,13 @@ let rec make_comb_set_proof_argument : Comb_set_proof_argument (Comb_set_one, after_ty) | n, Pair_t (hd_ty, tl_ty, _, _) -> let* (Comb_set_proof_argument (comb_set_left_witness, tl_ty')) = - make_comb_set_proof_argument ctxt stack_ty loc (n - 2) value_ty tl_ty + make_comb_set_proof_argument stack_ty loc (n - 2) value_ty tl_ty in let+ (Ty_ex_c after_ty) = pair_t loc hd_ty tl_ty' in Comb_set_proof_argument (Comb_set_plus_two comb_set_left_witness, after_ty) | _ -> - let whole_stack = serialize_stack_for_error ctxt stack_ty in + let whole_stack = serialize_stack_for_error stack_ty in tzfail (Bad_stack (loc, I_UPDATE, 2, whole_stack)) type 'a ex_ty_cstr = @@ -1920,8 +1913,9 @@ let comb_witness1 : type t tc. (t, tc) ty -> (t, unit -> unit) comb_witness = | Pair_t _ -> Comb_Pair Comb_Any | _ -> Comb_Any -let parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = - let open Result_syntax in +let parse_view_name : Script.node -> (Script_string.t, error trace) Gas_monad.t + = + let open Gas_monad.Syntax in function | String (loc, v) as expr -> (* The limitation of length of string is same as entrypoint *) @@ -1932,22 +1926,25 @@ let parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = else if Script_ir_annot.is_allowed_char v.[i] then check_char (i - 1) else tzfail (Bad_view_name loc) in - let* ctxt = Gas.consume ctxt (Typecheck_costs.check_printable v) in - record_trace - (Invalid_syntactic_constant - ( loc, - strip_locations expr, - "string [a-zA-Z0-9_.%@] and the maximum string length of 31 \ - characters" )) + let*$ () = Typecheck_costs.check_printable v in + Gas_monad.record_trace_eval + ~error_details:(Informative ()) + (fun () -> + Invalid_syntactic_constant + ( loc, + strip_locations expr, + "string [a-zA-Z0-9_.%@] and the maximum string length of 31 \ + characters" )) (let* v = check_char (String.length v - 1) in - let+ s = Script_string.of_string v in - (s, ctxt)) + let+? s = Script_string.of_string v in + s) | expr -> tzfail @@ Invalid_kind (location expr, [String_kind], kind expr) -let parse_toplevel : context -> Script.expr -> (toplevel * context) tzresult = - let open Result_syntax in - fun ctxt toplevel -> - record_trace (Ill_typed_contract (toplevel, [])) +let parse_toplevel : Script.expr -> (toplevel, error trace) Gas_monad.t = + let open Gas_monad.Syntax in + fun toplevel -> + Gas_monad.record_trace_eval ~error_details:(Informative ()) (fun () -> + Ill_typed_contract (toplevel, [])) @@ match root toplevel with | Int (loc, _) -> tzfail (Invalid_kind (loc, [Seq_kind], Int_kind)) @@ -1955,9 +1952,9 @@ let parse_toplevel : context -> Script.expr -> (toplevel * context) tzresult = | Bytes (loc, _) -> tzfail (Invalid_kind (loc, [Seq_kind], Bytes_kind)) | Prim (loc, _, _, _) -> tzfail (Invalid_kind (loc, [Seq_kind], Prim_kind)) | Seq (_, fields) -> ( - let rec find_fields ctxt p s c views fields = + let rec find_fields p s c views fields = match fields with - | [] -> return (ctxt, (p, s, c, views)) + | [] -> return (p, s, c, views) | Int (loc, _) :: _ -> tzfail (Invalid_kind (loc, [Prim_kind], Int_kind)) | String (loc, _) :: _ -> @@ -1968,26 +1965,24 @@ let parse_toplevel : context -> Script.expr -> (toplevel * context) tzresult = tzfail (Invalid_kind (loc, [Prim_kind], Seq_kind)) | Prim (loc, K_parameter, [arg], annot) :: rest -> ( match p with - | None -> find_fields ctxt (Some (arg, loc, annot)) s c views rest + | None -> find_fields (Some (arg, loc, annot)) s c views rest | Some _ -> tzfail (Duplicate_field (loc, K_parameter))) | Prim (loc, K_storage, [arg], annot) :: rest -> ( match s with - | None -> find_fields ctxt p (Some (arg, loc, annot)) c views rest + | None -> find_fields p (Some (arg, loc, annot)) c views rest | Some _ -> tzfail (Duplicate_field (loc, K_storage))) | Prim (loc, K_code, [arg], annot) :: rest -> ( match c with - | None -> find_fields ctxt p s (Some (arg, loc, annot)) views rest + | None -> find_fields p s (Some (arg, loc, annot)) views rest | Some _ -> tzfail (Duplicate_field (loc, K_code))) | Prim (loc, ((K_parameter | K_storage | K_code) as name), args, _) :: _ -> tzfail (Invalid_arity (loc, name, 1, List.length args)) | Prim (loc, K_view, [name; input_ty; output_ty; view_code], _) :: rest -> - let* str, ctxt = parse_view_name ctxt name in - let* ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.view_update str views) + let* str = parse_view_name name in + let*$ () = + Michelson_v1_gas.Cost_of.Interpreter.view_update str views in if Script_map.mem str views then tzfail (Duplicated_view_name loc) else @@ -1997,15 +1992,15 @@ let parse_toplevel : context -> Script.expr -> (toplevel * context) tzresult = (Some {input_ty; output_ty; view_code}) views in - find_fields ctxt p s c views' rest + find_fields p s c views' rest | Prim (loc, K_view, args, _) :: _ -> tzfail (Invalid_arity (loc, K_view, 4, List.length args)) | Prim (loc, name, _, _) :: _ -> let allowed = [K_parameter; K_storage; K_code; K_view] in tzfail (Invalid_primitive (loc, allowed, name)) in - let* ctxt, toplevel = - find_fields ctxt None None None (Script_map.empty string_t) fields + let* toplevel = + find_fields None None None (Script_map.empty string_t) fields in match toplevel with | None, _, _, _ -> tzfail (Missing_field K_parameter) @@ -2015,10 +2010,10 @@ let parse_toplevel : context -> Script.expr -> (toplevel * context) tzresult = Some (s, sloc, sannot), Some (c, cloc, cannot), views ) -> - let* () = Script_ir_annot.error_unexpected_annot ploc pannot in - let* () = Script_ir_annot.error_unexpected_annot cloc cannot in - let+ () = Script_ir_annot.error_unexpected_annot sloc sannot in - ({code_field = c; arg_type = p; views; storage_type = s}, ctxt)) + let*? () = Script_ir_annot.error_unexpected_annot ploc pannot in + let*? () = Script_ir_annot.error_unexpected_annot cloc cannot in + let+? () = Script_ir_annot.error_unexpected_annot sloc sannot in + {code_field = c; arg_type = p; views; storage_type = s}) (* Normalize lambdas during parsing *) @@ -2237,8 +2232,8 @@ let rec parse_data : | Address_t, expr -> traced_from_gas_monad ctxt @@ parse_address - ~sc_rollup_enable:(Constants.sc_rollup_enable ctxt) - ~zk_rollup_enable:(Constants.zk_rollup_enable ctxt) + ~sc_rollup_enable:elab_conf.sc_rollup_enable + ~zk_rollup_enable:elab_conf.zk_rollup_enable expr | Contract_t (arg_ty, _), expr -> traced @@ -2551,9 +2546,9 @@ and parse_view : ctxt ) | Typed ({loc; aft; _} as descr) -> ( let ill_type_view stack_ty loc = - let actual = serialize_stack_for_error ctxt stack_ty in + let actual = serialize_stack_for_error stack_ty in let expected_stack = Item_t (output_ty, Bot_t) in - let expected = serialize_stack_for_error ctxt expected_stack in + let expected = serialize_stack_for_error expected_stack in Ill_typed_view {loc; actual; expected} in let open Result_syntax in @@ -2631,7 +2626,7 @@ and parse_kdescr : Gas_monad.run ctxt @@ Gas_monad.record_trace_eval ~error_details (fun loc -> let ret = serialize_ty_for_error ret in - let stack_ty = serialize_stack_for_error ctxt stack_ty in + let stack_ty = serialize_stack_for_error stack_ty in Bad_return (loc, stack_ty, ret)) @@ ty_eq ~error_details ty ret in @@ -2639,9 +2634,9 @@ and parse_kdescr : return ( (close_descr descr : (arg, end_of_stack, ret, end_of_stack) kdescr), ctxt ) - | Typed {loc; aft = stack_ty; _}, ctxt -> + | Typed {loc; aft = stack_ty; _}, _ctxt -> let ret = serialize_ty_for_error ret in - let stack_ty = serialize_stack_for_error ctxt stack_ty in + let stack_ty = serialize_stack_for_error stack_ty in tzfail @@ Bad_return (loc, stack_ty, ret) | Failed {descr}, ctxt -> return @@ -2690,7 +2685,7 @@ and parse_lam_rec : Gas_monad.run ctxt @@ Gas_monad.record_trace_eval ~error_details (fun loc -> let ret = serialize_ty_for_error ret in - let stack_ty = serialize_stack_for_error ctxt stack_ty in + let stack_ty = serialize_stack_for_error stack_ty in Bad_return (loc, stack_ty, ret)) @@ ty_eq ~error_details ty ret in @@ -2710,9 +2705,9 @@ and parse_lam_rec : ctxt closed_descr script_instr - | Typed {loc; aft = stack_ty; _}, ctxt -> + | Typed {loc; aft = stack_ty; _}, _ctxt -> let ret = serialize_ty_for_error ret in - let stack_ty = serialize_stack_for_error ctxt stack_ty in + let stack_ty = serialize_stack_for_error stack_ty in tzfail @@ Bad_return (loc, stack_ty, ret) | Failed {descr}, ctxt -> (normalized_lam_rec [@ocaml.tailcall]) @@ -2747,7 +2742,7 @@ and parse_instr : loc name n m : ((a, b) eq * context) tzresult = let open Result_syntax in record_trace_eval (fun () -> - let stack_ty = serialize_stack_for_error ctxt stack_ty in + let stack_ty = serialize_stack_for_error stack_ty in Bad_stack (loc, name, m, stack_ty)) @@ record_trace (Bad_stack_item n) @@ -2789,8 +2784,8 @@ and parse_instr : script_instr stack_ty in - let bad_stack_error ctxt loc prim relevant_stack_portion = - let whole_stack = serialize_stack_for_error ctxt stack_ty in + let bad_stack_error loc prim relevant_stack_portion = + let whole_stack = serialize_stack_for_error stack_ty in Result_syntax.tzfail (Bad_stack (loc, prim, relevant_stack_portion, whole_stack)) in @@ -2817,7 +2812,7 @@ and parse_instr : in Dropn_proof_argument (KPrefix (loc, a, n'), stack_after_drops) | _, _ -> - let whole_stack = serialize_stack_for_error ctxt whole_stack in + let whole_stack = serialize_stack_for_error whole_stack in tzfail (Bad_stack (loc, I_DROP, whole_n, whole_stack)) in let*? () = error_unexpected_annot loc result_annot in @@ -2832,12 +2827,13 @@ and parse_instr : tzfail (Invalid_arity (loc, I_DROP, 1, List.length l)) | Prim (loc, I_DUP, [], annot), (Item_t (v, _) as stack) -> let*? () = check_var_annot loc annot in - let*? ctxt = + let*? res, ctxt = Gas_monad.run ctxt @@ check_dupable_ty loc v in + let*? () = record_trace_eval (fun () -> let t = serialize_ty_for_error v in Non_dupable_type (loc, t)) - (check_dupable_ty ctxt loc v) + res in let dup = {apply = (fun k -> IDup (loc, k))} in typed ctxt loc dup (Item_t (v, stack)) @@ -2857,7 +2853,7 @@ and parse_instr : make_proof_argument (n - 1) tl_ty in Dup_n_proof_argument (Dup_n_succ dup_n_witness, b_ty) - | _ -> bad_stack_error ctxt loc I_DUP 1 + | _ -> bad_stack_error loc I_DUP 1 in let*? n = parse_uint10 n in let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in @@ -2867,12 +2863,13 @@ and parse_instr : let*? (Dup_n_proof_argument (witness, after_ty)) = record_trace (Dup_n_bad_stack loc) (make_proof_argument n stack_ty) in - let*? ctxt = + let*? res, ctxt = Gas_monad.run ctxt (check_dupable_ty loc after_ty) in + let*? () = record_trace_eval (fun () -> let t = serialize_ty_for_error after_ty in Non_dupable_type (loc, t)) - (check_dupable_ty ctxt loc after_ty) + res in let dupn = {apply = (fun k -> IDup_n (loc, n, witness, k))} in typed ctxt loc dupn (Item_t (after_ty, stack_ty)) @@ -2891,7 +2888,7 @@ and parse_instr : in Dig_proof_argument (KPrefix (loc, v, n'), x, Item_t (v, aft')) | _, _ -> - let whole_stack = serialize_stack_for_error ctxt stack in + let whole_stack = serialize_stack_for_error stack in tzfail (Bad_stack (loc, I_DIG, 3, whole_stack)) in let*? n = parse_uint10 n in @@ -2908,14 +2905,14 @@ and parse_instr : let*? () = error_unexpected_annot loc result_annot in match make_dug_proof_argument loc whole_n x whole_stack with | None -> - let whole_stack = serialize_stack_for_error ctxt whole_stack in + let whole_stack = serialize_stack_for_error whole_stack in tzfail (Bad_stack (loc, I_DUG, whole_n, whole_stack)) | Some (Dug_proof_argument (n', aft)) -> let dug = {apply = (fun k -> IDug (loc, whole_n, n', k))} in typed ctxt loc dug aft) | Prim (loc, I_DUG, [_], result_annot), stack -> let*? () = error_unexpected_annot loc result_annot in - let stack = serialize_stack_for_error ctxt stack in + let stack = serialize_stack_for_error stack in tzfail (Bad_stack (loc, I_DUG, 1, stack)) | Prim (loc, I_DUG, (([] | _ :: _ :: _) as l), _), _ -> tzfail (Invalid_arity (loc, I_DUG, 1, List.length l)) @@ -2976,19 +2973,22 @@ and parse_instr : match judgement with | Typed ({loc; aft = Item_t (ret, aft_rest); _} as kibody) -> let invalid_map_body () = - let aft = serialize_stack_for_error ctxt kibody.aft in + let aft = serialize_stack_for_error kibody.aft in Invalid_map_body (loc, aft) in record_trace_eval invalid_map_body - (let* Eq, ctxt = stack_eq loc ctxt 1 aft_rest rest in + (let* eq, ctxt = + Gas_monad.run ctxt @@ stack_eq loc 1 aft_rest rest + in + let* Eq = eq in let* opt_ty = option_t loc ret in let final_stack = Item_t (opt_ty, rest) in let body = kibody.instr.apply (IHalt loc) in let apply k = IOpt_map {loc; body; k} in typed_no_lwt ctxt loc {apply} final_stack) | Typed {aft = Bot_t; _} -> - let aft = serialize_stack_for_error ctxt Bot_t in + let aft = serialize_stack_for_error Bot_t in tzfail (Invalid_map_body (loc, aft)) | Failed _ -> tzfail (Invalid_map_block_fail loc)) | ( Prim (loc, I_IF_NONE, [bt; bf], annot), @@ -3012,7 +3012,11 @@ and parse_instr : in {loc; instr = ifnone; bef; aft = ibt.aft} in - Lwt.return @@ merge_branches ctxt loc btr bfr {branch} + let*? res, ctxt = + Gas_monad.run ctxt @@ merge_branches loc btr bfr {branch} + in + let*? res in + return (res, ctxt) (* pairs *) | Prim (loc, I_PAIR, [], annot), Item_t (a, Item_t (b, rest)) -> let*? () = check_constr_annot loc annot in @@ -3036,7 +3040,7 @@ and parse_instr : let+ (Ty_ex_c pair_t) = pair_t loc a_ty b_ty in Comb_proof_argument (Comb_succ comb_witness, Item_t (pair_t, tl_ty')) - | _ -> bad_stack_error ctxt loc I_PAIR 1 + | _ -> bad_stack_error loc I_PAIR 1 in let*? n = parse_uint10 n in let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in @@ -3063,7 +3067,7 @@ and parse_instr : in Uncomb_proof_argument (Uncomb_succ uncomb_witness, Item_t (a_ty, after_ty)) - | _ -> bad_stack_error ctxt loc I_UNPAIR 1 + | _ -> bad_stack_error loc I_UNPAIR 1 in let*? n = parse_uint10 n in let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in @@ -3081,7 +3085,7 @@ and parse_instr : let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in match make_comb_get_proof_argument n comb_ty with | None -> - let whole_stack = serialize_stack_for_error ctxt stack_ty in + let whole_stack = serialize_stack_for_error stack_ty in tzfail (Bad_stack (loc, I_GET, 1, whole_stack)) | Some (Comb_get_proof_argument (witness, ty')) -> let after_stack_ty = Item_t (ty', rest_ty) in @@ -3093,7 +3097,7 @@ and parse_instr : let*? n = parse_uint11 n in let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in let*? (Comb_set_proof_argument (witness, after_ty)) = - make_comb_set_proof_argument ctxt stack_ty loc n value_ty comb_ty + make_comb_set_proof_argument stack_ty loc n value_ty comb_ty in let after_stack_ty = Item_t (after_ty, rest_ty) in let comb_set = {apply = (fun k -> IComb_set (loc, n, witness, k))} in @@ -3157,7 +3161,11 @@ and parse_instr : in {loc; instr; bef; aft = ibt.aft} in - Lwt.return @@ merge_branches ctxt loc btr bfr {branch} + let*? res, ctxt = + Gas_monad.run ctxt @@ merge_branches loc btr bfr {branch} + in + let*? res in + return (res, ctxt) (* lists *) | Prim (loc, I_NIL, [t], annot), stack -> let*? t, ctxt = @@ -3198,7 +3206,11 @@ and parse_instr : in {loc; instr; bef; aft = ibt.aft} in - Lwt.return @@ merge_branches ctxt loc btr bfr {branch} + let*? res, ctxt = + Gas_monad.run ctxt @@ merge_branches loc btr bfr {branch} + in + let*? res in + return (res, ctxt) | Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest) -> let*? () = check_var_type_annot loc annot in let list_size = {apply = (fun k -> IList_size (loc, k))} in @@ -3220,12 +3232,15 @@ and parse_instr : match judgement with | Typed ({aft = Item_t (ret, rest) as aft; _} as kibody) -> let invalid_map_body () = - let aft = serialize_stack_for_error ctxt aft in + let aft = serialize_stack_for_error aft in Invalid_map_body (loc, aft) in record_trace_eval invalid_map_body - (let* Eq, ctxt = stack_eq loc ctxt 1 rest starting_rest in + (let* eq, ctxt = + Gas_monad.run ctxt @@ stack_eq loc 1 rest starting_rest + in + let* Eq = eq in let hloc = loc in let ibody = kibody.instr.apply (IHalt hloc) in let* ty = list_t loc ret in @@ -3238,7 +3253,7 @@ and parse_instr : let stack = Item_t (ty, rest) in typed_no_lwt ctxt loc list_map stack) | Typed {aft; _} -> - let aft = serialize_stack_for_error ctxt aft in + let aft = serialize_stack_for_error aft in tzfail (Invalid_map_body (loc, aft)) | Failed _ -> tzfail (Invalid_map_block_fail loc)) | Prim (loc, I_ITER, [body], annot), Item_t (List_t (elt, _), rest) -> ( @@ -3262,13 +3277,14 @@ and parse_instr : match judgement with | Typed ({aft; _} as ibody) -> let invalid_iter_body () = - let aft = serialize_stack_for_error ctxt ibody.aft in - let rest = serialize_stack_for_error ctxt rest in + let aft = serialize_stack_for_error ibody.aft in + let rest = serialize_stack_for_error rest in Invalid_iter_body (loc, rest, aft) in record_trace_eval invalid_iter_body - (let* Eq, ctxt = stack_eq loc ctxt 1 aft rest in + (let* eq, ctxt = Gas_monad.run ctxt @@ stack_eq loc 1 aft rest in + let* Eq = eq in typed_no_lwt ctxt loc (mk_list_iter ibody) rest) | Failed {descr} -> typed_no_lwt ctxt loc (mk_list_iter (descr rest)) rest ) @@ -3304,13 +3320,14 @@ and parse_instr : match judgement with | Typed ({aft; _} as ibody) -> let invalid_iter_body () = - let aft = serialize_stack_for_error ctxt ibody.aft in - let rest = serialize_stack_for_error ctxt rest in + let aft = serialize_stack_for_error ibody.aft in + let rest = serialize_stack_for_error rest in Invalid_iter_body (loc, rest, aft) in record_trace_eval invalid_iter_body - (let* Eq, ctxt = stack_eq loc ctxt 1 aft rest in + (let* eq, ctxt = Gas_monad.run ctxt @@ stack_eq loc 1 aft rest in + let* Eq = eq in typed_no_lwt ctxt loc (mk_iset_iter ibody) rest) | Failed {descr} -> typed_no_lwt ctxt loc (mk_iset_iter (descr rest)) rest ) @@ -3361,12 +3378,15 @@ and parse_instr : match judgement with | Typed ({aft = Item_t (ret, rest) as aft; _} as ibody) -> let invalid_map_body () = - let aft = serialize_stack_for_error ctxt aft in + let aft = serialize_stack_for_error aft in Invalid_map_body (loc, aft) in record_trace_eval invalid_map_body - (let* Eq, ctxt = stack_eq loc ctxt 1 rest starting_rest in + (let* eq, ctxt = + Gas_monad.run ctxt @@ stack_eq loc 1 rest starting_rest + in + let* Eq = eq in let* ty = map_t loc kt ret in let instr = { @@ -3380,7 +3400,7 @@ and parse_instr : let stack = Item_t (ty, rest) in typed_no_lwt ctxt loc instr stack) | Typed {aft; _} -> - let aft = serialize_stack_for_error ctxt aft in + let aft = serialize_stack_for_error aft in tzfail (Invalid_map_body (loc, aft)) | Failed _ -> tzfail (Invalid_map_block_fail loc)) | Prim (loc, I_ITER, [body], annot), Item_t (Map_t (key, element_ty, _), rest) @@ -3406,13 +3426,14 @@ and parse_instr : match judgement with | Typed ({aft; _} as ibody) -> let invalid_iter_body () = - let aft = serialize_stack_for_error ctxt ibody.aft in - let rest = serialize_stack_for_error ctxt rest in + let aft = serialize_stack_for_error ibody.aft in + let rest = serialize_stack_for_error rest in Invalid_iter_body (loc, rest, aft) in record_trace_eval invalid_iter_body - (let* Eq, ctxt = stack_eq loc ctxt 1 aft rest in + (let* eq, ctxt = Gas_monad.run ctxt @@ stack_eq loc 1 aft rest in + let* Eq = eq in typed_no_lwt ctxt loc (make_instr ibody) rest) | Failed {descr} -> typed_no_lwt ctxt loc (make_instr (descr rest)) rest) | Prim (loc, I_MEM, [], annot), Item_t (vk, Item_t (Map_t (k, _, _), rest)) -> @@ -3598,7 +3619,11 @@ and parse_instr : in {loc; instr; bef; aft = ibt.aft} in - Lwt.return @@ merge_branches ctxt loc btr bfr {branch} + let*? res, ctxt = + Gas_monad.run ctxt @@ merge_branches loc btr bfr {branch} + in + let*? res in + return (res, ctxt) | Prim (loc, I_LOOP, [body], annot), (Item_t (Bool_t, rest) as stack) -> ( let*? () = check_kind [Seq_kind] body in let*? () = error_unexpected_annot loc annot in @@ -3609,13 +3634,16 @@ and parse_instr : match judgement with | Typed ibody -> let unmatched_branches () = - let aft = serialize_stack_for_error ctxt ibody.aft in - let stack = serialize_stack_for_error ctxt stack in + let aft = serialize_stack_for_error ibody.aft in + let stack = serialize_stack_for_error stack in Unmatched_branches (loc, aft, stack) in record_trace_eval unmatched_branches - (let* Eq, ctxt = stack_eq loc ctxt 1 ibody.aft stack in + (let* eq, ctxt = + Gas_monad.run ctxt @@ stack_eq loc 1 ibody.aft stack + in + let* Eq = eq in let instr = { apply = @@ -3651,13 +3679,16 @@ and parse_instr : match judgement with | Typed ibody -> let unmatched_branches () = - let aft = serialize_stack_for_error ctxt ibody.aft in - let stack = serialize_stack_for_error ctxt stack in + let aft = serialize_stack_for_error ibody.aft in + let stack = serialize_stack_for_error stack in Unmatched_branches (loc, aft, stack) in record_trace_eval unmatched_branches - (let* Eq, ctxt = stack_eq loc ctxt 1 ibody.aft stack in + (let* eq, ctxt = + Gas_monad.run ctxt @@ stack_eq loc 1 ibody.aft stack + in + let* Eq = eq in let instr = { apply = @@ -3793,8 +3824,11 @@ and parse_instr : let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in let rec make_proof_argument : type a s. - int -> (a, s) stack_ty -> (a, s) dipn_proof_argument tzresult Lwt.t = - fun n stk -> + int -> + (a, s) stack_ty -> + context -> + ((a, s) dipn_proof_argument * context) tzresult Lwt.t = + fun n stk ctxt -> match (Compare.Int.(n = 0), stk) with | true, rest -> ( let* judgement, ctxt = @@ -3803,22 +3837,23 @@ and parse_instr : match judgement with | Typed descr -> return - (Dipn_proof_argument (KRest, ctxt, descr, descr.aft) - : (a, s) dipn_proof_argument) + ( (Dipn_proof_argument (KRest, descr, descr.aft) + : (a, s) dipn_proof_argument), + ctxt ) | Failed _ -> tzfail (Fail_not_in_tail_position loc)) | false, Item_t (v, rest) -> - let+ (Dipn_proof_argument (n', ctxt, descr, aft')) = - make_proof_argument (n - 1) rest + let+ Dipn_proof_argument (n', descr, aft'), ctxt = + make_proof_argument (n - 1) rest ctxt in let w = KPrefix (loc, v, n') in - Dipn_proof_argument (w, ctxt, descr, Item_t (v, aft')) + (Dipn_proof_argument (w, descr, Item_t (v, aft')), ctxt) | _, _ -> - let whole_stack = serialize_stack_for_error ctxt stack in + let whole_stack = serialize_stack_for_error stack in tzfail (Bad_stack (loc, I_DIP, 1, whole_stack)) in let*? () = error_unexpected_annot loc result_annot in - let* (Dipn_proof_argument (n', ctxt, descr, aft)) = - make_proof_argument n stack + let* Dipn_proof_argument (n', descr, aft), ctxt = + make_proof_argument n stack ctxt in let b = descr.instr.apply (IHalt descr.loc) in let res = {apply = (fun k -> IDipn (loc, n, n', b, k))} in @@ -4262,7 +4297,8 @@ and parse_instr : | ( Prim (loc, I_VIEW, [name; output_ty], annot), Item_t (input_ty, Item_t (Address_t, rest)) ) -> let output_ty_loc = location output_ty in - let*? name, ctxt = parse_view_name ctxt name in + let*? name, ctxt = Gas_monad.run ctxt @@ parse_view_name name in + let*? name in let*? output_ty, ctxt = Gas_monad.run ctxt @@ parse_view_output_ty ~stack_depth:0 ~legacy output_ty @@ -4315,13 +4351,13 @@ and parse_instr : contracts but then we throw away the typed version, except for the storage type which is kept for efficiency in the ticket scanner. *) let canonical_code = Micheline.strip_locations code in - let*? {arg_type; storage_type; code_field; views}, ctxt = - parse_toplevel ctxt canonical_code - in let*? res, ctxt = Gas_monad.run ctxt @@ let open Gas_monad.Syntax in + let* {arg_type; storage_type; code_field; views} = + parse_toplevel canonical_code + in let error_details = Informative () in let* arg_type = Gas_monad.record_trace_eval ~error_details (fun () -> @@ -4341,10 +4377,12 @@ and parse_instr : ~legacy storage_type in - (arg_type, storage_type) + (arg_type, storage_type, code_field, views) in let*? ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, - Ex_ty storage_type ) = + Ex_ty storage_type, + code_field, + views ) = res in let*? (Ty_ex_c arg_type_full) = pair_t loc arg_type storage_type in @@ -4747,13 +4785,13 @@ and parse_instr : let t = serialize_ty_for_error t in tzfail (Undefined_unop (loc, name, t)) | Prim (loc, ((I_UPDATE | I_SLICE | I_OPEN_CHEST) as name), [], _), stack -> - let stack = serialize_stack_for_error ctxt stack in + let stack = serialize_stack_for_error stack in tzfail (Bad_stack (loc, name, 3, stack)) | Prim (loc, I_CREATE_CONTRACT, _, _), stack -> - let stack = serialize_stack_for_error ctxt stack in + let stack = serialize_stack_for_error stack in tzfail (Bad_stack (loc, I_CREATE_CONTRACT, 7, stack)) | Prim (loc, I_TRANSFER_TOKENS, [], _), stack -> - let stack = serialize_stack_for_error ctxt stack in + let stack = serialize_stack_for_error stack in tzfail (Bad_stack (loc, I_TRANSFER_TOKENS, 4, stack)) | ( Prim ( loc, @@ -4768,7 +4806,7 @@ and parse_instr : _, _ ), stack ) -> - let stack = serialize_stack_for_error ctxt stack in + let stack = serialize_stack_for_error stack in tzfail (Bad_stack (loc, name, 1, stack)) | ( Prim ( loc, @@ -4779,7 +4817,7 @@ and parse_instr : _, _ ), stack ) -> - let stack = serialize_stack_for_error ctxt stack in + let stack = serialize_stack_for_error stack in tzfail (Bad_stack (loc, name, 2, stack)) (* Generic parsing errors *) | expr, _ -> @@ -4981,14 +5019,15 @@ and parse_contract : ctxt code in - (* can only fail because of gas *) - let*? {arg_type; _}, ctxt = parse_toplevel ctxt code in let*? targ, ctxt = Gas_monad.run ctxt - @@ parse_parameter_ty_and_entrypoints - ~stack_depth:(stack_depth + 1) - ~legacy:true - arg_type + @@ + let open Gas_monad.Syntax in + let* {arg_type; _} = parse_toplevel code in + parse_parameter_ty_and_entrypoints + ~stack_depth:(stack_depth + 1) + ~legacy:true + arg_type in let*? (Ex_parameter_ty_and_entrypoints {arg_type = targ; entrypoints}) = @@ -5128,15 +5167,13 @@ let parse_code : in let legacy = elab_conf.legacy in let* ctxt, code = Global_constants_storage.expand ctxt code in - let*? {arg_type; storage_type; code_field; views}, ctxt = - parse_toplevel ctxt code - in - let arg_type_loc = location arg_type in - let storage_type_loc = location storage_type in let*? res, ctxt = Gas_monad.run ctxt @@ let open Gas_monad.Syntax in + let* {arg_type; storage_type; code_field; views} = parse_toplevel code in + let arg_type_loc = location arg_type in + let storage_type_loc = location storage_type in let* arg_type = Gas_monad.record_trace_eval ~error_details:(Informative ()) (fun () -> Ill_formed_type (Some "parameter", code, arg_type_loc)) @@ -5147,10 +5184,13 @@ let parse_code : Ill_formed_type (Some "storage", code, storage_type_loc)) @@ parse_storage_ty ~stack_depth:0 ~legacy storage_type in - (arg_type, storage_type) + (arg_type, storage_type, code_field, views, storage_type_loc) in let*? ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, - Ex_ty storage_type ) = + Ex_ty storage_type, + code_field, + views, + storage_type_loc ) = res in let*? (Ty_ex_c arg_type_full) = @@ -5267,15 +5307,15 @@ let typecheck_code : fun ~unparse_code_rec ~legacy ~show_types ctxt code -> (* Constants need to be expanded or [parse_toplevel] may fail. *) let* ctxt, code = Global_constants_storage.expand ctxt code in - let*? toplevel, ctxt = parse_toplevel ctxt code in - let {arg_type; storage_type; code_field; views} = toplevel in let type_map = ref [] in - let arg_type_loc = location arg_type in - let storage_type_loc = location storage_type in let*? res, ctxt = Gas_monad.run ctxt @@ let open Gas_monad.Syntax in + let* toplevel = parse_toplevel code in + let {arg_type; storage_type; code_field; views} = toplevel in + let arg_type_loc = location arg_type in + let storage_type_loc = location storage_type in let* arg_type = Gas_monad.record_trace_eval ~error_details:(Informative ()) (fun () -> Ill_formed_type (Some "parameter", code, arg_type_loc)) @@ -5286,10 +5326,14 @@ let typecheck_code : Ill_formed_type (Some "storage", code, storage_type_loc)) @@ parse_storage_ty ~stack_depth:0 ~legacy storage_type in - (arg_type, ex_storage_type) + (arg_type, ex_storage_type, toplevel, code_field, views, storage_type_loc) in let*? ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, - Ex_ty storage_type ) = + Ex_ty storage_type, + toplevel, + code_field, + views, + storage_type_loc ) = res in let*? (Ty_ex_c arg_type_full) = @@ -5302,7 +5346,9 @@ let typecheck_code : type_map := (loc, (stack_ty_before, stack_ty_after)) :: !type_map in let type_logger = if show_types then Some type_logger else None in - let elab_conf = Script_ir_translator_config.make ~legacy ?type_logger () in + let elab_conf = + Script_ir_translator_config.make ~legacy ?type_logger ctxt + in let result = parse_kdescr ~unparse_code_rec @@ -5425,7 +5471,7 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage let* storage, ctxt = parse_storage ~unparse_code_rec - ~elab_conf:(Script_ir_translator_config.make ~legacy ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy ctxt) ctxt ~allow_forged:allow_forged_in_storage storage_type @@ -5963,7 +6009,8 @@ let parse_script ~elab_conf ctxt ~allow_forged_in_storage script = let parse_comparable_data ?type_logger ctxt ty t = parse_data - ~elab_conf:Script_ir_translator_config.(make ~legacy:false ?type_logger ()) + ~elab_conf: + Script_ir_translator_config.(make ~legacy:false ?type_logger ctxt) ~allow_forged:false ctxt ty @@ -6003,7 +6050,9 @@ let parse_contract_data context loc arg_ty contract ~entrypoint = let parse_toplevel ctxt toplevel = let open Lwt_result_syntax in let* ctxt, toplevel = Global_constants_storage.expand ctxt toplevel in - Lwt.return @@ parse_toplevel ctxt toplevel + let*? toplevel, ctxt = Gas_monad.run ctxt @@ parse_toplevel toplevel in + let*? toplevel in + return (toplevel, ctxt) let parse_comparable_ty = parse_comparable_ty ~stack_depth:0 diff --git a/src/proto_alpha/lib_protocol/script_ir_translator_config.ml b/src/proto_alpha/lib_protocol/script_ir_translator_config.ml index a8c535735b08b9e09b840dcaf1bf8b50c45d0fd5..84e6ec366d50d06a6c9cb221cb7ca733ca762125 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator_config.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator_config.ml @@ -73,9 +73,11 @@ type elab_config = { result in a crash. This cannot be helped at the moment, but since logging is never enabled during validation, we should be safe. *) legacy : bool; (** If set to true, it enables the legacy mode (see above). *) + sc_rollup_enable : bool; + zk_rollup_enable : bool; } -(** [make ?type_logger ?logging_enabled ~legacy ()] creates an [elab_config] +(** [make ?type_logger ?logging_enabled ~legacy ctxt] creates an [elab_config] record to be passed to parsing functions in [Script_ir_translator]. Note: [?logging_enabled] defaults to [false], because it only ever should @@ -85,7 +87,16 @@ let make : ?type_logger:type_logger -> ?keep_extra_types_for_interpreter_logging:bool -> legacy:bool -> - unit -> + context -> elab_config = - fun ?type_logger ?(keep_extra_types_for_interpreter_logging = false) ~legacy () -> - {type_logger; keep_extra_types_for_interpreter_logging; legacy} + fun ?type_logger + ?(keep_extra_types_for_interpreter_logging = false) + ~legacy + ctxt -> + { + type_logger; + keep_extra_types_for_interpreter_logging; + legacy; + sc_rollup_enable = Constants.sc_rollup_enable ctxt; + zk_rollup_enable = Constants.zk_rollup_enable ctxt; + } diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml index 1e0105efd4c72300026979ce239b880e49378af2..4acddaaca87e4bce9469ae64e1506a2bcb0891c5 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.ml +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -182,10 +182,7 @@ let rec unparse_stack_uncarbonated : let urest = unparse_stack_uncarbonated rest in strip_locations uty :: urest -let serialize_stack_for_error ctxt stack_ty = - match Gas.level ctxt with - | Unaccounted -> unparse_stack_uncarbonated stack_ty - | Limited _ -> [] +let serialize_stack_for_error stack_ty = unparse_stack_uncarbonated stack_ty let unparse_unit ~loc () = Gas_monad.return (Prim (loc, D_Unit, [], [])) @@ -777,7 +774,7 @@ module Data_unparser (P : MICHELSON_PARSER) = struct and unparse_code_rec ctxt ~stack_depth mode code = let open Lwt_result_syntax in - let elab_conf = Script_ir_translator_config.make ~legacy:true () in + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in let*? ctxt = Gas.consume ctxt Unparse_costs.unparse_instr_cycle in let non_terminal_recursion ctxt mode code = if Compare.Int.(stack_depth > 10_000) then diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.mli b/src/proto_alpha/lib_protocol/script_ir_unparser.mli index 965d95e8403dc0a1399c1f3479240d44bcc1aff0..f63e77685520b2373fe1a5b6a670900828091501 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.mli +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.mli @@ -46,10 +46,9 @@ type ('ty, 'depth) comb_witness = when this function is called, the operation must have already failed. *) val serialize_ty_for_error : ('a, 'b) ty -> Script.expr -(** [serialize_stack_for_error ctxt stack_ty] returns a Micheline representation of - [stack_ty] as a list of Micheline expressions ONLY IF gas is unlimited - in [ctxt]. Otherwise returns an empty list. *) -val serialize_stack_for_error : context -> ('a, 'b) stack_ty -> Script.expr list +(** [serialize_stack_for_error stack_ty] returns a Micheline representation of + [stack_ty] as a list of Micheline expressions. *) +val serialize_stack_for_error : ('a, 'b) stack_ty -> Script.expr list (** [unparse_ty ~loc ty] returns the Micheline representation of a given type. *) diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.ml b/src/proto_alpha/lib_protocol/test/helpers/block.ml index 7f3b6208f5416a83361e6333e13d780b76a1cdf1..3815597222410c849fc83be6d52db45672b1ef1a 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/block.ml @@ -447,7 +447,7 @@ let initial_alpha_context ?(commitments = []) constants let* Ex_script (Script parsed_script), ctxt = Script_ir_translator.parse_script ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:true ctxt) ~allow_forged_in_storage script in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_annotations.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_annotations.ml index fa18ed71408e9450b92313fd520cd5d1fa330616..3beb36c954a7ac32b48d9016d628b502d06624e5 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_annotations.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_annotations.ml @@ -86,7 +86,7 @@ let get_address_from_storage inc factory_addr = let*! res = Script_ir_translator.parse_data ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:false ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:false ctxt) ~allow_forged:false option_address_t (Micheline.root factory_storage) diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_lambda_normalization.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_lambda_normalization.ml index 7c4f246a968673d2d66aec8852185ff2044483d6..21b892f04a43b2d4a4b3457393f46705ac7ec8b2 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_lambda_normalization.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_lambda_normalization.ml @@ -44,7 +44,7 @@ let new_ctxt () = let parse_and_project (ty : ((_, _) lambda, _) ty) (node : Script.node) = let open Lwt_result_wrap_syntax in let* ctxt = new_ctxt () in - let elab_conf = Script_ir_translator_config.make ~legacy:false () in + let elab_conf = Script_ir_translator_config.make ~legacy:false ctxt in let*@ lam, _ctxt = Script_ir_translator.parse_data ~elab_conf ctxt ~allow_forged:false ty node in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_patched_contracts.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_patched_contracts.ml index 1e186dfc08357589e9e6dc7a896653ecba356375..4eb787ccd235f97a38b99386dd892b455e980d28 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_patched_contracts.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_patched_contracts.ml @@ -172,7 +172,7 @@ module Legacy_patch_test (Patches : LEGACY_SCRIPT_PATCHES) : let* _code, _ctxt = Lwt.map Environment.wrap_tzresult @@ Script_ir_translator.parse_code - ~elab_conf:Script_ir_translator_config.(make ~legacy:false ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:false ctxt) ~code:(Script_repr.lazy_expr code) ctxt in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml index cbc00cf513196def660afb606028d9820b561de5..bd21ffba4dae9c8c91812f52ad75f68ba9f0b781 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml @@ -1049,7 +1049,8 @@ module Interpreter_tests = struct let*@ Ex_script (Script script), ctxt = Script_ir_translator.parse_script ctx_without_gas_2 - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) + ~elab_conf: + (Script_ir_translator_config.make ~legacy:true ctx_without_gas_2) ~allow_forged_in_storage:true script in @@ -1193,7 +1194,8 @@ module Interpreter_tests = struct let*@ (state_1, state_2), _ctx = Script_ir_translator.parse_storage ctx_without_gas - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) + ~elab_conf: + (Script_ir_translator_config.make ~legacy:true ctx_without_gas) ~allow_forged:true tytype ~storage:storage_lazy_expr diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml index 3d4c29b44b3fd948583d7345bb032177bcafc917..4e3a020c40e1bbbe0442db27ce3d8008d023644e 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml @@ -356,7 +356,7 @@ let origination_operation ctxt ~sender ~script:(code, storage) ~orig_contract = ctxt ) = Script_ir_translator.parse_script ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:true ctxt) ~allow_forged_in_storage:true script in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_manager.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_manager.ml index 0270f2d08349ee58829efc17bcd5793ecc09d191..862a472288636635952d87901bccb10641f5a2b3 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_manager.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_manager.ml @@ -93,7 +93,7 @@ let ticket_balance_of_storage ctxt (contract : Alpha_context.Contract.t) = ctxt ) = Script_ir_translator.parse_script ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:true ctxt) ~allow_forged_in_storage:true script in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml index ae967de5eb54f5627924df1e6e14462b5b616c8f..5a59c1b4822adb4005ded9b01762aa52ab65bdd2 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml @@ -279,7 +279,7 @@ let origination_operation block ~sender ~baker ~script ~storage ~forges_tickets ctxt ) = Script_ir_translator.parse_script ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:true ctxt) ~allow_forged_in_storage:true script in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml index cc4c193a2094aa1b7b713ee2339e53c4d82f14dd..45f86bf97f1044ff98eda782554ef199e65fb52a 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml @@ -137,7 +137,7 @@ let tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp = let*@ value, ctxt = Script_ir_translator.parse_data ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:false ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:false ctxt) ~allow_forged:true ty node diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml index 5faf2ce4e7b3e41aa1ed9313f5114881f5d57e94..f6b7e74a32052b7690fe54d55b28be4763186e12 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml @@ -414,7 +414,7 @@ let test_unparse_comb_comparable_type () = let test_parse_data ?(equal = Stdlib.( = )) loc ctxt ty node expected = let open Lwt_result_wrap_syntax in - let elab_conf = Script_ir_translator_config.make ~legacy:false () in + let elab_conf = Script_ir_translator_config.make ~legacy:false ctxt in let allow_forged = true in let*@ actual, ctxt = Script_ir_translator.parse_data ctxt ~elab_conf ~allow_forged ty node @@ -424,7 +424,7 @@ let test_parse_data ?(equal = Stdlib.( = )) loc ctxt ty node expected = let test_parse_data_fails loc ctxt ty node = let open Lwt_result_wrap_syntax in - let elab_conf = Script_ir_translator_config.make ~legacy:false () in + let elab_conf = Script_ir_translator_config.make ~legacy:false ctxt in let allow_forged = false in let*! result = Script_ir_translator.parse_data ctxt ~elab_conf ~allow_forged ty node @@ -808,11 +808,11 @@ let gas_monad_run ctxt m = *) let test_contract_not_packable () = let open Lwt_result_syntax in - let elab_conf = Script_ir_translator_config.make ~legacy:false () in let contract_unit = Prim (0, Script.T_contract, [Prim (0, T_unit, [], [])], []) in let* ctxt = test_context () in + let elab_conf = Script_ir_translator_config.make ~legacy:false ctxt in (* Test that [contract_unit] is parsable *) let* () = match diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml index 2251ff68f74f69ccfc11dfca77d3b177132ccaa6..0bbb73d6ceee4b8d19b67b16c1accacd6abf9f96 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml @@ -361,7 +361,7 @@ let verify_params ctxt ~parameters_ty ~parameters ~unparsed_parameters = let* parsed_unparsed_parameters, ctxt = Script_ir_translator.parse_data ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:true ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:true ctxt) ~allow_forged:true parameters_ty (Environment.Micheline.root unparsed_parameters) diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml index bacc7280a7a4789fedabbba923cd788d0d66823e..de30d7d4d4733d4500b098e9d18a0bcfda9eb445 100644 --- a/src/proto_alpha/lib_protocol/ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml @@ -496,7 +496,7 @@ module Ticket_collection = struct let+ v, ctxt = Script_ir_translator.parse_data ~elab_conf: - Script_ir_translator_config.(make ~legacy:true ()) + Script_ir_translator_config.(make ~legacy:true ctxt) ctxt ~allow_forged:true value_type @@ -546,7 +546,7 @@ let tickets_of_node ctxt ~include_lazy has_tickets expr = let* value, ctxt = Script_ir_translator.parse_data ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:true ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:true ctxt) ~allow_forged:true ty expr