From 2f7b6a9a988cb5f1c117cd9838a4deee8ac59894 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 11 Jan 2021 14:11:55 +0100 Subject: [PATCH 01/23] Proto/Michelson: remove type annot from type metadata --- .../lib_protocol/michelson_v1_gas.ml | 8 +- .../lib_protocol/script_interpreter.ml | 8 +- .../lib_protocol/script_ir_translator.ml | 606 ++++++++---------- .../lib_protocol/script_typed_ir.ml | 227 +++---- .../lib_protocol/script_typed_ir.mli | 131 ++-- .../lib_protocol/script_typed_ir_size.ml | 2 +- .../lib_protocol/ticket_balance_key.ml | 5 +- 7 files changed, 419 insertions(+), 568 deletions(-) diff --git a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml index 04032bfaa655..dec735d47a3b 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml @@ -1427,9 +1427,7 @@ module Cost_of = struct let view_mem (elt : Script_string.t) (m : Script_typed_ir.view Script_typed_ir.SMap.t) = let open S_syntax in - let per_elt_cost = - compare (Script_typed_ir.string_key ~annot:None) elt elt - in + let per_elt_cost = compare Script_typed_ir.string_key elt elt in let size = S.safe_int (Script_typed_ir.SMap.cardinal m) in let intercept = atomic_step_cost (S.safe_int 80) in Gas.(intercept +@ (log2 size *@ per_elt_cost)) @@ -1439,9 +1437,7 @@ module Cost_of = struct let view_update (elt : Script_string.t) (m : Script_typed_ir.view Script_typed_ir.SMap.t) = let open S_syntax in - let per_elt_cost = - compare (Script_typed_ir.string_key ~annot:None) elt elt - in + let per_elt_cost = compare Script_typed_ir.string_key elt elt in let size = S.safe_int (Script_typed_ir.SMap.cardinal m) in let intercept = atomic_step_cost (S.safe_int 80) in Gas.(intercept +@ (S.safe_int 2 * log2 size *@ per_elt_cost)) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 9846ee56642a..f15f7165c446 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1015,7 +1015,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack | IImplicit_account (_, k) -> let key = accu in - let arg_ty = unit_t ~annot:None in + let arg_ty = unit_t in let contract = Contract.implicit_contract key in let address = {contract; entrypoint = Entrypoint.default} in let res = {arg_ty; address} in @@ -1071,11 +1071,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = kinstr; }, _script_view ) -> ( - pair_t - kloc - (input_ty, None) - (storage_type, None) - ~annot:None + pair_t kloc (input_ty, None) (storage_type, None) >>?= fun pair_ty -> let open Gas_monad in let io_ty = diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index c0ba5ea23ca0..08a055a7490c 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -186,25 +186,21 @@ let add_field_annot a = function let rec unparse_comparable_ty_uncarbonated : type a loc. loc:loc -> a comparable_ty -> loc Script.michelson_node = fun ~loc -> function - | Unit_key meta -> Prim (loc, T_unit, [], unparse_type_annot meta.annot) - | Never_key meta -> Prim (loc, T_never, [], unparse_type_annot meta.annot) - | Int_key meta -> Prim (loc, T_int, [], unparse_type_annot meta.annot) - | Nat_key meta -> Prim (loc, T_nat, [], unparse_type_annot meta.annot) - | Signature_key meta -> - Prim (loc, T_signature, [], unparse_type_annot meta.annot) - | String_key meta -> Prim (loc, T_string, [], unparse_type_annot meta.annot) - | Bytes_key meta -> Prim (loc, T_bytes, [], unparse_type_annot meta.annot) - | Mutez_key meta -> Prim (loc, T_mutez, [], unparse_type_annot meta.annot) - | Bool_key meta -> Prim (loc, T_bool, [], unparse_type_annot meta.annot) - | Key_hash_key meta -> - Prim (loc, T_key_hash, [], unparse_type_annot meta.annot) - | Key_key meta -> Prim (loc, T_key, [], unparse_type_annot meta.annot) - | Timestamp_key meta -> - Prim (loc, T_timestamp, [], unparse_type_annot meta.annot) - | Address_key meta -> Prim (loc, T_address, [], unparse_type_annot meta.annot) - | Chain_id_key meta -> - Prim (loc, T_chain_id, [], unparse_type_annot meta.annot) - | Pair_key ((l, al), (r, ar), meta) -> ( + | Unit_key _meta -> Prim (loc, T_unit, [], unparse_type_annot None) + | Never_key _meta -> Prim (loc, T_never, [], unparse_type_annot None) + | Int_key _meta -> Prim (loc, T_int, [], unparse_type_annot None) + | Nat_key _meta -> Prim (loc, T_nat, [], unparse_type_annot None) + | Signature_key _meta -> Prim (loc, T_signature, [], unparse_type_annot None) + | String_key _meta -> Prim (loc, T_string, [], unparse_type_annot None) + | Bytes_key _meta -> Prim (loc, T_bytes, [], unparse_type_annot None) + | Mutez_key _meta -> Prim (loc, T_mutez, [], unparse_type_annot None) + | Bool_key _meta -> Prim (loc, T_bool, [], unparse_type_annot None) + | Key_hash_key _meta -> Prim (loc, T_key_hash, [], unparse_type_annot None) + | Key_key _meta -> Prim (loc, T_key, [], unparse_type_annot None) + | Timestamp_key _meta -> Prim (loc, T_timestamp, [], unparse_type_annot None) + | Address_key _meta -> Prim (loc, T_address, [], unparse_type_annot None) + | Chain_id_key _meta -> Prim (loc, T_chain_id, [], unparse_type_annot None) + | Pair_key ((l, al), (r, ar), _meta) -> ( let tl = add_field_annot al (unparse_comparable_ty_uncarbonated ~loc l) in let tr = add_field_annot ar (unparse_comparable_ty_uncarbonated ~loc r) in (* Fold [pair a1 (pair ... (pair an-1 an))] into [pair a1 ... an] *) @@ -212,18 +208,18 @@ let rec unparse_comparable_ty_uncarbonated : field annotation because this annotation would be lost *) match tr with | Prim (_, T_pair, ts, []) -> - Prim (loc, T_pair, tl :: ts, unparse_type_annot meta.annot) - | _ -> Prim (loc, T_pair, [tl; tr], unparse_type_annot meta.annot)) - | Union_key ((l, al), (r, ar), meta) -> + Prim (loc, T_pair, tl :: ts, unparse_type_annot None) + | _ -> Prim (loc, T_pair, [tl; tr], unparse_type_annot None)) + | Union_key ((l, al), (r, ar), _meta) -> let tl = add_field_annot al (unparse_comparable_ty_uncarbonated ~loc l) in let tr = add_field_annot ar (unparse_comparable_ty_uncarbonated ~loc r) in - Prim (loc, T_or, [tl; tr], unparse_type_annot meta.annot) - | Option_key (t, meta) -> + Prim (loc, T_or, [tl; tr], unparse_type_annot None) + | Option_key (t, _meta) -> Prim ( loc, T_option, [unparse_comparable_ty_uncarbonated ~loc t], - unparse_type_annot meta.annot ) + unparse_type_annot None ) let unparse_memo_size ~loc memo_size = let z = Sapling.Memo_size.unparse_to_z memo_size in @@ -234,32 +230,29 @@ let rec unparse_ty_uncarbonated : fun ~loc ty -> let prim (name, args, annot) = Prim (loc, name, args, annot) in match ty with - | Unit_t meta -> prim (T_unit, [], unparse_type_annot meta.annot) - | Int_t meta -> prim (T_int, [], unparse_type_annot meta.annot) - | Nat_t meta -> prim (T_nat, [], unparse_type_annot meta.annot) - | Signature_t meta -> prim (T_signature, [], unparse_type_annot meta.annot) - | String_t meta -> prim (T_string, [], unparse_type_annot meta.annot) - | Bytes_t meta -> prim (T_bytes, [], unparse_type_annot meta.annot) - | Mutez_t meta -> prim (T_mutez, [], unparse_type_annot meta.annot) - | Bool_t meta -> prim (T_bool, [], unparse_type_annot meta.annot) - | Key_hash_t meta -> prim (T_key_hash, [], unparse_type_annot meta.annot) - | Key_t meta -> prim (T_key, [], unparse_type_annot meta.annot) - | Timestamp_t meta -> prim (T_timestamp, [], unparse_type_annot meta.annot) - | Address_t meta -> prim (T_address, [], unparse_type_annot meta.annot) - | Operation_t meta -> prim (T_operation, [], unparse_type_annot meta.annot) - | Chain_id_t meta -> prim (T_chain_id, [], unparse_type_annot meta.annot) - | Never_t meta -> prim (T_never, [], unparse_type_annot meta.annot) - | Bls12_381_g1_t meta -> - prim (T_bls12_381_g1, [], unparse_type_annot meta.annot) - | Bls12_381_g2_t meta -> - prim (T_bls12_381_g2, [], unparse_type_annot meta.annot) - | Bls12_381_fr_t meta -> - prim (T_bls12_381_fr, [], unparse_type_annot meta.annot) - | Contract_t (ut, meta) -> + | Unit_t _meta -> prim (T_unit, [], unparse_type_annot None) + | Int_t _meta -> prim (T_int, [], unparse_type_annot None) + | Nat_t _meta -> prim (T_nat, [], unparse_type_annot None) + | Signature_t _meta -> prim (T_signature, [], unparse_type_annot None) + | String_t _meta -> prim (T_string, [], unparse_type_annot None) + | Bytes_t _meta -> prim (T_bytes, [], unparse_type_annot None) + | Mutez_t _meta -> prim (T_mutez, [], unparse_type_annot None) + | Bool_t _meta -> prim (T_bool, [], unparse_type_annot None) + | Key_hash_t _meta -> prim (T_key_hash, [], unparse_type_annot None) + | Key_t _meta -> prim (T_key, [], unparse_type_annot None) + | Timestamp_t _meta -> prim (T_timestamp, [], unparse_type_annot None) + | Address_t _meta -> prim (T_address, [], unparse_type_annot None) + | Operation_t _meta -> prim (T_operation, [], unparse_type_annot None) + | Chain_id_t _meta -> prim (T_chain_id, [], unparse_type_annot None) + | Never_t _meta -> prim (T_never, [], unparse_type_annot None) + | Bls12_381_g1_t _meta -> prim (T_bls12_381_g1, [], unparse_type_annot None) + | Bls12_381_g2_t _meta -> prim (T_bls12_381_g2, [], unparse_type_annot None) + | Bls12_381_fr_t _meta -> prim (T_bls12_381_fr, [], unparse_type_annot None) + | Contract_t (ut, _meta) -> let t = unparse_ty_uncarbonated ~loc ut in - prim (T_contract, [t], unparse_type_annot meta.annot) - | Pair_t ((utl, l_field), (utr, r_field), meta) -> - let annot = unparse_type_annot meta.annot in + prim (T_contract, [t], unparse_type_annot None) + | Pair_t ((utl, l_field), (utr, r_field), _meta) -> + let annot = unparse_type_annot None in let utl = unparse_ty_uncarbonated ~loc utl in let tl = add_field_annot l_field utl in let utr = unparse_ty_uncarbonated ~loc utr in @@ -271,50 +264,50 @@ let rec unparse_ty_uncarbonated : (match tr with | Prim (_, T_pair, ts, []) -> (T_pair, tl :: ts, annot) | _ -> (T_pair, [tl; tr], annot)) - | Union_t ((utl, l_field), (utr, r_field), meta) -> - let annot = unparse_type_annot meta.annot in + | Union_t ((utl, l_field), (utr, r_field), _meta) -> + let annot = unparse_type_annot None in let utl = unparse_ty_uncarbonated ~loc utl in let tl = add_field_annot l_field utl in let utr = unparse_ty_uncarbonated ~loc utr in let tr = add_field_annot r_field utr in prim (T_or, [tl; tr], annot) - | Lambda_t (uta, utr, meta) -> + | Lambda_t (uta, utr, _meta) -> let ta = unparse_ty_uncarbonated ~loc uta in let tr = unparse_ty_uncarbonated ~loc utr in - prim (T_lambda, [ta; tr], unparse_type_annot meta.annot) - | Option_t (ut, meta) -> - let annot = unparse_type_annot meta.annot in + prim (T_lambda, [ta; tr], unparse_type_annot None) + | Option_t (ut, _meta) -> + let annot = unparse_type_annot None in let ut = unparse_ty_uncarbonated ~loc ut in prim (T_option, [ut], annot) - | List_t (ut, meta) -> + | List_t (ut, _meta) -> let t = unparse_ty_uncarbonated ~loc ut in - prim (T_list, [t], unparse_type_annot meta.annot) - | Ticket_t (ut, meta) -> + prim (T_list, [t], unparse_type_annot None) + | Ticket_t (ut, _meta) -> let t = unparse_comparable_ty_uncarbonated ~loc ut in - prim (T_ticket, [t], unparse_type_annot meta.annot) - | Set_t (ut, meta) -> + prim (T_ticket, [t], unparse_type_annot None) + | Set_t (ut, _meta) -> let t = unparse_comparable_ty_uncarbonated ~loc ut in - prim (T_set, [t], unparse_type_annot meta.annot) - | Map_t (uta, utr, meta) -> + prim (T_set, [t], unparse_type_annot None) + | Map_t (uta, utr, _meta) -> let ta = unparse_comparable_ty_uncarbonated ~loc uta in let tr = unparse_ty_uncarbonated ~loc utr in - prim (T_map, [ta; tr], unparse_type_annot meta.annot) - | Big_map_t (uta, utr, meta) -> + prim (T_map, [ta; tr], unparse_type_annot None) + | Big_map_t (uta, utr, _meta) -> let ta = unparse_comparable_ty_uncarbonated ~loc uta in let tr = unparse_ty_uncarbonated ~loc utr in - prim (T_big_map, [ta; tr], unparse_type_annot meta.annot) - | Sapling_transaction_t (memo_size, meta) -> + prim (T_big_map, [ta; tr], unparse_type_annot None) + | Sapling_transaction_t (memo_size, _meta) -> prim ( T_sapling_transaction, [unparse_memo_size ~loc memo_size], - unparse_type_annot meta.annot ) - | Sapling_state_t (memo_size, meta) -> + unparse_type_annot None ) + | Sapling_state_t (memo_size, _meta) -> prim ( T_sapling_state, [unparse_memo_size ~loc memo_size], - unparse_type_annot meta.annot ) - | Chest_key_t meta -> prim (T_chest_key, [], unparse_type_annot meta.annot) - | Chest_t meta -> prim (T_chest, [], unparse_type_annot meta.annot) + unparse_type_annot None ) + | Chest_key_t _meta -> prim (T_chest_key, [], unparse_type_annot None) + | Chest_t _meta -> prim (T_chest, [], unparse_type_annot None) let unparse_ty ~loc ctxt ty = Gas.consume ctxt (Unparse_costs.unparse_type ty) >|? fun ctxt -> @@ -730,13 +723,9 @@ let merge_type_metadata : 'a ty_metadata -> 'b ty_metadata -> ('a ty_metadata, error_trace) result = - fun ~legacy - ~error_details - {size = size_a; annot = annot_a} - {size = size_b; annot = annot_b} -> + fun ~legacy ~error_details {size = size_a} {size = size_b} -> Type_size.merge ~error_details size_a size_b >>? fun size -> - merge_type_annot ~legacy ~error_details annot_a annot_b >|? fun annot -> - {annot; size} + merge_type_annot ~legacy ~error_details None None >|? fun _annot -> {size} let default_merge_type_error ty1 ty2 = let ty1 = serialize_ty_for_error ty1 in @@ -1172,47 +1161,47 @@ let[@coq_struct "ty"] rec parse_comparable_ty : else match ty with | Prim (loc, T_unit, [], annot) -> - parse_type_annot loc annot >|? fun annot -> - (Ex_comparable_ty (unit_key ~annot), ctxt) + parse_type_annot loc annot >|? fun _annot -> + (Ex_comparable_ty unit_key, ctxt) | Prim (loc, T_never, [], annot) -> - parse_type_annot loc annot >|? fun annot -> - (Ex_comparable_ty (never_key ~annot), ctxt) + parse_type_annot loc annot >|? fun _annot -> + (Ex_comparable_ty never_key, ctxt) | Prim (loc, T_int, [], annot) -> - parse_type_annot loc annot >|? fun annot -> - (Ex_comparable_ty (int_key ~annot), ctxt) + parse_type_annot loc annot >|? fun _annot -> + (Ex_comparable_ty int_key, ctxt) | Prim (loc, T_nat, [], annot) -> - parse_type_annot loc annot >|? fun annot -> - (Ex_comparable_ty (nat_key ~annot), ctxt) + parse_type_annot loc annot >|? fun _annot -> + (Ex_comparable_ty nat_key, ctxt) | Prim (loc, T_signature, [], annot) -> - parse_type_annot loc annot >|? fun annot -> - (Ex_comparable_ty (signature_key ~annot), ctxt) + parse_type_annot loc annot >|? fun _annot -> + (Ex_comparable_ty signature_key, ctxt) | Prim (loc, T_string, [], annot) -> - parse_type_annot loc annot >|? fun annot -> - (Ex_comparable_ty (string_key ~annot), ctxt) + parse_type_annot loc annot >|? fun _annot -> + (Ex_comparable_ty string_key, ctxt) | Prim (loc, T_bytes, [], annot) -> - parse_type_annot loc annot >|? fun annot -> - (Ex_comparable_ty (bytes_key ~annot), ctxt) + parse_type_annot loc annot >|? fun _annot -> + (Ex_comparable_ty bytes_key, ctxt) | Prim (loc, T_mutez, [], annot) -> - parse_type_annot loc annot >|? fun annot -> - (Ex_comparable_ty (mutez_key ~annot), ctxt) + parse_type_annot loc annot >|? fun _annot -> + (Ex_comparable_ty mutez_key, ctxt) | Prim (loc, T_bool, [], annot) -> - parse_type_annot loc annot >|? fun annot -> - (Ex_comparable_ty (bool_key ~annot), ctxt) + parse_type_annot loc annot >|? fun _annot -> + (Ex_comparable_ty bool_key, ctxt) | Prim (loc, T_key_hash, [], annot) -> - parse_type_annot loc annot >|? fun annot -> - (Ex_comparable_ty (key_hash_key ~annot), ctxt) + parse_type_annot loc annot >|? fun _annot -> + (Ex_comparable_ty key_hash_key, ctxt) | Prim (loc, T_key, [], annot) -> - parse_type_annot loc annot >|? fun annot -> - (Ex_comparable_ty (key_key ~annot), ctxt) + parse_type_annot loc annot >|? fun _annot -> + (Ex_comparable_ty key_key, ctxt) | Prim (loc, T_timestamp, [], annot) -> - parse_type_annot loc annot >|? fun annot -> - (Ex_comparable_ty (timestamp_key ~annot), ctxt) + parse_type_annot loc annot >|? fun _annot -> + (Ex_comparable_ty timestamp_key, ctxt) | Prim (loc, T_chain_id, [], annot) -> - parse_type_annot loc annot >|? fun annot -> - (Ex_comparable_ty (chain_id_key ~annot), ctxt) + parse_type_annot loc annot >|? fun _annot -> + (Ex_comparable_ty chain_id_key, ctxt) | Prim (loc, T_address, [], annot) -> - parse_type_annot loc annot >|? fun annot -> - (Ex_comparable_ty (address_key ~annot), ctxt) + parse_type_annot loc annot >|? fun _annot -> + (Ex_comparable_ty address_key, ctxt) | Prim ( loc, (( T_unit | T_never | T_int | T_nat | T_string | T_bytes | T_mutez @@ -1222,7 +1211,7 @@ let[@coq_struct "ty"] rec parse_comparable_ty : _ ) -> error (Invalid_arity (loc, prim, 0, List.length l)) | Prim (loc, T_pair, left :: right, annot) -> - parse_type_annot loc annot >>? fun annot -> + parse_type_annot loc annot >>? fun _annot -> extract_field_annot left >>? fun (left, left_annot) -> (match right with | [right] -> extract_field_annot right @@ -1234,25 +1223,25 @@ let[@coq_struct "ty"] rec parse_comparable_ty : >>? fun (Ex_comparable_ty right, ctxt) -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt left >>? fun (Ex_comparable_ty left, ctxt) -> - pair_key loc (left, left_annot) (right, right_annot) ~annot - >|? fun ty -> (Ex_comparable_ty ty, ctxt) + pair_key loc (left, left_annot) (right, right_annot) >|? fun ty -> + (Ex_comparable_ty ty, ctxt) | Prim (loc, T_or, [left; right], annot) -> - parse_type_annot loc annot >>? fun annot -> + parse_type_annot loc annot >>? fun _annot -> extract_field_annot left >>? fun (left, left_annot) -> extract_field_annot right >>? fun (right, right_annot) -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt right >>? fun (Ex_comparable_ty right, ctxt) -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt left >>? fun (Ex_comparable_ty left, ctxt) -> - union_key loc (left, left_annot) (right, right_annot) ~annot - >|? fun ty -> (Ex_comparable_ty ty, ctxt) + union_key loc (left, left_annot) (right, right_annot) >|? fun ty -> + (Ex_comparable_ty ty, ctxt) | Prim (loc, ((T_pair | T_or) as prim), l, _) -> error (Invalid_arity (loc, prim, 2, List.length l)) | Prim (loc, T_option, [t], annot) -> - parse_type_annot loc annot >>? fun annot -> + parse_type_annot loc annot >>? fun _annot -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t >>? fun (Ex_comparable_ty t, ctxt) -> - option_key loc t ~annot >|? fun ty -> (Ex_comparable_ty ty, ctxt) + option_key loc t >|? fun ty -> (Ex_comparable_ty ty, ctxt) | Prim (loc, T_option, l, _) -> error (Invalid_arity (loc, T_option, 1, List.length l)) | Prim @@ -1416,73 +1405,57 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : else match node with | Prim (loc, T_unit, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (unit_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty unit_t, ctxt) | Prim (loc, T_int, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (int_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty int_t, ctxt) | Prim (loc, T_nat, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (nat_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty nat_t, ctxt) | Prim (loc, T_string, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (string_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty string_t, ctxt) | Prim (loc, T_bytes, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (bytes_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty bytes_t, ctxt) | Prim (loc, T_mutez, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (mutez_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty mutez_t, ctxt) | Prim (loc, T_bool, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (bool_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty bool_t, ctxt) | Prim (loc, T_key, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (key_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty key_t, ctxt) | Prim (loc, T_key_hash, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (key_hash_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty key_hash_t, ctxt) | Prim (loc, T_chest_key, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (chest_key_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty chest_key_t, ctxt) | Prim (loc, T_chest, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (chest_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty chest_t, ctxt) | Prim (loc, T_timestamp, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (timestamp_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty timestamp_t, ctxt) | Prim (loc, T_address, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (address_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty address_t, ctxt) | Prim (loc, T_signature, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (signature_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty signature_t, ctxt) | Prim (loc, T_operation, [], annot) -> if allow_operation then - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (operation_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> + ok (Ex_ty operation_t, ctxt) else error (Unexpected_operation loc) | Prim (loc, T_chain_id, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (chain_id_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty chain_id_t, ctxt) | Prim (loc, T_never, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (never_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty never_t, ctxt) | Prim (loc, T_bls12_381_g1, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (bls12_381_g1_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> + ok (Ex_ty bls12_381_g1_t, ctxt) | Prim (loc, T_bls12_381_g2, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (bls12_381_g2_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> + ok (Ex_ty bls12_381_g2_t, ctxt) | Prim (loc, T_bls12_381_fr, [], annot) -> - parse_type_annot loc annot >>? fun annot -> - ok (Ex_ty (bls12_381_fr_t ~annot), ctxt) + parse_type_annot loc annot >>? fun _annot -> + ok (Ex_ty bls12_381_fr_t, ctxt) | Prim (loc, T_contract, [utl], annot) -> if allow_contract then parse_parameter_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy utl >>? fun (Ex_ty tl, ctxt) -> - parse_type_annot loc annot >>? fun annot -> - contract_t loc tl ~annot >|? fun ty -> (Ex_ty ty, ctxt) + parse_type_annot loc annot >>? fun _annot -> + contract_t loc tl >|? fun ty -> (Ex_ty ty, ctxt) else error (Unexpected_contract loc) | Prim (loc, T_pair, utl :: utr, annot) -> extract_field_annot utl >>? fun (utl, left_field) -> @@ -1512,8 +1485,8 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : ~allow_ticket utr >>? fun (Ex_ty tr, ctxt) -> - parse_type_annot loc annot >>? fun annot -> - pair_t loc (tl, left_field) (tr, right_field) ~annot >|? fun ty -> + parse_type_annot loc annot >>? fun _annot -> + pair_t loc (tl, left_field) (tr, right_field) >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_or, [utl; utr], annot) -> extract_field_annot utl >>? fun (utl, left_constr) -> @@ -1538,16 +1511,16 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : ~allow_ticket utr >>? fun (Ex_ty tr, ctxt) -> - parse_type_annot loc annot >>? fun annot -> - union_t loc (tl, left_constr) (tr, right_constr) ~annot >|? fun ty -> + parse_type_annot loc annot >>? fun _annot -> + union_t loc (tl, left_constr) (tr, right_constr) >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_lambda, [uta; utr], annot) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy uta >>? fun (Ex_ty ta, ctxt) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy utr >>? fun (Ex_ty tr, ctxt) -> - parse_type_annot loc annot >>? fun annot -> - lambda_t loc ta tr ~annot >|? fun ty -> (Ex_ty ty, ctxt) + parse_type_annot loc annot >>? fun _annot -> + lambda_t loc ta tr >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_option, [ut], annot) -> (if legacy then (* legacy semantics with (broken) field annotations *) @@ -1555,7 +1528,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : parse_composed_type_annot loc annot >>? fun (ty_name, _none_constr, _) -> ok (ut, ty_name) else parse_type_annot loc annot >>? fun annot -> ok (ut, annot)) - >>? fun (ut, annot) -> + >>? fun (ut, _annot) -> parse_ty ctxt ~stack_depth:(stack_depth + 1) @@ -1566,7 +1539,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : ~allow_ticket ut >>? fun (Ex_ty t, ctxt) -> - option_t loc t ~annot >|? fun ty -> (Ex_ty ty, ctxt) + option_t loc t >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_list, [ut], annot) -> parse_ty ctxt @@ -1578,20 +1551,20 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : ~allow_ticket ut >>? fun (Ex_ty t, ctxt) -> - parse_type_annot loc annot >>? fun annot -> - list_t loc t ~annot >|? fun ty -> (Ex_ty ty, ctxt) + parse_type_annot loc annot >>? fun _annot -> + list_t loc t >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_ticket, [ut], annot) -> if allow_ticket then parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> - parse_type_annot loc annot >>? fun annot -> - ticket_t loc t ~annot >|? fun ty -> (Ex_ty ty, ctxt) + parse_type_annot loc annot >>? fun _annot -> + ticket_t loc t >|? fun ty -> (Ex_ty ty, ctxt) else error (Unexpected_ticket loc) | Prim (loc, T_set, [ut], annot) -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> - parse_type_annot loc annot >>? fun annot -> - set_t loc t ~annot >|? fun ty -> (Ex_ty ty, ctxt) + parse_type_annot loc annot >>? fun _annot -> + set_t loc t >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_map, [uta; utr], annot) -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt uta >>? fun (Ex_comparable_ty ta, ctxt) -> @@ -1605,12 +1578,12 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : ~allow_ticket utr >>? fun (Ex_ty tr, ctxt) -> - parse_type_annot loc annot >>? fun annot -> - map_t loc ta tr ~annot >|? fun ty -> (Ex_ty ty, ctxt) + parse_type_annot loc annot >>? fun _annot -> + map_t loc ta tr >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_sapling_transaction, [memo_size], annot) -> - parse_type_annot loc annot >>? fun annot -> + parse_type_annot loc annot >>? fun _annot -> parse_memo_size memo_size >|? fun memo_size -> - (Ex_ty (sapling_transaction_t ~memo_size ~annot), ctxt) + (Ex_ty (sapling_transaction_t ~memo_size), ctxt) (* /!\ When adding new lazy storage kinds, be careful to use [when allow_lazy_storage] /!\ @@ -1620,9 +1593,9 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : | Prim (loc, T_big_map, args, annot) when allow_lazy_storage -> (parse_big_map_ty [@tailcall]) ctxt ~stack_depth ~legacy loc args annot | Prim (loc, T_sapling_state, [memo_size], annot) when allow_lazy_storage -> - parse_type_annot loc annot >>? fun annot -> + parse_type_annot loc annot >>? fun _annot -> parse_memo_size memo_size >|? fun memo_size -> - (Ex_ty (sapling_state_t ~memo_size ~annot), ctxt) + (Ex_ty (sapling_state_t ~memo_size), ctxt) | Prim (loc, (T_big_map | T_sapling_state), _, _) -> error (Unexpected_lazy_storage loc) | Prim @@ -1689,8 +1662,8 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma ~legacy value_ty >>? fun (Ex_ty value_ty, ctxt) -> - parse_type_annot big_map_loc map_annot >>? fun annot -> - big_map_t big_map_loc key_ty value_ty ~annot >|? fun big_map_ty -> + parse_type_annot big_map_loc map_annot >>? fun _annot -> + big_map_t big_map_loc key_ty value_ty >|? fun big_map_ty -> (Ex_ty big_map_ty, ctxt) | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) @@ -1745,12 +1718,8 @@ let parse_storage_ty : remaining_storage >>? fun (Ex_ty remaining_storage, ctxt) -> parse_composed_type_annot loc storage_annot - >>? fun (annot, map_field, storage_field) -> - pair_t - loc - (big_map_ty, map_field) - (remaining_storage, storage_field) - ~annot + >>? fun (_annot, map_field, storage_field) -> + pair_t loc (big_map_ty, map_field) (remaining_storage, storage_field) >|? fun ty -> (Ex_ty ty, ctxt)) | _ -> (parse_normal_storage_ty [@tailcall]) ctxt ~stack_depth ~legacy node @@ -2012,11 +1981,7 @@ let parse_uint11 = parse_uint ~nb_bits:11 - serialize and deserialize tickets when they are stored or transferred, - type the READ_TICKET instruction. *) let opened_ticket_type loc ty = - pair_3_key - loc - (address_key ~annot:None, None) - (ty, None) - (nat_key ~annot:None, None) + pair_3_key loc (address_key, None) (ty, None) (nat_key, None) (* -- parse data of primitive types -- *) @@ -2664,7 +2629,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : >|=? fun (diff, ctxt) -> (None, diff, ctxt) | Prim (loc, D_Pair, [Int (loc_id, id); Seq (_, vs)], annot) -> error_unexpected_annot loc annot >>?= fun () -> - option_t loc tv ~annot:None >>?= fun tv_opt -> + option_t loc tv >>?= fun tv_opt -> parse_big_map_items ?type_logger ctxt expr tk tv_opt vs (fun x -> x) >|=? fun (diff, ctxt) -> (Some (id, loc_id), diff, ctxt) | Prim (_, D_Pair, [Int _; expr], _) -> @@ -2815,8 +2780,7 @@ and parse_view_returning : (Some "return of view", strip_locations output_ty, output_ty_loc)) (parse_view_output_ty ctxt ~stack_depth:0 ~legacy output_ty) >>?= fun (Ex_ty output_ty', ctxt) -> - pair_t input_ty_loc (input_ty', None) (storage_type, None) ~annot:None - >>?= fun pair_ty -> + pair_t input_ty_loc (input_ty', None) (storage_type, None) >>?= fun pair_ty -> parse_instr ?type_logger ~stack_depth:0 @@ -3115,26 +3079,25 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let const = {apply = (fun kinfo k -> IConst (kinfo, v, k))} in typed ctxt loc const (Item_t (t, stack)) | (Prim (loc, I_UNIT, [], annot), stack) -> - parse_var_type_annot loc annot >>?= fun ty_name -> + parse_var_type_annot loc annot >>?= fun _ty_name -> let const = {apply = (fun kinfo k -> IConst (kinfo, (), k))} in - typed ctxt loc const (Item_t (unit_t ~annot:ty_name, stack)) + typed ctxt loc const (Item_t (unit_t, stack)) (* options *) | (Prim (loc, I_SOME, [], annot), Item_t (t, rest)) -> - parse_var_type_annot loc annot >>?= fun ty_name -> + parse_var_type_annot loc annot >>?= fun _ty_name -> let cons_some = {apply = (fun kinfo k -> ICons_some (kinfo, k))} in - option_t loc t ~annot:ty_name >>?= fun ty -> - typed ctxt loc cons_some (Item_t (ty, rest)) + option_t loc t >>?= fun ty -> typed ctxt loc cons_some (Item_t (ty, rest)) | (Prim (loc, I_NONE, [t], annot), stack) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> - parse_var_type_annot loc annot >>?= fun ty_name -> + parse_var_type_annot loc annot >>?= fun _ty_name -> let cons_none = {apply = (fun kinfo k -> ICons_none (kinfo, k))} in - option_t loc t ~annot:ty_name >>?= fun ty -> + option_t loc t >>?= fun ty -> let stack_ty = Item_t (ty, stack) in typed ctxt loc cons_none stack_ty | (Prim (loc, I_MAP, [body], annot), Item_t (Option_t (t, _), rest)) -> ( check_kind [Seq_kind] body >>?= fun () -> - parse_var_type_annot loc annot >>?= fun opt_ty_name -> + parse_var_type_annot loc annot >>?= fun _opt_ty_name -> non_terminal_recursion ?type_logger ~legacy @@ -3155,7 +3118,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : invalid_map_body ( merge_stacks ~legacy loc ctxt 1 aft_rest rest >>? fun (Eq, rest, ctxt) -> - option_t loc ret ~annot:opt_ty_name >>? fun opt_ty -> + option_t loc ret >>? fun opt_ty -> let final_stack = Item_t (opt_ty, rest) in let hinfo = {iloc = loc; kstack_ty = Item_t (ret, aft_rest)} in let cinfo = kinfo_of_descr kibody in @@ -3194,8 +3157,8 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : Lwt.return @@ merge_branches ~legacy ctxt loc btr bfr {branch} (* pairs *) | (Prim (loc, I_PAIR, [], annot), Item_t (a, Item_t (b, rest))) -> - parse_constr_annot loc annot >>?= fun (ty_name, l_field, r_field) -> - pair_t loc (a, l_field) (b, r_field) ~annot:ty_name >>?= fun ty -> + parse_constr_annot loc annot >>?= fun (_ty_name, l_field, r_field) -> + pair_t loc (a, l_field) (b, r_field) >>?= fun ty -> let stack_ty = Item_t (ty, rest) in let cons_pair = {apply = (fun kinfo k -> ICons_pair (kinfo, k))} in typed ctxt loc cons_pair stack_ty @@ -3212,7 +3175,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : make_proof_argument (n - 1) tl_ty >>? fun (Comb_proof_argument (comb_witness, Item_t (b_ty, tl_ty'))) -> - pair_t loc (a_ty, None) (b_ty, None) ~annot:None >|? fun pair_t -> + pair_t loc (a_ty, None) (b_ty, None) >|? fun pair_t -> Comb_proof_argument (Comb_succ comb_witness, Item_t (pair_t, tl_ty')) | _ -> let whole_stack = serialize_stack_for_error ctxt stack_ty in @@ -3292,13 +3255,13 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : fun n value_ty ty -> match (n, ty) with | (0, _) -> ok @@ Comb_set_proof_argument (Comb_set_zero, value_ty) - | (1, Pair_t ((_hd_ty, at1), (tl_ty, bt1), {annot; _})) -> - pair_t loc (value_ty, at1) (tl_ty, bt1) ~annot >|? fun after_ty -> + | (1, Pair_t ((_hd_ty, at1), (tl_ty, bt1), _)) -> + pair_t loc (value_ty, at1) (tl_ty, bt1) >|? fun after_ty -> Comb_set_proof_argument (Comb_set_one, after_ty) - | (n, Pair_t ((hd_ty, at1), (tl_ty, bt1), {annot; _})) -> + | (n, Pair_t ((hd_ty, at1), (tl_ty, bt1), _)) -> make_proof_argument (n - 2) value_ty tl_ty >>? fun (Comb_set_proof_argument (comb_set_left_witness, tl_ty')) -> - pair_t loc (hd_ty, at1) (tl_ty', bt1) ~annot >|? fun after_ty -> + pair_t loc (hd_ty, at1) (tl_ty', bt1) >|? fun after_ty -> Comb_set_proof_argument (Comb_set_plus_two comb_set_left_witness, after_ty) | _ -> @@ -3339,17 +3302,17 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest)) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tr >>?= fun (Ex_ty tr, ctxt) -> - parse_constr_annot loc annot >>?= fun (tname, l_field, r_field) -> + parse_constr_annot loc annot >>?= fun (_tname, l_field, r_field) -> let cons_left = {apply = (fun kinfo k -> ICons_left (kinfo, k))} in - union_t loc (tl, l_field) (tr, r_field) ~annot:tname >>?= fun ty -> + union_t loc (tl, l_field) (tr, r_field) >>?= fun ty -> let stack_ty = Item_t (ty, rest) in typed ctxt loc cons_left stack_ty | (Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest)) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tl >>?= fun (Ex_ty tl, ctxt) -> - parse_constr_annot loc annot >>?= fun (tname, l_field, r_field) -> + parse_constr_annot loc annot >>?= fun (_tname, l_field, r_field) -> let cons_right = {apply = (fun kinfo k -> ICons_right (kinfo, k))} in - union_t loc (tl, l_field) (tr, r_field) ~annot:tname >>?= fun ty -> + union_t loc (tl, l_field) (tr, r_field) >>?= fun ty -> let stack_ty = Item_t (ty, rest) in typed ctxt loc cons_right stack_ty | ( Prim (loc, I_IF_LEFT, [bt; bf], annot), @@ -3392,10 +3355,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_NIL, [t], annot), stack) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> - parse_var_type_annot loc annot >>?= fun ty_name -> + parse_var_type_annot loc annot >>?= fun _ty_name -> let nil = {apply = (fun kinfo k -> INil (kinfo, k))} in - list_t loc t ~annot:ty_name >>?= fun ty -> - typed ctxt loc nil (Item_t (ty, stack)) + list_t loc t >>?= fun ty -> typed ctxt loc nil (Item_t (ty, stack)) | ( Prim (loc, I_CONS, [], annot), Item_t (tv, Item_t (List_t (t, ty_name), rest)) ) -> check_item_ty ctxt tv t loc I_CONS 1 2 >>?= fun (Eq, t, ctxt) -> @@ -3434,13 +3396,13 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : in Lwt.return @@ merge_branches ~legacy ctxt loc btr bfr {branch} | (Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest)) -> - parse_var_type_annot loc annot >>?= fun tname -> + parse_var_type_annot loc annot >>?= fun _tname -> let list_size = {apply = (fun kinfo k -> IList_size (kinfo, k))} in - typed ctxt loc list_size (Item_t (nat_t ~annot:tname, rest)) + typed ctxt loc list_size (Item_t (nat_t, rest)) | (Prim (loc, I_MAP, [body], annot), Item_t (List_t (elt, _), starting_rest)) -> ( check_kind [Seq_kind] body >>?= fun () -> - parse_var_type_annot loc annot >>?= fun list_ty_name -> + parse_var_type_annot loc annot >>?= fun _list_ty_name -> non_terminal_recursion ?type_logger tc_context @@ -3467,7 +3429,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let list_map = {apply = (fun kinfo k -> IList_map (kinfo, ibody, k))} in - list_t loc ret ~annot:list_ty_name >>? fun ty -> + list_t loc ret >>? fun ty -> let stack = Item_t (ty, rest) in typed_no_lwt ctxt loc list_map stack ) | Typed {aft; _} -> @@ -3515,10 +3477,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_EMPTY_SET, [t], annot), rest) -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t >>?= fun (Ex_comparable_ty t, ctxt) -> - parse_var_type_annot loc annot >>?= fun tname -> + parse_var_type_annot loc annot >>?= fun _tname -> let instr = {apply = (fun kinfo k -> IEmpty_set (kinfo, t, k))} in - set_t loc t ~annot:tname >>?= fun ty -> - typed ctxt loc instr (Item_t (ty, rest)) + set_t loc t >>?= fun ty -> typed ctxt loc instr (Item_t (ty, rest)) | (Prim (loc, I_ITER, [body], annot), Item_t (Set_t (comp_elt, _), rest)) -> ( check_kind [Seq_kind] body >>?= fun () -> error_unexpected_annot loc annot >>?= fun () -> @@ -3559,10 +3520,10 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : ) | (Prim (loc, I_MEM, [], annot), Item_t (v, Item_t (Set_t (elt, _), rest))) -> let elt = ty_of_comparable_ty elt in - parse_var_type_annot loc annot >>?= fun tname -> + parse_var_type_annot loc annot >>?= fun _tname -> check_item_ty ctxt elt v loc I_MEM 1 2 >>?= fun (Eq, _, ctxt) -> let instr = {apply = (fun kinfo k -> ISet_mem (kinfo, k))} in - (typed ctxt loc instr (Item_t (bool_t ~annot:tname, rest)) + (typed ctxt loc instr (Item_t (bool_t, rest)) : ((a, s) judgement * context) tzresult Lwt.t) | ( Prim (loc, I_UPDATE, [], annot), Item_t (v, Item_t (Bool_t _, Item_t (Set_t (elt, tname), rest))) ) -> @@ -3575,23 +3536,22 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_SIZE, [], annot), Item_t (Set_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISet_size (kinfo, k))} in - typed ctxt loc instr (Item_t (nat_t ~annot:None, rest)) + typed ctxt loc instr (Item_t (nat_t, rest)) (* maps *) | (Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack) -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk >>?= fun (Ex_comparable_ty tk, ctxt) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> - parse_var_type_annot loc annot >>?= fun ty_name -> + parse_var_type_annot loc annot >>?= fun _ty_name -> let instr = {apply = (fun kinfo k -> IEmpty_map (kinfo, tk, k))} in - map_t loc tk tv ~annot:ty_name >>?= fun ty -> - typed ctxt loc instr (Item_t (ty, stack)) + map_t loc tk tv >>?= fun ty -> typed ctxt loc instr (Item_t (ty, stack)) | ( Prim (loc, I_MAP, [body], annot), Item_t (Map_t (ck, elt, _), starting_rest) ) -> ( let k = ty_of_comparable_ty ck in check_kind [Seq_kind] body >>?= fun () -> - parse_var_type_annot loc annot >>?= fun ty_name -> - pair_t loc (k, None) (elt, None) ~annot:None >>?= fun ty -> + parse_var_type_annot loc annot >>?= fun _ty_name -> + pair_t loc (k, None) (elt, None) >>?= fun ty -> non_terminal_recursion ?type_logger tc_context @@ -3624,7 +3584,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : IMap_map (kinfo, ibody, k)); } in - map_t loc ck ret ~annot:ty_name >>? fun ty -> + map_t loc ck ret >>? fun ty -> let stack = Item_t (ty, rest) in typed_no_lwt ctxt loc instr stack ) | Typed {aft; _} -> @@ -3636,7 +3596,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : check_kind [Seq_kind] body >>?= fun () -> error_unexpected_annot loc annot >>?= fun () -> let key = ty_of_comparable_ty comp_elt in - pair_t loc (key, None) (element_ty, None) ~annot:None >>?= fun ty -> + pair_t loc (key, None) (element_ty, None) >>?= fun ty -> non_terminal_recursion ?type_logger tc_context @@ -3676,7 +3636,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : check_item_ty ctxt vk k loc I_MEM 1 2 >>?= fun (Eq, _, ctxt) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IMap_mem (kinfo, k))} in - (typed ctxt loc instr (Item_t (bool_t ~annot:None, rest)) + (typed ctxt loc instr (Item_t (bool_t, rest)) : ((a, s) judgement * context) tzresult Lwt.t) | ( Prim (loc, I_GET, [], annot), Item_t (vk, Item_t (Map_t (ck, elt, _), rest)) ) -> @@ -3684,7 +3644,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : check_item_ty ctxt vk k loc I_GET 1 2 >>?= fun (Eq, _, ctxt) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IMap_get (kinfo, k))} in - option_t loc elt ~annot:None + option_t loc elt >>?= fun ty : ((a, s) judgement * context) tzresult Lwt.t -> typed ctxt loc instr (Item_t (ty, rest)) | ( Prim (loc, I_UPDATE, [], annot), @@ -3715,18 +3675,18 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_SIZE, [], annot), Item_t (Map_t (_, _, _), rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IMap_size (kinfo, k))} in - typed ctxt loc instr (Item_t (nat_t ~annot:None, rest)) + typed ctxt loc instr (Item_t (nat_t, rest)) (* big_map *) | (Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack) -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk >>?= fun (Ex_comparable_ty tk, ctxt) -> parse_big_map_value_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> - parse_var_type_annot loc annot >>?= fun ty_name -> + parse_var_type_annot loc annot >>?= fun _ty_name -> let instr = {apply = (fun kinfo k -> IEmpty_big_map (kinfo, tk, tv, k))} in - big_map_t loc tk tv ~annot:ty_name >>?= fun ty -> + big_map_t loc tk tv >>?= fun ty -> let stack = Item_t (ty, stack) in typed ctxt loc instr stack | ( Prim (loc, I_MEM, [], annot), @@ -3735,7 +3695,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : check_item_ty ctxt set_key k loc I_MEM 1 2 >>?= fun (Eq, _, ctxt) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IBig_map_mem (kinfo, k))} in - let stack = Item_t (bool_t ~annot:None, rest) in + let stack = Item_t (bool_t, rest) in (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) | ( Prim (loc, I_GET, [], annot), Item_t (vk, Item_t (Big_map_t (ck, elt, _), rest)) ) -> @@ -3743,7 +3703,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : check_item_ty ctxt vk k loc I_GET 1 2 >>?= fun (Eq, _, ctxt) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IBig_map_get (kinfo, k))} in - option_t loc elt ~annot:None >>?= fun ty -> + option_t loc elt >>?= fun ty -> let stack = Item_t (ty, rest) in (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) | ( Prim (loc, I_UPDATE, [], annot), @@ -3784,7 +3744,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let instr = {apply = (fun kinfo k -> ISapling_empty_state (kinfo, memo_size, k))} in - let stack = Item_t (sapling_state_t ~memo_size ~annot:None, rest) in + let stack = Item_t (sapling_state_t ~memo_size, rest) in typed ctxt loc instr stack | ( Prim (loc, I_SAPLING_VERIFY_UPDATE, [], _), Item_t @@ -3799,9 +3759,8 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let instr = {apply = (fun kinfo k -> ISapling_verify_update (kinfo, k))} in - pair_t loc (int_t ~annot:None, None) (state_ty, None) ~annot:None - >>?= fun pair_ty -> - option_t loc pair_ty ~annot:None >>?= fun ty -> + pair_t loc (int_t, None) (state_ty, None) >>?= fun pair_ty -> + option_t loc pair_ty >>?= fun ty -> let stack = Item_t (ty, rest) in typed ctxt loc instr stack (* control *) @@ -3966,7 +3925,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : code >>=? fun (lambda, ctxt) -> let instr = {apply = (fun kinfo k -> ILambda (kinfo, lambda, k))} in - lambda_t loc arg ret ~annot:None >>?= fun ty -> + lambda_t loc arg ret >>?= fun ty -> let stack = Item_t (ty, stack) in typed ctxt loc instr stack | ( Prim (loc, I_EXEC, [], annot), @@ -3980,17 +3939,14 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : Item_t ( capture, Item_t - ( Lambda_t - ( Pair_t ((capture_ty, _), (arg_ty, _), {annot = lam_annot; _}), - ret, - _ ), - rest ) ) ) -> + (Lambda_t (Pair_t ((capture_ty, _), (arg_ty, _), _), ret, _), rest) + ) ) -> check_packable ~legacy:false loc capture_ty >>?= fun () -> check_item_ty ctxt capture capture_ty loc I_APPLY 1 2 >>?= fun (Eq, capture_ty, ctxt) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IApply (kinfo, capture_ty, k))} in - lambda_t loc arg_ty ret ~annot:lam_annot + lambda_t loc arg_ty ret (* This cannot fail because the type [lambda 'arg 'ret] is always smaller than the input type [lambda (pair 'arg 'capture) 'ret]. In an ideal world, there would be a smart deconstructor to ensure this statically. *) @@ -4107,14 +4063,12 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (Timestamp_t tname, rest) in typed ctxt loc instr stack | ( Prim (loc, I_SUB, [], annot), - Item_t - ( Timestamp_t {annot = tn1; size = _}, - Item_t (Timestamp_t {annot = tn2; size = _}, rest) ) ) -> + Item_t (Timestamp_t _, Item_t (Timestamp_t _, rest)) ) -> check_var_annot loc annot >>?= fun () -> - merge_type_annot ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_annot ~legacy ~error_details:Informative None None + >>?= fun _tname -> let instr = {apply = (fun kinfo k -> IDiff_timestamps (kinfo, k))} in - let stack = Item_t (int_t ~annot:tname, rest) in + let stack = Item_t (int_t, rest) in typed ctxt loc instr stack (* string operations *) | ( Prim (loc, I_CONCAT, [], annot), @@ -4138,7 +4092,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_SIZE, [], annot), Item_t (String_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IString_size (kinfo, k))} in - let stack = Item_t (nat_t ~annot:None, rest) in + let stack = Item_t (nat_t, rest) in typed ctxt loc instr stack (* bytes operations *) | ( Prim (loc, I_CONCAT, [], annot), @@ -4164,7 +4118,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_SIZE, [], annot), Item_t (Bytes_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IBytes_size (kinfo, k))} in - let stack = Item_t (nat_t ~annot:None, rest) in + let stack = Item_t (nat_t, rest) in typed ctxt loc instr stack (* currency operations *) | ( Prim (loc, I_ADD, [], annot), @@ -4241,7 +4195,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_ABS, [], annot), Item_t (Int_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IAbs_int (kinfo, k))} in - let stack = Item_t (nat_t ~annot:None, rest) in + let stack = Item_t (nat_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_ISNAT, [], annot), Item_t (Int_t _, rest)) -> check_var_annot loc annot >>?= fun () -> @@ -4251,7 +4205,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_INT, [], annot), Item_t (Nat_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IInt_nat (kinfo, k))} in - let stack = Item_t (int_t ~annot:None, rest) in + let stack = Item_t (int_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_NEG, [], annot), Item_t (Int_t tname, rest)) -> check_var_annot loc annot >>?= fun () -> @@ -4261,7 +4215,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_NEG, [], annot), Item_t (Nat_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> INeg (kinfo, k))} in - let stack = Item_t (int_t ~annot:None, rest) in + let stack = Item_t (int_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_ADD, [], annot), Item_t (Int_t tn1, Item_t (Int_t tn2, rest))) -> @@ -4317,7 +4271,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 >>?= fun _tname -> let instr = {apply = (fun kinfo k -> ISub_int (kinfo, k))} in - let stack = Item_t (int_t ~annot:None, rest) in + let stack = Item_t (int_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_MUL, [], annot), Item_t (Int_t tn1, Item_t (Int_t tn2, rest))) -> @@ -4443,7 +4397,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_NOT, [], annot), Item_t (Nat_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> INot_int (kinfo, k))} in - let stack = Item_t (int_t ~annot:None, rest) in + let stack = Item_t (int_t, rest) in typed ctxt loc instr stack (* comparison *) | (Prim (loc, I_COMPARE, [], annot), Item_t (t1, Item_t (t2, rest))) -> @@ -4451,38 +4405,38 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : check_item_ty ctxt t1 t2 loc I_COMPARE 1 2 >>?= fun (Eq, t, ctxt) -> comparable_ty_of_ty ctxt loc t >>?= fun (key, ctxt) -> let instr = {apply = (fun kinfo k -> ICompare (kinfo, key, k))} in - let stack = Item_t (int_t ~annot:None, rest) in + let stack = Item_t (int_t, rest) in (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) (* comparators *) | (Prim (loc, I_EQ, [], annot), Item_t (Int_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEq (kinfo, k))} in - let stack = Item_t (bool_t ~annot:None, rest) in + let stack = Item_t (bool_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_NEQ, [], annot), Item_t (Int_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> INeq (kinfo, k))} in - let stack = Item_t (bool_t ~annot:None, rest) in + let stack = Item_t (bool_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_LT, [], annot), Item_t (Int_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ILt (kinfo, k))} in - let stack = Item_t (bool_t ~annot:None, rest) in + let stack = Item_t (bool_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_GT, [], annot), Item_t (Int_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IGt (kinfo, k))} in - let stack = Item_t (bool_t ~annot:None, rest) in + let stack = Item_t (bool_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_LE, [], annot), Item_t (Int_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ILe (kinfo, k))} in - let stack = Item_t (bool_t ~annot:None, rest) in + let stack = Item_t (bool_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_GE, [], annot), Item_t (Int_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IGe (kinfo, k))} in - let stack = Item_t (bool_t ~annot:None, rest) in + let stack = Item_t (bool_t, rest) in typed ctxt loc instr stack (* annotations *) | (Prim (loc, I_CAST, [cast_t], annot), Item_t (t, stack)) -> @@ -4508,13 +4462,13 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : >>?= fun () -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IPack (kinfo, t, k))} in - let stack = Item_t (bytes_t ~annot:None, rest) in + let stack = Item_t (bytes_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t _, rest)) -> parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> - parse_var_type_annot loc annot >>?= fun ty_name -> - option_t loc t ~annot:ty_name >>?= fun res_ty -> + parse_var_type_annot loc annot >>?= fun _ty_name -> + option_t loc t >>?= fun res_ty -> let instr = {apply = (fun kinfo k -> IUnpack (kinfo, t, k))} in let stack = Item_t (res_ty, rest) in typed ctxt loc instr stack @@ -4522,13 +4476,13 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_ADDRESS, [], annot), Item_t (Contract_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IAddress (kinfo, k))} in - let stack = Item_t (address_t ~annot:None, rest) in + let stack = Item_t (address_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_CONTRACT, [ty], annot), Item_t (Address_t _, rest)) -> parse_parameter_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> - contract_t loc t ~annot:None >>?= fun contract_ty -> - option_t loc contract_ty ~annot:None >>?= fun res_ty -> + contract_t loc t >>?= fun contract_ty -> + option_t loc contract_ty >>?= fun res_ty -> parse_entrypoint_annot loc annot >>?= fun entrypoint -> Script_ir_annot.field_annot_opt_to_entrypoint_strict ~loc entrypoint >>?= fun entrypoint -> @@ -4543,7 +4497,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : parse_view_name ctxt name >>?= fun (name, ctxt) -> parse_view_output_ty ctxt ~stack_depth:0 ~legacy output_ty >>?= fun (Ex_ty output_ty, ctxt) -> - option_t output_ty_loc output_ty ~annot:None >>?= fun res_ty -> + option_t output_ty_loc output_ty >>?= fun res_ty -> check_var_annot loc annot >>?= fun () -> let instr = { @@ -4560,14 +4514,14 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : check_item_ty ctxt p cp loc prim 1 4 >>?= fun (Eq, _, ctxt) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ITransfer_tokens (kinfo, k))} in - let stack = Item_t (operation_t ~annot:None, rest) in + let stack = Item_t (operation_t, rest) in (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) | ( Prim (loc, (I_SET_DELEGATE as prim), [], annot), Item_t (Option_t (Key_hash_t _, _), rest) ) -> Tc_context.check_not_in_view loc ~legacy tc_context prim >>?= fun () -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISet_delegate (kinfo, k))} in - let stack = Item_t (operation_t ~annot:None, rest) in + let stack = Item_t (operation_t, rest) in typed ctxt loc instr stack | (Prim (_, I_CREATE_ACCOUNT, _, _), _) -> fail (Deprecated_instruction I_CREATE_ACCOUNT) @@ -4604,9 +4558,8 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : ~legacy storage_type) >>?= fun (Ex_ty storage_type, ctxt) -> - pair_t loc (arg_type, None) (storage_type, None) ~annot:None - >>?= fun arg_type_full -> - pair_t loc (list_operation_t, None) (storage_type, None) ~annot:None + pair_t loc (arg_type, None) (storage_type, None) >>?= fun arg_type_full -> + pair_t loc (list_operation_t, None) (storage_type, None) >>?= fun ret_type_full -> trace (Ill_typed_contract (canonical_code, [])) @@ -4639,56 +4592,54 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : {kinfo; storage_type; arg_type; lambda; views; root_name; k}); } in - let stack = - Item_t (operation_t ~annot:None, Item_t (address_t ~annot:None, rest)) - in + let stack = Item_t (operation_t, Item_t (address_t, rest)) in typed ctxt loc instr stack | (Prim (loc, I_NOW, [], annot), stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> INow (kinfo, k))} in - let stack = Item_t (timestamp_t ~annot:None, stack) in + let stack = Item_t (timestamp_t, stack) in typed ctxt loc instr stack | (Prim (loc, I_AMOUNT, [], annot), stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IAmount (kinfo, k))} in - let stack = Item_t (mutez_t ~annot:None, stack) in + let stack = Item_t (mutez_t, stack) in typed ctxt loc instr stack | (Prim (loc, I_CHAIN_ID, [], annot), stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IChainId (kinfo, k))} in - let stack = Item_t (chain_id_t ~annot:None, stack) in + let stack = Item_t (chain_id_t, stack) in typed ctxt loc instr stack | (Prim (loc, I_BALANCE, [], annot), stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IBalance (kinfo, k))} in - let stack = Item_t (mutez_t ~annot:None, stack) in + let stack = Item_t (mutez_t, stack) in typed ctxt loc instr stack | (Prim (loc, I_LEVEL, [], annot), stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ILevel (kinfo, k))} in - let stack = Item_t (nat_t ~annot:None, stack) in + let stack = Item_t (nat_t, stack) in typed ctxt loc instr stack | (Prim (loc, I_VOTING_POWER, [], annot), Item_t (Key_hash_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IVoting_power (kinfo, k))} in - let stack = Item_t (nat_t ~annot:None, rest) in + let stack = Item_t (nat_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_TOTAL_VOTING_POWER, [], annot), stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ITotal_voting_power (kinfo, k))} in - let stack = Item_t (nat_t ~annot:None, stack) in + let stack = Item_t (nat_t, stack) in typed ctxt loc instr stack | (Prim (_, I_STEPS_TO_QUOTA, _, _), _) -> fail (Deprecated_instruction I_STEPS_TO_QUOTA) | (Prim (loc, I_SOURCE, [], annot), stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISource (kinfo, k))} in - let stack = Item_t (address_t ~annot:None, stack) in + let stack = Item_t (address_t, stack) in typed ctxt loc instr stack | (Prim (loc, I_SENDER, [], annot), stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISender (kinfo, k))} in - let stack = Item_t (address_t ~annot:None, stack) in + let stack = Item_t (address_t, stack) in typed ctxt loc instr stack | (Prim (loc, (I_SELF as prim), [], annot), stack) -> Lwt.return @@ -4716,7 +4667,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : ~root_name entrypoint >>? fun (_, Ex_ty param_type) -> - contract_t loc param_type ~annot:None >>? fun res_ty -> + contract_t loc param_type >>? fun res_ty -> let instr = { apply = @@ -4728,44 +4679,44 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_SELF_ADDRESS, [], annot), stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISelf_address (kinfo, k))} in - let stack = Item_t (address_t ~annot:None, stack) in + let stack = Item_t (address_t, stack) in typed ctxt loc instr stack (* cryptography *) | (Prim (loc, I_HASH_KEY, [], annot), Item_t (Key_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IHash_key (kinfo, k))} in - let stack = Item_t (key_hash_t ~annot:None, rest) in + let stack = Item_t (key_hash_t, rest) in typed ctxt loc instr stack | ( Prim (loc, I_CHECK_SIGNATURE, [], annot), Item_t (Key_t _, Item_t (Signature_t _, Item_t (Bytes_t _, rest))) ) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ICheck_signature (kinfo, k))} in - let stack = Item_t (bool_t ~annot:None, rest) in + let stack = Item_t (bool_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_BLAKE2B, [], annot), Item_t (Bytes_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IBlake2b (kinfo, k))} in - let stack = Item_t (bytes_t ~annot:None, rest) in + let stack = Item_t (bytes_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_SHA256, [], annot), Item_t (Bytes_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISha256 (kinfo, k))} in - let stack = Item_t (bytes_t ~annot:None, rest) in + let stack = Item_t (bytes_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_SHA512, [], annot), Item_t (Bytes_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISha512 (kinfo, k))} in - let stack = Item_t (bytes_t ~annot:None, rest) in + let stack = Item_t (bytes_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_KECCAK, [], annot), Item_t (Bytes_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IKeccak (kinfo, k))} in - let stack = Item_t (bytes_t ~annot:None, rest) in + let stack = Item_t (bytes_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_SHA3, [], annot), Item_t (Bytes_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISha3 (kinfo, k))} in - let stack = Item_t (bytes_t ~annot:None, rest) in + let stack = Item_t (bytes_t, rest) in typed ctxt loc instr stack | ( Prim (loc, I_ADD, [], annot), Item_t (Bls12_381_g1_t tn1, Item_t (Bls12_381_g1_t tn2, rest)) ) -> @@ -4810,16 +4761,16 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (Bls12_381_fr_t tname, rest) in typed ctxt loc instr stack | ( Prim (loc, I_MUL, [], annot), - Item_t (Nat_t {annot = tname; _}, Item_t (Bls12_381_fr_t _, rest)) ) -> + Item_t (Nat_t _, Item_t (Bls12_381_fr_t _, rest)) ) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IMul_bls12_381_fr_z (kinfo, k))} in - let stack = Item_t (bls12_381_fr_t ~annot:tname, rest) in + let stack = Item_t (bls12_381_fr_t, rest) in typed ctxt loc instr stack | ( Prim (loc, I_MUL, [], annot), - Item_t (Int_t {annot = tname; _}, Item_t (Bls12_381_fr_t _, rest)) ) -> + Item_t (Int_t _, Item_t (Bls12_381_fr_t _, rest)) ) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IMul_bls12_381_fr_z (kinfo, k))} in - let stack = Item_t (bls12_381_fr_t ~annot:tname, rest) in + let stack = Item_t (bls12_381_fr_t, rest) in typed ctxt loc instr stack | ( Prim (loc, I_MUL, [], annot), Item_t (Bls12_381_fr_t tname, Item_t (Int_t _, rest)) ) -> @@ -4836,7 +4787,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_INT, [], annot), Item_t (Bls12_381_fr_t _, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IInt_bls12_381_fr (kinfo, k))} in - let stack = Item_t (int_t ~annot:None, rest) in + let stack = Item_t (int_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_NEG, [], annot), Item_t (Bls12_381_g1_t tname, rest)) -> check_var_annot loc annot >>?= fun () -> @@ -4861,13 +4812,13 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let instr = {apply = (fun kinfo k -> IPairing_check_bls12_381 (kinfo, k))} in - let stack = Item_t (bool_t ~annot:None, rest) in + let stack = Item_t (bool_t, rest) in typed ctxt loc instr stack (* Tickets *) | (Prim (loc, I_TICKET, [], annot), Item_t (t, Item_t (Nat_t _, rest))) -> check_var_annot loc annot >>?= fun () -> comparable_ty_of_ty ctxt loc t >>?= fun (ty, ctxt) -> - ticket_t loc ty ~annot:None >>?= fun res_ty -> + ticket_t loc ty >>?= fun res_ty -> let instr = {apply = (fun kinfo k -> ITicket (kinfo, k))} in let stack = Item_t (res_ty, rest) in typed ctxt loc instr stack @@ -4886,9 +4837,8 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : Item_t (Pair_t ((Nat_t _, fa_a), (Nat_t _, fa_b), _), rest) ) ) -> check_var_annot loc annot >>?= fun () -> let () = check_dupable_comparable_ty t in - pair_t loc (ticket_t, fa_a) (ticket_t, fa_b) ~annot:None - >>?= fun pair_tickets_ty -> - option_t loc pair_tickets_ty ~annot:None >>?= fun res_ty -> + pair_t loc (ticket_t, fa_a) (ticket_t, fa_b) >>?= fun pair_tickets_ty -> + option_t loc pair_tickets_ty >>?= fun res_ty -> let instr = {apply = (fun kinfo k -> ISplit_ticket (kinfo, k))} in let stack = Item_t (res_ty, rest) in typed ctxt loc instr stack @@ -4903,7 +4853,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : eq_ty >>?= fun (Eq, ty) -> match ty with | Ticket_t (contents_ty, _) -> - option_t loc ty ~annot:None >>?= fun res_ty -> + option_t loc ty >>?= fun res_ty -> let instr = {apply = (fun kinfo k -> IJoin_tickets (kinfo, contents_ty, k))} in @@ -5129,8 +5079,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra if Entrypoint.is_default entrypoint then (* An implicit account on the "default" entrypoint always exists and has type unit. *) Lwt.return - ( ty_eq ~legacy:true ctxt loc arg (unit_t ~annot:None) - >|? fun (Eq, ctxt) -> + ( ty_eq ~legacy:true ctxt loc arg unit_t >|? fun (Eq, ctxt) -> (ctxt, {arg_ty = arg; address = {contract; entrypoint}}) ) else fail (No_such_entrypoint entrypoint) | None -> ( @@ -5306,12 +5255,7 @@ let parse_contract_for_script : (* An implicit account on the "default" entrypoint always exists and has type unit. *) Lwt.return ( Gas_monad.run ctxt - @@ merge_types - ~legacy:true - ~error_details:Fast - loc - arg - (unit_t ~annot:None) + @@ merge_types ~legacy:true ~error_details:Fast loc arg unit_t >|? fun (eq_ty, ctxt) -> match eq_ty with | Ok (Eq, _ty) -> @@ -5395,13 +5339,9 @@ let parse_code : (Ill_formed_type (Some "storage", code, storage_type_loc)) (parse_storage_ty ctxt ~stack_depth:0 ~legacy storage_type) >>?= fun (Ex_ty storage_type, ctxt) -> - pair_t storage_type_loc (arg_type, None) (storage_type, None) ~annot:None + pair_t storage_type_loc (arg_type, None) (storage_type, None) >>?= fun arg_type_full -> - pair_t - storage_type_loc - (list_operation_t, None) - (storage_type, None) - ~annot:None + pair_t storage_type_loc (list_operation_t, None) (storage_type, None) >>?= fun ret_type_full -> trace (Ill_typed_contract (code, [])) @@ -5510,13 +5450,9 @@ let typecheck_code : (Ill_formed_type (Some "storage", code, storage_type_loc)) (parse_storage_ty ctxt ~stack_depth:0 ~legacy storage_type) >>?= fun (Ex_ty storage_type, ctxt) -> - pair_t storage_type_loc (arg_type, None) (storage_type, None) ~annot:None + pair_t storage_type_loc (arg_type, None) (storage_type, None) >>?= fun arg_type_full -> - pair_t - storage_type_loc - (list_operation_t, None) - (storage_type, None) - ~annot:None + pair_t storage_type_loc (list_operation_t, None) (storage_type, None) >>?= fun ret_type_full -> let type_logger loc bef aft = type_map := (loc, (bef, aft)) :: !type_map in let type_logger = if show_types then Some type_logger else None in @@ -5720,7 +5656,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : in (* this can't fail if the original type is well-formed because [option vt] is always strictly smaller than [big_map kt vt] *) - option_t loc vt ~annot:None >>?= fun vt -> + option_t loc vt >>?= fun vt -> unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items >|=? fun (items, ctxt) -> ( Micheline.Prim diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 9c7893c63a23..9b9ea808df3d 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -310,7 +310,7 @@ type empty_cell = EmptyCell type end_of_stack = empty_cell * empty_cell -type 'a ty_metadata = {annot : type_annot option; size : 'a Type_size.t} +type 'a ty_metadata = {size : 'a Type_size.t} type _ comparable_ty = | Unit_key : unit ty_metadata -> unit comparable_ty @@ -366,48 +366,47 @@ let comparable_ty_metadata : type a. a comparable_ty -> a ty_metadata = function let comparable_ty_size t = (comparable_ty_metadata t).size -let unit_key ~annot = Unit_key {annot; size = Type_size.one} +let unit_key = Unit_key {size = Type_size.one} -let never_key ~annot = Never_key {annot; size = Type_size.one} +let never_key = Never_key {size = Type_size.one} -let int_key ~annot = Int_key {annot; size = Type_size.one} +let int_key = Int_key {size = Type_size.one} -let nat_key ~annot = Nat_key {annot; size = Type_size.one} +let nat_key = Nat_key {size = Type_size.one} -let signature_key ~annot = Signature_key {annot; size = Type_size.one} +let signature_key = Signature_key {size = Type_size.one} -let string_key ~annot = String_key {annot; size = Type_size.one} +let string_key = String_key {size = Type_size.one} -let bytes_key ~annot = Bytes_key {annot; size = Type_size.one} +let bytes_key = Bytes_key {size = Type_size.one} -let mutez_key ~annot = Mutez_key {annot; size = Type_size.one} +let mutez_key = Mutez_key {size = Type_size.one} -let bool_key ~annot = Bool_key {annot; size = Type_size.one} +let bool_key = Bool_key {size = Type_size.one} -let key_hash_key ~annot = Key_hash_key {annot; size = Type_size.one} +let key_hash_key = Key_hash_key {size = Type_size.one} -let key_key ~annot = Key_key {annot; size = Type_size.one} +let key_key = Key_key {size = Type_size.one} -let timestamp_key ~annot = Timestamp_key {annot; size = Type_size.one} +let timestamp_key = Timestamp_key {size = Type_size.one} -let chain_id_key ~annot = Chain_id_key {annot; size = Type_size.one} +let chain_id_key = Chain_id_key {size = Type_size.one} -let address_key ~annot = Address_key {annot; size = Type_size.one} +let address_key = Address_key {size = Type_size.one} -let pair_key loc (l, fannot_l) (r, fannot_r) ~annot = +let pair_key loc (l, fannot_l) (r, fannot_r) = Type_size.compound2 loc (comparable_ty_size l) (comparable_ty_size r) - >|? fun size -> Pair_key ((l, fannot_l), (r, fannot_r), {annot; size}) + >|? fun size -> Pair_key ((l, fannot_l), (r, fannot_r), {size}) -let pair_3_key loc l m r = - pair_key loc m r ~annot:None >>? fun r -> pair_key loc l (r, None) ~annot:None +let pair_3_key loc l m r = pair_key loc m r >>? fun r -> pair_key loc l (r, None) -let union_key loc (l, fannot_l) (r, fannot_r) ~annot = +let union_key loc (l, fannot_l) (r, fannot_r) = Type_size.compound2 loc (comparable_ty_size l) (comparable_ty_size r) - >|? fun size -> Union_key ((l, fannot_l), (r, fannot_r), {annot; size}) + >|? fun size -> Union_key ((l, fannot_l), (r, fannot_r), {size}) -let option_key loc t ~annot = +let option_key loc t = Type_size.compound1 loc (comparable_ty_size t) >|? fun size -> - Option_key (t, {annot; size}) + Option_key (t, {size}) (* @@ -1812,169 +1811,133 @@ let ty_metadata : type a. a ty -> a ty_metadata = function let ty_size t = (ty_metadata t).size -let unit_t ~annot = Unit_t {annot; size = Type_size.one} +let unit_t = Unit_t {size = Type_size.one} -let int_t ~annot = Int_t {annot; size = Type_size.one} +let int_t = Int_t {size = Type_size.one} -let nat_t ~annot = Nat_t {annot; size = Type_size.one} +let nat_t = Nat_t {size = Type_size.one} -let signature_t ~annot = Signature_t {annot; size = Type_size.one} +let signature_t = Signature_t {size = Type_size.one} -let string_t ~annot = String_t {annot; size = Type_size.one} +let string_t = String_t {size = Type_size.one} -let bytes_t ~annot = Bytes_t {annot; size = Type_size.one} +let bytes_t = Bytes_t {size = Type_size.one} -let mutez_t ~annot = Mutez_t {annot; size = Type_size.one} +let mutez_t = Mutez_t {size = Type_size.one} -let key_hash_t ~annot = Key_hash_t {annot; size = Type_size.one} +let key_hash_t = Key_hash_t {size = Type_size.one} -let key_t ~annot = Key_t {annot; size = Type_size.one} +let key_t = Key_t {size = Type_size.one} -let timestamp_t ~annot = Timestamp_t {annot; size = Type_size.one} +let timestamp_t = Timestamp_t {size = Type_size.one} -let address_t ~annot = Address_t {annot; size = Type_size.one} +let address_t = Address_t {size = Type_size.one} -let bool_t ~annot = Bool_t {annot; size = Type_size.one} +let bool_t = Bool_t {size = Type_size.one} -let pair_t loc (l, fannot_l) (r, fannot_r) ~annot = +let pair_t loc (l, fannot_l) (r, fannot_r) = Type_size.compound2 loc (ty_size l) (ty_size r) >|? fun size -> - Pair_t ((l, fannot_l), (r, fannot_r), {annot; size}) + Pair_t ((l, fannot_l), (r, fannot_r), {size}) -let union_t loc (l, fannot_l) (r, fannot_r) ~annot = +let union_t loc (l, fannot_l) (r, fannot_r) = Type_size.compound2 loc (ty_size l) (ty_size r) >|? fun size -> - Union_t ((l, fannot_l), (r, fannot_r), {annot; size}) + Union_t ((l, fannot_l), (r, fannot_r), {size}) let union_bytes_bool_t = - Union_t - ( (bytes_t ~annot:None, None), - (bool_t ~annot:None, None), - {annot = None; size = Type_size.three} ) + Union_t ((bytes_t, None), (bool_t, None), {size = Type_size.three}) -let lambda_t loc l r ~annot = +let lambda_t loc l r = Type_size.compound2 loc (ty_size l) (ty_size r) >|? fun size -> - Lambda_t (l, r, {annot; size}) + Lambda_t (l, r, {size}) -let option_t loc t ~annot = - Type_size.compound1 loc (ty_size t) >|? fun size -> Option_t (t, {annot; size}) +let option_t loc t = + Type_size.compound1 loc (ty_size t) >|? fun size -> Option_t (t, {size}) -let option_mutez'_t meta = - let {annot; size = _} = meta in - Option_t (mutez_t ~annot, {annot = None; size = Type_size.two}) +let option_mutez'_t _meta = Option_t (mutez_t, {size = Type_size.two}) -let option_string'_t meta = - let {annot; size = _} = meta in - Option_t (string_t ~annot, {annot = None; size = Type_size.two}) +let option_string'_t _meta = Option_t (string_t, {size = Type_size.two}) -let option_bytes'_t meta = - let {annot; size = _} = meta in - Option_t (bytes_t ~annot, {annot = None; size = Type_size.two}) +let option_bytes'_t _meta = Option_t (bytes_t, {size = Type_size.two}) -let option_nat_t = - Option_t (nat_t ~annot:None, {annot = None; size = Type_size.two}) +let option_nat_t = Option_t (nat_t, {size = Type_size.two}) let option_pair_nat_nat_t = Option_t - ( Pair_t - ( (nat_t ~annot:None, None), - (nat_t ~annot:None, None), - {annot = None; size = Type_size.three} ), - {annot = None; size = Type_size.four} ) - -let option_pair_nat'_nat'_t meta = - let {annot; size = _} = meta in + ( Pair_t ((nat_t, None), (nat_t, None), {size = Type_size.three}), + {size = Type_size.four} ) + +let option_pair_nat'_nat'_t _meta = Option_t - ( Pair_t - ( (nat_t ~annot, None), - (nat_t ~annot, None), - {annot = None; size = Type_size.three} ), - {annot = None; size = Type_size.four} ) - -let option_pair_nat_mutez'_t meta = - let {annot; size = _} = meta in + ( Pair_t ((nat_t, None), (nat_t, None), {size = Type_size.three}), + {size = Type_size.four} ) + +let option_pair_nat_mutez'_t _meta = Option_t - ( Pair_t - ( (nat_t ~annot:None, None), - (mutez_t ~annot, None), - {annot = None; size = Type_size.three} ), - {annot = None; size = Type_size.four} ) - -let option_pair_mutez'_mutez'_t meta = - let {annot; size = _} = meta in + ( Pair_t ((nat_t, None), (mutez_t, None), {size = Type_size.three}), + {size = Type_size.four} ) + +let option_pair_mutez'_mutez'_t _meta = Option_t - ( Pair_t - ( (mutez_t ~annot, None), - (mutez_t ~annot, None), - {annot = None; size = Type_size.three} ), - {annot = None; size = Type_size.four} ) - -let option_pair_int'_nat_t meta = - let {annot; size = _} = meta in + ( Pair_t ((mutez_t, None), (mutez_t, None), {size = Type_size.three}), + {size = Type_size.four} ) + +let option_pair_int'_nat_t _meta = Option_t - ( Pair_t - ( (int_t ~annot, None), - (nat_t ~annot:None, None), - {annot = None; size = Type_size.three} ), - {annot = None; size = Type_size.four} ) - -let option_pair_int_nat'_t meta = - let {annot; size = _} = meta in + ( Pair_t ((int_t, None), (nat_t, None), {size = Type_size.three}), + {size = Type_size.four} ) + +let option_pair_int_nat'_t _meta = Option_t - ( Pair_t - ( (int_t ~annot:None, None), - (nat_t ~annot, None), - {annot = None; size = Type_size.three} ), - {annot = None; size = Type_size.four} ) + ( Pair_t ((int_t, None), (nat_t, None), {size = Type_size.three}), + {size = Type_size.four} ) -let list_t loc t ~annot = - Type_size.compound1 loc (ty_size t) >|? fun size -> List_t (t, {annot; size}) +let list_t loc t = + Type_size.compound1 loc (ty_size t) >|? fun size -> List_t (t, {size}) -let operation_t ~annot = Operation_t {annot; size = Type_size.one} +let operation_t = Operation_t {size = Type_size.one} -let list_operation_t = - List_t (operation_t ~annot:None, {annot = None; size = Type_size.two}) +let list_operation_t = List_t (operation_t, {size = Type_size.two}) -let set_t loc t ~annot = +let set_t loc t = Type_size.compound1 loc (comparable_ty_size t) >|? fun size -> - Set_t (t, {annot; size}) + Set_t (t, {size}) -let map_t loc l r ~annot = +let map_t loc l r = Type_size.compound2 loc (comparable_ty_size l) (ty_size r) >|? fun size -> - Map_t (l, r, {annot; size}) + Map_t (l, r, {size}) -let big_map_t loc l r ~annot = +let big_map_t loc l r = Type_size.compound2 loc (comparable_ty_size l) (ty_size r) >|? fun size -> - Big_map_t (l, r, {annot; size}) + Big_map_t (l, r, {size}) -let contract_t loc t ~annot = - Type_size.compound1 loc (ty_size t) >|? fun size -> - Contract_t (t, {annot; size}) +let contract_t loc t = + Type_size.compound1 loc (ty_size t) >|? fun size -> Contract_t (t, {size}) -let contract_unit_t = - Contract_t (unit_t ~annot:None, {annot = None; size = Type_size.two}) +let contract_unit_t = Contract_t (unit_t, {size = Type_size.two}) -let sapling_transaction_t ~memo_size ~annot = - Sapling_transaction_t (memo_size, {annot; size = Type_size.one}) +let sapling_transaction_t ~memo_size = + Sapling_transaction_t (memo_size, {size = Type_size.one}) -let sapling_state_t ~memo_size ~annot = - Sapling_state_t (memo_size, {annot; size = Type_size.one}) +let sapling_state_t ~memo_size = + Sapling_state_t (memo_size, {size = Type_size.one}) -let chain_id_t ~annot = Chain_id_t {annot; size = Type_size.one} +let chain_id_t = Chain_id_t {size = Type_size.one} -let never_t ~annot = Never_t {annot; size = Type_size.one} +let never_t = Never_t {size = Type_size.one} -let bls12_381_g1_t ~annot = Bls12_381_g1_t {annot; size = Type_size.one} +let bls12_381_g1_t = Bls12_381_g1_t {size = Type_size.one} -let bls12_381_g2_t ~annot = Bls12_381_g2_t {annot; size = Type_size.one} +let bls12_381_g2_t = Bls12_381_g2_t {size = Type_size.one} -let bls12_381_fr_t ~annot = Bls12_381_fr_t {annot; size = Type_size.one} +let bls12_381_fr_t = Bls12_381_fr_t {size = Type_size.one} -let ticket_t loc t ~annot = +let ticket_t loc t = Type_size.compound1 loc (comparable_ty_size t) >|? fun size -> - Ticket_t (t, {annot; size}) + Ticket_t (t, {size}) -let chest_key_t ~annot = Chest_key_t {annot; size = Type_size.one} +let chest_key_t = Chest_key_t {size = Type_size.one} -let chest_t ~annot = Chest_t {annot; size = Type_size.one} +let chest_t = Chest_t {size = Type_size.one} type 'a kinstr_traverse = { apply : 'b 'u 'r 'f. 'a -> ('b, 'u, 'r, 'f) kinstr -> 'a; diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 0bd3069c0b62..6bca003f7ab1 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -188,7 +188,7 @@ module Type_size : sig val to_int : 'a t -> Saturation_repr.mul_safe Saturation_repr.t end -type 'a ty_metadata = {annot : type_annot option; size : 'a Type_size.t} +type 'a ty_metadata = {size : 'a Type_size.t} type _ comparable_ty = | Unit_key : unit ty_metadata -> unit comparable_ty @@ -223,39 +223,38 @@ type _ comparable_ty = 'v comparable_ty * 'v option ty_metadata -> 'v option comparable_ty -val unit_key : annot:type_annot option -> unit comparable_ty +val unit_key : unit comparable_ty -val never_key : annot:type_annot option -> never comparable_ty +val never_key : never comparable_ty -val int_key : annot:type_annot option -> z num comparable_ty +val int_key : z num comparable_ty -val nat_key : annot:type_annot option -> n num comparable_ty +val nat_key : n num comparable_ty -val signature_key : annot:type_annot option -> signature comparable_ty +val signature_key : signature comparable_ty -val string_key : annot:type_annot option -> Script_string.t comparable_ty +val string_key : Script_string.t comparable_ty -val bytes_key : annot:type_annot option -> Bytes.t comparable_ty +val bytes_key : Bytes.t comparable_ty -val mutez_key : annot:type_annot option -> Tez.t comparable_ty +val mutez_key : Tez.t comparable_ty -val bool_key : annot:type_annot option -> bool comparable_ty +val bool_key : bool comparable_ty -val key_hash_key : annot:type_annot option -> public_key_hash comparable_ty +val key_hash_key : public_key_hash comparable_ty -val key_key : annot:type_annot option -> public_key comparable_ty +val key_key : public_key comparable_ty -val timestamp_key : annot:type_annot option -> Script_timestamp.t comparable_ty +val timestamp_key : Script_timestamp.t comparable_ty -val chain_id_key : annot:type_annot option -> Script_chain_id.t comparable_ty +val chain_id_key : Script_chain_id.t comparable_ty -val address_key : annot:type_annot option -> address comparable_ty +val address_key : address comparable_ty val pair_key : Script.location -> 'a comparable_ty * field_annot option -> 'b comparable_ty * field_annot option -> - annot:type_annot option -> ('a, 'b) pair comparable_ty tzresult val pair_3_key : @@ -269,14 +268,10 @@ val union_key : Script.location -> 'a comparable_ty * field_annot option -> 'b comparable_ty * field_annot option -> - annot:type_annot option -> ('a, 'b) union comparable_ty tzresult val option_key : - Script.location -> - 'v comparable_ty -> - annot:type_annot option -> - 'v option comparable_ty tzresult + Script.location -> 'v comparable_ty -> 'v option comparable_ty tzresult module type Boxed_set_OPS = sig type t @@ -1541,55 +1536,48 @@ val ty_size : 'a ty -> 'a Type_size.t val comparable_ty_size : 'a comparable_ty -> 'a Type_size.t -val unit_t : annot:type_annot option -> unit ty +val unit_t : unit ty -val int_t : annot:type_annot option -> z num ty +val int_t : z num ty -val nat_t : annot:type_annot option -> n num ty +val nat_t : n num ty -val signature_t : annot:type_annot option -> signature ty +val signature_t : signature ty -val string_t : annot:type_annot option -> Script_string.t ty +val string_t : Script_string.t ty -val bytes_t : annot:type_annot option -> Bytes.t ty +val bytes_t : Bytes.t ty -val mutez_t : annot:type_annot option -> Tez.t ty +val mutez_t : Tez.t ty -val key_hash_t : annot:type_annot option -> public_key_hash ty +val key_hash_t : public_key_hash ty -val key_t : annot:type_annot option -> public_key ty +val key_t : public_key ty -val timestamp_t : annot:type_annot option -> Script_timestamp.t ty +val timestamp_t : Script_timestamp.t ty -val address_t : annot:type_annot option -> address ty +val address_t : address ty -val bool_t : annot:type_annot option -> bool ty +val bool_t : bool ty val pair_t : Script.location -> 'a ty * field_annot option -> 'b ty * field_annot option -> - annot:type_annot option -> ('a, 'b) pair ty tzresult val union_t : Script.location -> 'a ty * field_annot option -> 'b ty * field_annot option -> - annot:type_annot option -> ('a, 'b) union ty tzresult val union_bytes_bool_t : (Bytes.t, bool) union ty val lambda_t : - Script.location -> - 'arg ty -> - 'ret ty -> - annot:type_annot option -> - ('arg, 'ret) lambda ty tzresult + Script.location -> 'arg ty -> 'ret ty -> ('arg, 'ret) lambda ty tzresult -val option_t : - Script.location -> 'v ty -> annot:type_annot option -> 'v option ty tzresult +val option_t : Script.location -> 'v ty -> 'v option ty tzresult (* the quote is used to indicate where the annotation will go *) @@ -1613,71 +1601,44 @@ val option_pair_int'_nat_t : _ ty_metadata -> (z num, n num) pair option ty val option_pair_int_nat'_t : _ ty_metadata -> (z num, n num) pair option ty -val list_t : - Script.location -> - 'v ty -> - annot:type_annot option -> - 'v boxed_list ty tzresult +val list_t : Script.location -> 'v ty -> 'v boxed_list ty tzresult val list_operation_t : operation boxed_list ty -val set_t : - Script.location -> - 'v comparable_ty -> - annot:type_annot option -> - 'v set ty tzresult +val set_t : Script.location -> 'v comparable_ty -> 'v set ty tzresult val map_t : - Script.location -> - 'k comparable_ty -> - 'v ty -> - annot:type_annot option -> - ('k, 'v) map ty tzresult + Script.location -> 'k comparable_ty -> 'v ty -> ('k, 'v) map ty tzresult val big_map_t : - Script.location -> - 'k comparable_ty -> - 'v ty -> - annot:type_annot option -> - ('k, 'v) big_map ty tzresult + Script.location -> 'k comparable_ty -> 'v ty -> ('k, 'v) big_map ty tzresult -val contract_t : - Script.location -> - 'arg ty -> - annot:type_annot option -> - 'arg typed_contract ty tzresult +val contract_t : Script.location -> 'arg ty -> 'arg typed_contract ty tzresult val contract_unit_t : unit typed_contract ty val sapling_transaction_t : - memo_size:Sapling.Memo_size.t -> - annot:type_annot option -> - Sapling.transaction ty + memo_size:Sapling.Memo_size.t -> Sapling.transaction ty -val sapling_state_t : - memo_size:Sapling.Memo_size.t -> annot:type_annot option -> Sapling.state ty +val sapling_state_t : memo_size:Sapling.Memo_size.t -> Sapling.state ty -val operation_t : annot:type_annot option -> operation ty +val operation_t : operation ty -val chain_id_t : annot:type_annot option -> Script_chain_id.t ty +val chain_id_t : Script_chain_id.t ty -val never_t : annot:type_annot option -> never ty +val never_t : never ty -val bls12_381_g1_t : annot:type_annot option -> Script_bls.G1.t ty +val bls12_381_g1_t : Script_bls.G1.t ty -val bls12_381_g2_t : annot:type_annot option -> Script_bls.G2.t ty +val bls12_381_g2_t : Script_bls.G2.t ty -val bls12_381_fr_t : annot:type_annot option -> Script_bls.Fr.t ty +val bls12_381_fr_t : Script_bls.Fr.t ty -val ticket_t : - Script.location -> - 'a comparable_ty -> - annot:type_annot option -> - 'a ticket ty tzresult +val ticket_t : Script.location -> 'a comparable_ty -> 'a ticket ty tzresult -val chest_key_t : annot:type_annot option -> Script_timelock.chest_key ty +val chest_key_t : Script_timelock.chest_key ty -val chest_t : annot:type_annot option -> Script_timelock.chest ty +val chest_t : Script_timelock.chest ty (** diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index 2950658c7c9d..a87dfa951d57 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -33,7 +33,7 @@ let script_string_size s = Script_string.to_string s |> string_size let sapling_memo_size_size = !!0 let (comparable_ty_size, ty_size) = - let base {annot = _; size = _} = hh3w in + let base _meta = hh3w in let apply_comparable : type a. nodes_and_size -> a comparable_ty -> nodes_and_size = fun accu cty -> diff --git a/src/proto_alpha/lib_protocol/ticket_balance_key.ml b/src/proto_alpha/lib_protocol/ticket_balance_key.ml index 27361b8bd3cb..f31909155e27 100644 --- a/src/proto_alpha/lib_protocol/ticket_balance_key.ml +++ b/src/proto_alpha/lib_protocol/ticket_balance_key.ml @@ -50,11 +50,10 @@ let ticket_balance_key ctxt ~owner let owner_address = Script_typed_ir.{contract = owner; entrypoint = Entrypoint.default} in - let address_t = Script_typed_ir.address_t ~annot:None in Script_ir_translator.unparse_data ctxt Script_ir_translator.Optimized_legacy - address_t + Script_typed_ir.address_t ticketer_address >>=? fun (ticketer, ctxt) -> Script_ir_translator.unparse_comparable_data @@ -67,7 +66,7 @@ let ticket_balance_key ctxt ~owner Script_ir_translator.unparse_data ctxt Script_ir_translator.Optimized_legacy - address_t + Script_typed_ir.address_t owner_address >>=? fun (owner, ctxt) -> Lwt.return (Ticket_hash.make ctxt ~ticketer ~typ ~contents ~owner) -- GitLab From de4a81c2b4cbdc40f346d364613735cda5eb521b Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 11 Jan 2021 14:11:55 +0100 Subject: [PATCH 02/23] Proto/Plugin: remove type annot from type metadata --- src/proto_alpha/lib_plugin/plugin.ml | 155 +++++++++++++-------------- 1 file changed, 72 insertions(+), 83 deletions(-) diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index 1270254f0ffb..bc86d0369964 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -2,7 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Nomadic Development. *) -(* Copyright (c) 2021 Nomadic Labs, *) +(* Copyright (c) 2021-2022 Nomadic Labs, *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -1921,43 +1921,38 @@ module RPC = struct type a loc. loc:loc -> a comparable_ty -> (loc, Script.prim) Micheline.node = fun ~loc -> function - | Unit_key meta -> Prim (loc, T_unit, [], unparse_type_annot meta.annot) - | Never_key meta -> - Prim (loc, T_never, [], unparse_type_annot meta.annot) - | Int_key meta -> Prim (loc, T_int, [], unparse_type_annot meta.annot) - | Nat_key meta -> Prim (loc, T_nat, [], unparse_type_annot meta.annot) - | Signature_key meta -> - Prim (loc, T_signature, [], unparse_type_annot meta.annot) - | String_key meta -> - Prim (loc, T_string, [], unparse_type_annot meta.annot) - | Bytes_key meta -> - Prim (loc, T_bytes, [], unparse_type_annot meta.annot) - | Mutez_key meta -> - Prim (loc, T_mutez, [], unparse_type_annot meta.annot) - | Bool_key meta -> Prim (loc, T_bool, [], unparse_type_annot meta.annot) - | Key_hash_key meta -> - Prim (loc, T_key_hash, [], unparse_type_annot meta.annot) - | Key_key meta -> Prim (loc, T_key, [], unparse_type_annot meta.annot) - | Timestamp_key meta -> - Prim (loc, T_timestamp, [], unparse_type_annot meta.annot) - | Address_key meta -> - Prim (loc, T_address, [], unparse_type_annot meta.annot) - | Chain_id_key meta -> - Prim (loc, T_chain_id, [], unparse_type_annot meta.annot) - | Pair_key ((l, al), (r, ar), meta) -> + | Unit_key _meta -> Prim (loc, T_unit, [], unparse_type_annot None) + | Never_key _meta -> Prim (loc, T_never, [], unparse_type_annot None) + | Int_key _meta -> Prim (loc, T_int, [], unparse_type_annot None) + | Nat_key _meta -> Prim (loc, T_nat, [], unparse_type_annot None) + | Signature_key _meta -> + Prim (loc, T_signature, [], unparse_type_annot None) + | String_key _meta -> Prim (loc, T_string, [], unparse_type_annot None) + | Bytes_key _meta -> Prim (loc, T_bytes, [], unparse_type_annot None) + | Mutez_key _meta -> Prim (loc, T_mutez, [], unparse_type_annot None) + | Bool_key _meta -> Prim (loc, T_bool, [], unparse_type_annot None) + | Key_hash_key _meta -> + Prim (loc, T_key_hash, [], unparse_type_annot None) + | Key_key _meta -> Prim (loc, T_key, [], unparse_type_annot None) + | Timestamp_key _meta -> + Prim (loc, T_timestamp, [], unparse_type_annot None) + | Address_key _meta -> Prim (loc, T_address, [], unparse_type_annot None) + | Chain_id_key _meta -> + Prim (loc, T_chain_id, [], unparse_type_annot None) + | Pair_key ((l, al), (r, ar), _meta) -> let tl = add_field_annot al (unparse_comparable_ty ~loc l) in let tr = add_field_annot ar (unparse_comparable_ty ~loc r) in - Prim (loc, T_pair, [tl; tr], unparse_type_annot meta.annot) - | Union_key ((l, al), (r, ar), meta) -> + Prim (loc, T_pair, [tl; tr], unparse_type_annot None) + | Union_key ((l, al), (r, ar), _meta) -> let tl = add_field_annot al (unparse_comparable_ty ~loc l) in let tr = add_field_annot ar (unparse_comparable_ty ~loc r) in - Prim (loc, T_or, [tl; tr], unparse_type_annot meta.annot) - | Option_key (t, meta) -> + Prim (loc, T_or, [tl; tr], unparse_type_annot None) + | Option_key (t, _meta) -> Prim ( loc, T_option, [unparse_comparable_ty ~loc t], - unparse_type_annot meta.annot ) + unparse_type_annot None ) let unparse_memo_size ~loc memo_size = let z = Alpha_context.Sapling.Memo_size.unparse_to_z memo_size in @@ -1968,87 +1963,81 @@ module RPC = struct fun ~loc ty -> let return (name, args, annot) = Prim (loc, name, args, annot) in match ty with - | Unit_t meta -> return (T_unit, [], unparse_type_annot meta.annot) - | Int_t meta -> return (T_int, [], unparse_type_annot meta.annot) - | Nat_t meta -> return (T_nat, [], unparse_type_annot meta.annot) - | Signature_t meta -> - return (T_signature, [], unparse_type_annot meta.annot) - | String_t meta -> return (T_string, [], unparse_type_annot meta.annot) - | Bytes_t meta -> return (T_bytes, [], unparse_type_annot meta.annot) - | Mutez_t meta -> return (T_mutez, [], unparse_type_annot meta.annot) - | Bool_t meta -> return (T_bool, [], unparse_type_annot meta.annot) - | Key_hash_t meta -> - return (T_key_hash, [], unparse_type_annot meta.annot) - | Key_t meta -> return (T_key, [], unparse_type_annot meta.annot) - | Timestamp_t meta -> - return (T_timestamp, [], unparse_type_annot meta.annot) - | Address_t meta -> return (T_address, [], unparse_type_annot meta.annot) - | Operation_t meta -> - return (T_operation, [], unparse_type_annot meta.annot) - | Chain_id_t meta -> - return (T_chain_id, [], unparse_type_annot meta.annot) - | Never_t meta -> return (T_never, [], unparse_type_annot meta.annot) - | Bls12_381_g1_t meta -> - return (T_bls12_381_g1, [], unparse_type_annot meta.annot) - | Bls12_381_g2_t meta -> - return (T_bls12_381_g2, [], unparse_type_annot meta.annot) - | Bls12_381_fr_t meta -> - return (T_bls12_381_fr, [], unparse_type_annot meta.annot) - | Contract_t (ut, meta) -> + | Unit_t _meta -> return (T_unit, [], unparse_type_annot None) + | Int_t _meta -> return (T_int, [], unparse_type_annot None) + | Nat_t _meta -> return (T_nat, [], unparse_type_annot None) + | Signature_t _meta -> return (T_signature, [], unparse_type_annot None) + | String_t _meta -> return (T_string, [], unparse_type_annot None) + | Bytes_t _meta -> return (T_bytes, [], unparse_type_annot None) + | Mutez_t _meta -> return (T_mutez, [], unparse_type_annot None) + | Bool_t _meta -> return (T_bool, [], unparse_type_annot None) + | Key_hash_t _meta -> return (T_key_hash, [], unparse_type_annot None) + | Key_t _meta -> return (T_key, [], unparse_type_annot None) + | Timestamp_t _meta -> return (T_timestamp, [], unparse_type_annot None) + | Address_t _meta -> return (T_address, [], unparse_type_annot None) + | Operation_t _meta -> return (T_operation, [], unparse_type_annot None) + | Chain_id_t _meta -> return (T_chain_id, [], unparse_type_annot None) + | Never_t _meta -> return (T_never, [], unparse_type_annot None) + | Bls12_381_g1_t _meta -> + return (T_bls12_381_g1, [], unparse_type_annot None) + | Bls12_381_g2_t _meta -> + return (T_bls12_381_g2, [], unparse_type_annot None) + | Bls12_381_fr_t _meta -> + return (T_bls12_381_fr, [], unparse_type_annot None) + | Contract_t (ut, _meta) -> let t = unparse_ty ~loc ut in - return (T_contract, [t], unparse_type_annot meta.annot) - | Pair_t ((utl, l_field), (utr, r_field), meta) -> - let annot = unparse_type_annot meta.annot in + return (T_contract, [t], unparse_type_annot None) + | Pair_t ((utl, l_field), (utr, r_field), _meta) -> + let annot = unparse_type_annot None in let utl = unparse_ty ~loc utl in let tl = add_field_annot l_field utl in let utr = unparse_ty ~loc utr in let tr = add_field_annot r_field utr in return (T_pair, [tl; tr], annot) - | Union_t ((utl, l_field), (utr, r_field), meta) -> - let annot = unparse_type_annot meta.annot in + | Union_t ((utl, l_field), (utr, r_field), _meta) -> + let annot = unparse_type_annot None in let utl = unparse_ty ~loc utl in let tl = add_field_annot l_field utl in let utr = unparse_ty ~loc utr in let tr = add_field_annot r_field utr in return (T_or, [tl; tr], annot) - | Lambda_t (uta, utr, meta) -> + | Lambda_t (uta, utr, _meta) -> let ta = unparse_ty ~loc uta in let tr = unparse_ty ~loc utr in - return (T_lambda, [ta; tr], unparse_type_annot meta.annot) - | Option_t (ut, meta) -> - let annot = unparse_type_annot meta.annot in + return (T_lambda, [ta; tr], unparse_type_annot None) + | Option_t (ut, _meta) -> + let annot = unparse_type_annot None in let ut = unparse_ty ~loc ut in return (T_option, [ut], annot) - | List_t (ut, meta) -> + | List_t (ut, _meta) -> let t = unparse_ty ~loc ut in - return (T_list, [t], unparse_type_annot meta.annot) - | Ticket_t (ut, meta) -> + return (T_list, [t], unparse_type_annot None) + | Ticket_t (ut, _meta) -> let t = unparse_comparable_ty ~loc ut in - return (T_ticket, [t], unparse_type_annot meta.annot) - | Set_t (ut, meta) -> + return (T_ticket, [t], unparse_type_annot None) + | Set_t (ut, _meta) -> let t = unparse_comparable_ty ~loc ut in - return (T_set, [t], unparse_type_annot meta.annot) - | Map_t (uta, utr, meta) -> + return (T_set, [t], unparse_type_annot None) + | Map_t (uta, utr, _meta) -> let ta = unparse_comparable_ty ~loc uta in let tr = unparse_ty ~loc utr in - return (T_map, [ta; tr], unparse_type_annot meta.annot) - | Big_map_t (uta, utr, meta) -> + return (T_map, [ta; tr], unparse_type_annot None) + | Big_map_t (uta, utr, _meta) -> let ta = unparse_comparable_ty ~loc uta in let tr = unparse_ty ~loc utr in - return (T_big_map, [ta; tr], unparse_type_annot meta.annot) - | Sapling_transaction_t (memo_size, meta) -> + return (T_big_map, [ta; tr], unparse_type_annot None) + | Sapling_transaction_t (memo_size, _meta) -> return ( T_sapling_transaction, [unparse_memo_size ~loc memo_size], - unparse_type_annot meta.annot ) - | Sapling_state_t (memo_size, meta) -> + unparse_type_annot None ) + | Sapling_state_t (memo_size, _meta) -> return ( T_sapling_state, [unparse_memo_size ~loc memo_size], - unparse_type_annot meta.annot ) - | Chest_t meta -> return (T_chest, [], unparse_type_annot meta.annot) - | Chest_key_t meta -> - return (T_chest_key, [], unparse_type_annot meta.annot) + unparse_type_annot None ) + | Chest_t _meta -> return (T_chest, [], unparse_type_annot None) + | Chest_key_t _meta -> return (T_chest_key, [], unparse_type_annot None) end let run_operation_service ctxt () -- GitLab From 635b496e708203d6b375a0a71bf7fc8a6617f0d2 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 11 Jan 2021 14:11:55 +0100 Subject: [PATCH 03/23] Proto/Benchmarks: remove type annot from type metadata --- .../lib_benchmark/michelson_samplers.ml | 101 +++++++++--------- .../interpreter_benchmarks.ml | 15 +-- .../lib_benchmarks_proto/michelson_types.ml | 78 ++++++-------- .../translator_benchmarks.ml | 14 +-- 4 files changed, 96 insertions(+), 112 deletions(-) diff --git a/src/proto_alpha/lib_benchmark/michelson_samplers.ml b/src/proto_alpha/lib_benchmark/michelson_samplers.ml index fc28a39a99c7..a00f7ec10088 100644 --- a/src/proto_alpha/lib_benchmark/michelson_samplers.ml +++ b/src/proto_alpha/lib_benchmark/michelson_samplers.ml @@ -289,43 +289,42 @@ end) let type_of_atomic_type_name (at_tn : atomic_type_name) : Script_ir_translator.ex_ty = match at_tn with - | `TString -> Ex_ty (string_t ~annot:None) - | `TNat -> Ex_ty (nat_t ~annot:None) - | `TKey -> Ex_ty (key_t ~annot:None) - | `TBytes -> Ex_ty (bytes_t ~annot:None) - | `TBool -> Ex_ty (bool_t ~annot:None) - | `TAddress -> Ex_ty (address_t ~annot:None) - | `TTimestamp -> Ex_ty (timestamp_t ~annot:None) - | `TKey_hash -> Ex_ty (key_hash_t ~annot:None) - | `TMutez -> Ex_ty (mutez_t ~annot:None) - | `TSignature -> Ex_ty (signature_t ~annot:None) - | `TUnit -> Ex_ty (unit_t ~annot:None) - | `TInt -> Ex_ty (int_t ~annot:None) - | `TSapling_state -> Ex_ty (sapling_state_t ~memo_size ~annot:None) - | `TSapling_transaction -> - Ex_ty (sapling_transaction_t ~memo_size ~annot:None) - | `TChain_id -> Ex_ty (chain_id_t ~annot:None) - | `TBls12_381_g1 -> Ex_ty (bls12_381_g1_t ~annot:None) - | `TBls12_381_g2 -> Ex_ty (bls12_381_g2_t ~annot:None) - | `TBls12_381_fr -> Ex_ty (bls12_381_fr_t ~annot:None) + | `TString -> Ex_ty string_t + | `TNat -> Ex_ty nat_t + | `TKey -> Ex_ty key_t + | `TBytes -> Ex_ty bytes_t + | `TBool -> Ex_ty bool_t + | `TAddress -> Ex_ty address_t + | `TTimestamp -> Ex_ty timestamp_t + | `TKey_hash -> Ex_ty key_hash_t + | `TMutez -> Ex_ty mutez_t + | `TSignature -> Ex_ty signature_t + | `TUnit -> Ex_ty unit_t + | `TInt -> Ex_ty int_t + | `TSapling_state -> Ex_ty (sapling_state_t ~memo_size) + | `TSapling_transaction -> Ex_ty (sapling_transaction_t ~memo_size) + | `TChain_id -> Ex_ty chain_id_t + | `TBls12_381_g1 -> Ex_ty bls12_381_g1_t + | `TBls12_381_g2 -> Ex_ty bls12_381_g2_t + | `TBls12_381_fr -> Ex_ty bls12_381_fr_t let comparable_type_of_comparable_atomic_type_name (cmp_tn : 'a comparable_and_atomic) : Script_ir_translator.ex_comparable_ty = match cmp_tn with - | `TString -> Ex_comparable_ty (string_key ~annot:None) - | `TNat -> Ex_comparable_ty (nat_key ~annot:None) - | `TBytes -> Ex_comparable_ty (bytes_key ~annot:None) - | `TBool -> Ex_comparable_ty (bool_key ~annot:None) - | `TAddress -> Ex_comparable_ty (address_key ~annot:None) - | `TTimestamp -> Ex_comparable_ty (timestamp_key ~annot:None) - | `TKey_hash -> Ex_comparable_ty (key_hash_key ~annot:None) - | `TMutez -> Ex_comparable_ty (mutez_key ~annot:None) - | `TInt -> Ex_comparable_ty (int_key ~annot:None) - | `TUnit -> Ex_comparable_ty (unit_key ~annot:None) - | `TSignature -> Ex_comparable_ty (signature_key ~annot:None) - | `TKey -> Ex_comparable_ty (key_key ~annot:None) - | `TChain_id -> Ex_comparable_ty (chain_id_key ~annot:None) + | `TString -> Ex_comparable_ty string_key + | `TNat -> Ex_comparable_ty nat_key + | `TBytes -> Ex_comparable_ty bytes_key + | `TBool -> Ex_comparable_ty bool_key + | `TAddress -> Ex_comparable_ty address_key + | `TTimestamp -> Ex_comparable_ty timestamp_key + | `TKey_hash -> Ex_comparable_ty key_hash_key + | `TMutez -> Ex_comparable_ty mutez_key + | `TInt -> Ex_comparable_ty int_key + | `TUnit -> Ex_comparable_ty unit_key + | `TSignature -> Ex_comparable_ty signature_key + | `TKey -> Ex_comparable_ty key_key + | `TChain_id -> Ex_comparable_ty chain_id_key let rec m_type ~size : Script_ir_translator.ex_ty sampler = let open Script_ir_translator in @@ -340,27 +339,27 @@ end) @@ function | `TOption -> ( let* (Ex_ty t) = m_type ~size:1 in - match option_t (-1) t ~annot:None with + match option_t (-1) t with | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TList -> ( let* (Ex_ty t) = m_type ~size:1 in - match list_t (-1) t ~annot:None with + match list_t (-1) t with | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TSet -> ( let* (Ex_comparable_ty t) = m_comparable_type ~size:1 in - match set_t (-1) t ~annot:None with + match set_t (-1) t with | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TTicket -> ( let* (Ex_comparable_ty contents) = m_comparable_type ~size:1 in - match ticket_t (-1) contents ~annot:None with + match ticket_t (-1) contents with | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TContract -> ( let* (Ex_ty t) = m_type ~size:1 in - match contract_t (-1) t ~annot:None with + match contract_t (-1) t with | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) else @@ -369,57 +368,57 @@ end) let* (lsize, rsize) = pick_split (size - 1) in let* (Ex_ty left) = m_type ~size:lsize in let* (Ex_ty right) = m_type ~size:rsize in - match pair_t (-1) (left, None) (right, None) ~annot:None with + match pair_t (-1) (left, None) (right, None) with | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TLambda -> ( let* (lsize, rsize) = pick_split (size - 1) in let* (Ex_ty domain) = m_type ~size:lsize in let* (Ex_ty range) = m_type ~size:rsize in - match lambda_t (-1) domain range ~annot:None with + match lambda_t (-1) domain range with | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TUnion -> ( let* (lsize, rsize) = pick_split (size - 1) in let* (Ex_ty left) = m_type ~size:lsize in let* (Ex_ty right) = m_type ~size:rsize in - match union_t (-1) (left, None) (right, None) ~annot:None with + match union_t (-1) (left, None) (right, None) with | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TOption -> ( let* (Ex_ty t) = m_type ~size:(size - 1) in - match option_t (-1) t ~annot:None with + match option_t (-1) t with | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TMap -> ( let* (lsize, rsize) = pick_split (size - 1) in let* (Ex_comparable_ty key) = m_comparable_type ~size:lsize in let* (Ex_ty elt) = m_type ~size:rsize in - match map_t (-1) key elt ~annot:None with + match map_t (-1) key elt with | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TSet -> ( let* (Ex_comparable_ty key_ty) = m_comparable_type ~size:(size - 1) in - match set_t (-1) key_ty ~annot:None with + match set_t (-1) key_ty with | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TList -> ( let* (Ex_ty elt) = m_type ~size:(size - 1) in - match list_t (-1) elt ~annot:None with + match list_t (-1) elt with | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TTicket -> ( let* (Ex_comparable_ty contents) = m_comparable_type ~size:(size - 1) in - match ticket_t (-1) contents ~annot:None with + match ticket_t (-1) contents with | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TContract -> ( let* (Ex_ty t) = m_type ~size:(size - 1) in - match contract_t (-1) t ~annot:None with + match contract_t (-1) t with | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TBig_map -> @@ -437,7 +436,7 @@ end) let option_case size = let size = size - 1 in let* (Ex_comparable_ty t) = m_comparable_type ~size in - match option_key (-1) t ~annot:None with + match option_key (-1) t with | Error _ -> (* what should be done here? *) assert false | Ok res_ty -> return @@ Ex_comparable_ty res_ty in @@ -449,7 +448,7 @@ end) let size_right = size - size_left in let* (Ex_comparable_ty l) = m_comparable_type ~size:size_left in let* (Ex_comparable_ty r) = m_comparable_type ~size:size_right in - match pair_key (-1) (l, None) (r, None) ~annot:None with + match pair_key (-1) (l, None) (r, None) with | Error _ -> assert false | Ok res_ty -> return @@ Ex_comparable_ty res_ty in @@ -461,7 +460,7 @@ end) let size_right = size - size_left in let* (Ex_comparable_ty l) = m_comparable_type ~size:size_left in let* (Ex_comparable_ty r) = m_comparable_type ~size:size_right in - match union_key (-1) (l, None) (r, None) ~annot:None with + match union_key (-1) (l, None) (r, None) with | Error _ -> assert false | Ok res_ty -> return @@ Ex_comparable_ty res_ty in @@ -640,7 +639,7 @@ end) ( Execution_context.make ~rng_state >>=? fun (ctxt, _) -> let big_map = Script_ir_translator.empty_big_map key_ty elt_ty in (* Cannot have big maps under big maps *) - option_t (-1) elt_ty ~annot:None |> Environment.wrap_tzresult + option_t (-1) elt_ty |> Environment.wrap_tzresult >>?= fun opt_elt_ty -> let map = generate_map key_ty opt_elt_ty rng_state in Script_map.fold @@ -666,7 +665,7 @@ end) arg Script_typed_ir.ty -> arg Script_typed_ir.typed_contract sampler = fun arg_ty -> let open M in - let* address = value (address_t ~annot:None) in + let* address = value address_t in return {arg_ty; address} and generate_operation : Script_typed_ir.operation sampler = diff --git a/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml index c89d4241b008..b7cd662b07a8 100644 --- a/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml @@ -1421,7 +1421,7 @@ module Registration_section = struct (Lwt_main.run ( Execution_context.make ~rng_state >>=? fun (ctxt, _) -> let big_map = - Script_ir_translator.empty_big_map int_cmp (unit_t ~annot:None) + Script_ir_translator.empty_big_map int_cmp unit_t in Script_map.fold (fun k v acc -> @@ -1558,9 +1558,7 @@ module Registration_section = struct let (_, (module Samplers)) = make_default_samplers cfg.sampler in fun () -> let string = - Samplers.Random_value.value - Script_typed_ir.(string_t ~annot:None) - rng_state + Samplers.Random_value.value Script_typed_ir.string_t rng_state in let len = nat_of_positive_int (length string) in (* worst case: offset = 0 *) @@ -1606,9 +1604,7 @@ module Registration_section = struct let (_, (module Samplers)) = make_default_samplers cfg.sampler in fun () -> let bytes = - Samplers.Random_value.value - Script_typed_ir.(bytes_t ~annot:None) - rng_state + Samplers.Random_value.value Script_typed_ir.bytes_t rng_state in let len = nat_of_positive_int (Bytes.length bytes) in (* worst case: offset = 0 *) @@ -2279,10 +2275,7 @@ module Registration_section = struct let (_pkh, pk, sk) = Crypto_samplers.all rng_state in let unsigned_message = if for_intercept then Environment.Bytes.empty - else - Samplers.Random_value.value - Script_typed_ir.(bytes_t ~annot:None) - rng_state + else Samplers.Random_value.value Script_typed_ir.bytes_t rng_state in let signed_message = Signature.sign sk unsigned_message in let signed_message = Script_signature.make signed_message in diff --git a/src/proto_alpha/lib_benchmarks_proto/michelson_types.ml b/src/proto_alpha/lib_benchmarks_proto/michelson_types.ml index 5569ca6340da..9befe5633745 100644 --- a/src/proto_alpha/lib_benchmarks_proto/michelson_types.ml +++ b/src/proto_alpha/lib_benchmarks_proto/michelson_types.ml @@ -1,7 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) +(* Copyright (c) 2021-2022 Nomadic Labs, *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -32,107 +32,99 @@ let ( @$ ) x y = Item_t (x, y) let bot = Bot_t -let unit = unit_t ~annot:None +let unit = unit_t -let unit_cmp = unit_key ~annot:None +let unit_cmp = unit_key -let int_cmp = int_key ~annot:None +let int_cmp = int_key -let string_cmp = string_key ~annot:None +let string_cmp = string_key (* the type of integers *) -let int = int_t ~annot:None +let int = int_t (* the type of naturals *) -let nat = nat_t ~annot:None +let nat = nat_t (* the type of strings *) -let string = string_t ~annot:None +let string = string_t (* the type of bytes *) -let bytes = bytes_t ~annot:None +let bytes = bytes_t (* the type of booleans *) -let bool = bool_t ~annot:None +let bool = bool_t (* the type of mutez *) -let mutez = mutez_t ~annot:None +let mutez = mutez_t (* the type of public key *) -let public_key = key_t ~annot:None +let public_key = key_t (* the type of key hashes *) -let key_hash = key_hash_t ~annot:None +let key_hash = key_hash_t (* the type of signatures *) -let signature = signature_t ~annot:None +let signature = signature_t (* the type of addresses *) -let address = address_t ~annot:None +let address = address_t (* the type of chain ids *) -let chain_id = chain_id_t ~annot:None +let chain_id = chain_id_t (* the type of timestamps *) -let timestamp = timestamp_t ~annot:None +let timestamp = timestamp_t (* list type constructor *) -let list x = - match list_t (-1) x ~annot:None with Error _ -> assert false | Ok t -> t +let list x = match list_t (-1) x with Error _ -> assert false | Ok t -> t (* option type constructor *) -let option x = - match option_t (-1) x ~annot:None with Error _ -> assert false | Ok t -> t +let option x = match option_t (-1) x with Error _ -> assert false | Ok t -> t (* map type constructor*) -let map k v = - match map_t (-1) k v ~annot:None with Error _ -> assert false | Ok t -> t +let map k v = match map_t (-1) k v with Error _ -> assert false | Ok t -> t (* map type constructor*) let big_map k v = - match big_map_t (-1) k v ~annot:None with - | Error _ -> assert false - | Ok t -> t + match big_map_t (-1) k v with Error _ -> assert false | Ok t -> t (* set type constructor*) -let set k = - match set_t (-1) k ~annot:None with Error _ -> assert false | Ok t -> t +let set k = match set_t (-1) k with Error _ -> assert false | Ok t -> t (* pair type constructor*) let pair k1 k2 = - match pair_t (-1) (k1, None) (k2, None) ~annot:None with + match pair_t (-1) (k1, None) (k2, None) with | Error _ -> assert false | Ok t -> t (* union type constructor*) let union k1 k2 = - match union_t (-1) (k1, None) (k2, None) ~annot:None with + match union_t (-1) (k1, None) (k2, None) with | Error _ -> assert false | Ok t -> t let lambda x y = - match lambda_t (-1) x y ~annot:None with Error _ -> assert false | Ok t -> t + match lambda_t (-1) x y with Error _ -> assert false | Ok t -> t let contract arg_ty = - match contract_t (-1) arg_ty ~annot:None with - | Error _ -> assert false - | Ok t -> t + match contract_t (-1) arg_ty with Error _ -> assert false | Ok t -> t -let operation = operation_t ~annot:None +let operation = operation_t -let sapling_state memo_size = sapling_state_t ~memo_size ~annot:None +let sapling_state memo_size = sapling_state_t ~memo_size -let sapling_transaction memo_size = sapling_transaction_t ~memo_size ~annot:None +let sapling_transaction memo_size = sapling_transaction_t ~memo_size -let bls12_381_g1 = bls12_381_g1_t ~annot:None +let bls12_381_g1 = bls12_381_g1_t -let bls12_381_g2 = bls12_381_g2_t ~annot:None +let bls12_381_g2 = bls12_381_g2_t -let bls12_381_fr = bls12_381_fr_t ~annot:None +let bls12_381_fr = bls12_381_fr_t let ticket ty = - match ticket_t (-1) ty ~annot:None with Error _ -> assert false | Ok t -> t + match ticket_t (-1) ty with Error _ -> assert false | Ok t -> t -let chest_key = chest_key_t ~annot:None +let chest_key = chest_key_t -let chest = chest_t ~annot:None +let chest = chest_t diff --git a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml index 03c225cbce16..82eec3c31975 100644 --- a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml @@ -1,7 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) +(* Copyright (c) 2021-2022 Nomadic Labs, *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -619,13 +619,13 @@ let () = Registration_helpers.register (module Merge_types) let rec dummy_type_generator size = let open Script_ir_translator in let open Script_typed_ir in - if size <= 1 then Ex_ty (unit_t ~annot:None) + if size <= 1 then Ex_ty unit_t else match dummy_type_generator (size - 2) with | Ex_ty r -> - let l = unit_t ~annot:None in + let l = unit_t in Ex_ty - (match pair_t (-1) (l, None) (r, None) ~annot:None with + (match pair_t (-1) (l, None) (r, None) with | Error _ -> assert false | Ok t -> t) @@ -633,13 +633,13 @@ let rec dummy_type_generator size = let rec dummy_comparable_type_generator size = let open Script_ir_translator in let open Script_typed_ir in - if size <= 0 then Ex_comparable_ty (unit_key ~annot:None) + if size <= 0 then Ex_comparable_ty unit_key else match dummy_comparable_type_generator (size - 2) with | Ex_comparable_ty r -> - let l = unit_key ~annot:None in + let l = unit_key in Ex_comparable_ty - (match pair_key (-1) (l, None) (r, None) ~annot:None with + (match pair_key (-1) (l, None) (r, None) with | Error _ -> assert false | Ok t -> t) -- GitLab From d117c1a16616c3a6349349ba949decbdfb3e3728 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 11 Jan 2021 14:17:02 +0100 Subject: [PATCH 04/23] Proto/Tests: remove type_annot from type metadata --- .../test/helpers/lqt_fa12_repr.ml | 7 +- .../test/integration/gas/test_gas_costs.ml | 14 +- .../michelson/test_interpretation.ml | 35 ++++- .../integration/michelson/test_sapling.ml | 6 +- .../test_ticket_lazy_storage_diff.ml | 3 +- .../michelson/test_ticket_scanner.ml | 3 +- .../michelson/test_typechecking.ml | 140 +++++------------- .../test/pbt/test_script_comparison.ml | 4 +- 8 files changed, 83 insertions(+), 129 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml b/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml index 43c9dab4a1c5..8cdfa341d05c 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml @@ -1,7 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) +(* Copyright (c) 2021-2022 Nomadic Labs *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -216,10 +216,7 @@ module Storage = struct get ctxt ~contract >>=? fun storage -> let tokens = storage.tokens in get_alpha_context ctxt >>=? fun ctxt -> - Script_ir_translator.hash_data - ctxt - Script_typed_ir.(address_t ~annot:None) - owner + Script_ir_translator.hash_data ctxt Script_typed_ir.address_t owner >|= Environment.wrap_tzresult >>=? fun (address_hash, ctxt) -> Big_map.get_opt ctxt tokens address_hash >|= Environment.wrap_tzresult diff --git a/src/proto_alpha/lib_protocol/test/integration/gas/test_gas_costs.ml b/src/proto_alpha/lib_protocol/test/integration/gas/test_gas_costs.ml index e4a3baf1bb8d..ec6da065c02c 100644 --- a/src/proto_alpha/lib_protocol/test/integration/gas/test_gas_costs.ml +++ b/src/proto_alpha/lib_protocol/test/integration/gas/test_gas_costs.ml @@ -1,7 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs, *) +(* Copyright (c) 2020-2022 Nomadic Labs, *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -45,14 +45,11 @@ let forty_two_n = Alpha_context.Script_int.abs forty_two let dummy_set = let open Script_set in - update forty_two true (empty Script_typed_ir.(int_key ~annot:None)) + update forty_two true (empty Script_typed_ir.int_key) let dummy_map = let open Script_map in - update - forty_two - (Some forty_two) - (empty Script_typed_ir.(int_key ~annot:None)) + update forty_two (Some forty_two) (empty Script_typed_ir.int_key) let dummy_timestamp = Alpha_context.Script_timestamp.of_zint (Z.of_int 42) @@ -67,7 +64,7 @@ let dummy_string = | Ok s -> s | Error _ -> assert false -let dummy_ty = Script_typed_ir.never_t ~annot:None +let dummy_ty = Script_typed_ir.never_t let free = ["balance"; "bool"; "parsing_unit"; "unparsing_unit"] @@ -151,8 +148,7 @@ let all_interpreter_costs = ("dipn", dipn 42); ("dropn", dropn 42); ("neq", neq); - ( "compare", - compare Script_typed_ir.(int_key ~annot:None) forty_two forty_two ); + ("compare", compare Script_typed_ir.int_key forty_two forty_two); ( "concat_string_precheck", concat_string_precheck Script_list.(cons "42" empty) ); ("concat_string", concat_string (S.safe_int 42)); diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml index 2c48604f14c2..1ed116ede4a0 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml @@ -1,3 +1,28 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020-2022 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + (** Testing ------- Component: Protocol (interpretation) @@ -104,7 +129,7 @@ let test_stack_overflow () = let stack = Bot_t in let descr kinstr = {kloc = 0; kbef = stack; kaft = stack; kinstr} in let kinfo = {iloc = -1; kstack_ty = stack} in - let kinfo' = {iloc = -1; kstack_ty = Item_t (bool_t ~annot:None, stack)} in + let kinfo' = {iloc = -1; kstack_ty = Item_t (bool_t, stack)} in let enorme_et_seq n = let rec aux n acc = if n = 0 then acc @@ -133,10 +158,10 @@ let test_stack_overflow_in_lwt () = in let stack = Bot_t in let item ty s = Item_t (ty, s) in - let unit_t = unit_t ~annot:None in - let unit_k = unit_key ~annot:None in - let bool_t = bool_t ~annot:None in - big_map_t (-1) unit_k unit_t ~annot:None >>??= fun big_map_t -> + let unit_t = unit_t in + let unit_k = unit_key in + let bool_t = bool_t in + big_map_t (-1) unit_k unit_t >>??= fun big_map_t -> let descr kinstr = {kloc = 0; kbef = stack; kaft = stack; kinstr} in let kinfo s = {iloc = -1; kstack_ty = s} in let stack1 = item big_map_t Bot_t 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 4f0d28016c8e..ca327f466ec1 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 @@ -1,7 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs *) +(* Copyright (c) 2020-2022 Nomadic Labs *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -1003,8 +1003,8 @@ module Interpreter_tests = struct (let memo_size = memo_size_of_int memo_size in let open Script_typed_ir in - let state_ty = sapling_state_t ~memo_size ~annot:None in - pair_t (-1) (state_ty, None) (state_ty, None) ~annot:None) + let state_ty = sapling_state_t ~memo_size in + pair_t (-1) (state_ty, None) (state_ty, None)) >>??= fun tytype -> Script_ir_translator.parse_storage ctx_without_gas diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml index 836fc71e4e09..a421ad34a8a5 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml @@ -2,6 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2021 Trili Tech, *) +(* Copyright (c) 2022 Nomadic Labs, *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -111,7 +112,7 @@ let updates_of_key_values ctxt key_values = wrap (Script_ir_translator.hash_comparable_data ctxt - (Script_typed_ir.int_key ~annot:None) + Script_typed_ir.int_key (Script_int_repr.of_int key)) in return 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 9b7e38a2235a..de826ae3b328 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 @@ -2,6 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2021 Trili Tech, *) +(* Copyright (c) 2022 Nomadic Labs, *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -183,7 +184,7 @@ let tickets_from_big_map_ref ~pre_populated value_exp = wrap @@ Script_ir_translator.hash_comparable_data ctxt - (Script_typed_ir.int_key ~annot:None) + Script_typed_ir.int_key (Script_int_repr.of_int key) in return 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 ad265b4a7600..4ab80c5a7e8f 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 @@ -78,7 +78,7 @@ let test_context_with_nat_nat_big_map () = Incremental.begin_construction b >>=? fun v -> let ctxt = Incremental.alpha_ctxt v in wrap_error_lwt @@ Big_map.fresh ~temporary:false ctxt >>=? fun (ctxt, id) -> - let nat_ty = Script_typed_ir.nat_t ~annot:None in + let nat_ty = Script_typed_ir.nat_t in wrap_error_lwt @@ Lwt.return @@ Script_ir_translator.unparse_ty ~loc:() ctxt nat_ty >>=? fun (nat_ty_node, ctxt) -> @@ -190,9 +190,9 @@ let test_parse_comb_type () = let nat_prim_a = Prim (-1, T_nat, [], ["%a"]) in let nat_prim_b = Prim (-1, T_nat, [], ["%b"]) in let nat_prim_c = Prim (-1, T_nat, [], ["%c"]) in - let nat_ty = nat_t ~annot:None in + let nat_ty = nat_t in let pair_prim l = Prim (-1, T_pair, l, []) in - let pair_ty ty1 ty2 = pair_t (-1) (ty1, None) (ty2, None) ~annot:None in + let pair_ty ty1 ty2 = pair_t (-1) (ty1, None) (ty2, None) in let pair_prim2 a b = pair_prim [a; b] in let pair_nat_nat_prim = pair_prim2 nat_prim nat_prim in pair_ty nat_ty nat_ty >>??= fun pair_nat_nat_ty -> @@ -221,36 +221,24 @@ let test_parse_comb_type () = pair_nat_nat_nat_ty >>?= fun ctxt -> (* pair (nat %a) nat *) - pair_t (-1) (nat_ty, Some (field_annot "a")) (nat_ty, None) ~annot:None + pair_t (-1) (nat_ty, Some (field_annot "a")) (nat_ty, None) >>??= fun pair_nat_a_nat_ty -> test_parse_ty ctxt (pair_prim2 nat_prim_a nat_prim) pair_nat_a_nat_ty >>?= fun ctxt -> (* pair nat (nat %b) *) - pair_t (-1) (nat_ty, None) (nat_ty, Some (field_annot "b")) ~annot:None + pair_t (-1) (nat_ty, None) (nat_ty, Some (field_annot "b")) >>??= fun pair_nat_nat_b_ty -> test_parse_ty ctxt (pair_prim2 nat_prim nat_prim_b) pair_nat_nat_b_ty >>?= fun ctxt -> (* pair (nat %a) (nat %b) *) - pair_t - (-1) - (nat_ty, Some (field_annot "a")) - (nat_ty, Some (field_annot "b")) - ~annot:None + pair_t (-1) (nat_ty, Some (field_annot "a")) (nat_ty, Some (field_annot "b")) >>??= fun pair_nat_a_nat_b_ty -> test_parse_ty ctxt (pair_prim2 nat_prim_a nat_prim_b) pair_nat_a_nat_b_ty >>?= fun ctxt -> (* pair (nat %a) (nat %b) (nat %c) *) - pair_t - (-1) - (nat_ty, Some (field_annot "b")) - (nat_ty, Some (field_annot "c")) - ~annot:None + pair_t (-1) (nat_ty, Some (field_annot "b")) (nat_ty, Some (field_annot "c")) >>??= fun pair_nat_b_nat_c_ty -> - pair_t - (-1) - (nat_ty, Some (field_annot "a")) - (pair_nat_b_nat_c_ty, None) - ~annot:None + pair_t (-1) (nat_ty, Some (field_annot "a")) (pair_nat_b_nat_c_ty, None) >>??= fun pair_nat_a_nat_b_nat_c_ty -> test_parse_ty ctxt @@ -258,13 +246,11 @@ let test_parse_comb_type () = pair_nat_a_nat_b_nat_c_ty >>?= fun ctxt -> (* pair (nat %a) (pair %b nat nat) *) - pair_t (-1) (nat_ty, None) (nat_ty, None) ~annot:None - >>??= fun pair_b_nat_nat_ty -> + pair_t (-1) (nat_ty, None) (nat_ty, None) >>??= fun pair_b_nat_nat_ty -> pair_t (-1) (nat_ty, Some (field_annot "a")) (pair_b_nat_nat_ty, Some (field_annot "b")) - ~annot:None >>??= fun pair_nat_a_pair_b_nat_nat_ty -> test_parse_ty ctxt @@ -285,9 +271,9 @@ let test_unparse_comb_type () = let nat_prim_a = Prim ((), T_nat, [], ["%a"]) in let nat_prim_b = Prim ((), T_nat, [], ["%b"]) in let nat_prim_c = Prim ((), T_nat, [], ["%c"]) in - let nat_ty = nat_t ~annot:None in + let nat_ty = nat_t in let pair_prim l = Prim ((), T_pair, l, []) in - let pair_ty ty1 ty2 = pair_t (-1) (ty1, None) (ty2, None) ~annot:None in + let pair_ty ty1 ty2 = pair_t (-1) (ty1, None) (ty2, None) in let pair_prim2 a b = pair_prim [a; b] in let pair_nat_nat_prim = pair_prim2 nat_prim nat_prim in pair_ty nat_ty nat_ty >>??= fun pair_nat_nat_ty -> @@ -312,7 +298,7 @@ let test_unparse_comb_type () = pair_nat_nat_nat_ty >>?= fun ctxt -> (* pair (nat %a) nat *) - pair_t (-1) (nat_ty, Some (field_annot "a")) (nat_ty, None) ~annot:None + pair_t (-1) (nat_ty, Some (field_annot "a")) (nat_ty, None) >>??= fun pair_nat_a_nat_ty -> test_unparse_ty __LOC__ @@ -321,7 +307,7 @@ let test_unparse_comb_type () = pair_nat_a_nat_ty >>?= fun ctxt -> (* pair nat (nat %b) *) - pair_t (-1) (nat_ty, None) (nat_ty, Some (field_annot "b")) ~annot:None + pair_t (-1) (nat_ty, None) (nat_ty, Some (field_annot "b")) >>??= fun pair_nat_nat_b_ty -> test_unparse_ty __LOC__ @@ -330,11 +316,7 @@ let test_unparse_comb_type () = pair_nat_nat_b_ty >>?= fun ctxt -> (* pair (nat %a) (nat %b) *) - pair_t - (-1) - (nat_ty, Some (field_annot "a")) - (nat_ty, Some (field_annot "b")) - ~annot:None + pair_t (-1) (nat_ty, Some (field_annot "a")) (nat_ty, Some (field_annot "b")) >>??= fun pair_nat_a_nat_b_ty -> test_unparse_ty __LOC__ @@ -343,17 +325,9 @@ let test_unparse_comb_type () = pair_nat_a_nat_b_ty >>?= fun ctxt -> (* pair (nat %a) (nat %b) (nat %c) *) - pair_t - (-1) - (nat_ty, Some (field_annot "b")) - (nat_ty, Some (field_annot "c")) - ~annot:None + pair_t (-1) (nat_ty, Some (field_annot "b")) (nat_ty, Some (field_annot "c")) >>??= fun pair_nat_b_nat_c_ty -> - pair_t - (-1) - (nat_ty, Some (field_annot "a")) - (pair_nat_b_nat_c_ty, None) - ~annot:None + pair_t (-1) (nat_ty, Some (field_annot "a")) (pair_nat_b_nat_c_ty, None) >>??= fun pair_nat_a_nat_b_nat_c_ty -> test_unparse_ty __LOC__ @@ -362,30 +336,17 @@ let test_unparse_comb_type () = pair_nat_a_nat_b_nat_c_ty >>?= fun ctxt -> (* pair (nat %a) (pair %b nat nat) *) - pair_t (-1) (nat_ty, None) (nat_ty, None) ~annot:None - >>??= fun pair_nat_nat_ty -> + pair_t (-1) (nat_ty, None) (nat_ty, None) >>??= fun pair_nat_nat_ty -> pair_t (-1) (nat_ty, Some (field_annot "a")) (pair_nat_nat_ty, Some (field_annot "b")) - ~annot:None >>??= fun pair_nat_a_pair_b_nat_nat_ty -> test_unparse_ty __LOC__ ctxt (pair_prim2 nat_prim_a (Prim ((), T_pair, [nat_prim; nat_prim], ["%b"]))) pair_nat_a_pair_b_nat_nat_ty - >>?= fun ctxt -> - (* pair nat (pair :b nat nat) *) - pair_t (-1) (nat_ty, None) (nat_ty, None) ~annot:(Some (type_annot "b")) - >>??= fun pair_b_nat_nat_ty -> - pair_t (-1) (nat_ty, None) (pair_b_nat_nat_ty, None) ~annot:None - >>??= fun pair_nat_pair_b_nat_nat_ty -> - test_unparse_ty - __LOC__ - ctxt - (pair_prim2 nat_prim (Prim ((), T_pair, [nat_prim; nat_prim], [":b"]))) - pair_nat_pair_b_nat_nat_ty >>?= fun _ -> return_unit let test_unparse_comparable_ty loc ctxt expected ty = @@ -393,7 +354,7 @@ let test_unparse_comparable_ty loc ctxt expected ty = call parse_ty on a set type *) let open Script_typed_ir in Environment.wrap_tzresult - ( set_t (-1) ty ~annot:None >>? fun set_ty_ty -> + ( set_t (-1) ty >>? fun set_ty_ty -> Script_ir_translator.unparse_ty ~loc:() ctxt set_ty_ty >>? fun (actual, ctxt) -> if actual = Prim ((), T_set, [expected], []) then ok ctxt @@ -406,9 +367,9 @@ let test_unparse_comb_comparable_type () = let nat_prim_a = Prim ((), T_nat, [], ["%a"]) in let nat_prim_b = Prim ((), T_nat, [], ["%b"]) in let nat_prim_c = Prim ((), T_nat, [], ["%c"]) in - let nat_ty = nat_key ~annot:None in + let nat_ty = nat_key in let pair_prim l = Prim ((), T_pair, l, []) in - let pair_ty ty1 ty2 = pair_key (-1) (ty1, None) (ty2, None) ~annot:None in + let pair_ty ty1 ty2 = pair_key (-1) (ty1, None) (ty2, None) in let pair_prim2 a b = pair_prim [a; b] in let pair_nat_nat_prim = pair_prim2 nat_prim nat_prim in pair_ty nat_ty nat_ty >>??= fun pair_nat_nat_ty -> @@ -433,7 +394,7 @@ let test_unparse_comb_comparable_type () = pair_nat_nat_nat_ty >>?= fun ctxt -> (* pair (nat %a) nat *) - pair_key (-1) (nat_ty, Some (field_annot "a")) (nat_ty, None) ~annot:None + pair_key (-1) (nat_ty, Some (field_annot "a")) (nat_ty, None) >>??= fun pair_nat_a_nat_ty -> test_unparse_comparable_ty __LOC__ @@ -442,7 +403,7 @@ let test_unparse_comb_comparable_type () = pair_nat_a_nat_ty >>?= fun ctxt -> (* pair nat (nat %b) *) - pair_key (-1) (nat_ty, None) (nat_ty, Some (field_annot "b")) ~annot:None + pair_key (-1) (nat_ty, None) (nat_ty, Some (field_annot "b")) >>??= fun pair_nat_nat_b_ty -> test_unparse_comparable_ty __LOC__ @@ -451,11 +412,7 @@ let test_unparse_comb_comparable_type () = pair_nat_nat_b_ty >>?= fun ctxt -> (* pair (nat %a) (nat %b) *) - pair_key - (-1) - (nat_ty, Some (field_annot "a")) - (nat_ty, Some (field_annot "b")) - ~annot:None + pair_key (-1) (nat_ty, Some (field_annot "a")) (nat_ty, Some (field_annot "b")) >>??= fun pair_nat_a_nat_b_ty -> test_unparse_comparable_ty __LOC__ @@ -464,17 +421,9 @@ let test_unparse_comb_comparable_type () = pair_nat_a_nat_b_ty >>?= fun ctxt -> (* pair (nat %a) (nat %b) (nat %c) *) - pair_key - (-1) - (nat_ty, Some (field_annot "b")) - (nat_ty, Some (field_annot "c")) - ~annot:None + pair_key (-1) (nat_ty, Some (field_annot "b")) (nat_ty, Some (field_annot "c")) >>??= fun pair_nat_b_nat_c_ty -> - pair_key - (-1) - (nat_ty, Some (field_annot "a")) - (pair_nat_b_nat_c_ty, None) - ~annot:None + pair_key (-1) (nat_ty, Some (field_annot "a")) (pair_nat_b_nat_c_ty, None) >>??= fun pair_nat_a_nat_b_nat_c_ty -> test_unparse_comparable_ty __LOC__ @@ -487,24 +436,12 @@ let test_unparse_comb_comparable_type () = (-1) (nat_ty, Some (field_annot "a")) (pair_nat_nat_ty, Some (field_annot "b")) - ~annot:None >>??= fun pair_nat_a_pair_b_nat_nat_ty -> test_unparse_comparable_ty __LOC__ ctxt (pair_prim2 nat_prim_a (Prim ((), T_pair, [nat_prim; nat_prim], ["%b"]))) pair_nat_a_pair_b_nat_nat_ty - >>?= fun ctxt -> - (* pair nat (pair :b nat nat) *) - pair_key (-1) (nat_ty, None) (nat_ty, None) ~annot:(Some (type_annot "b")) - >>??= fun pair_b_nat_nat_ty -> - pair_key (-1) (nat_ty, None) (pair_b_nat_nat_ty, None) ~annot:None - >>??= fun pair_nat_pair_b_nat_nat_ty -> - test_unparse_comparable_ty - __LOC__ - ctxt - (pair_prim2 nat_prim (Prim ((), T_pair, [nat_prim; nat_prim], [":b"]))) - pair_nat_pair_b_nat_nat_ty >>?= fun _ -> return_unit let test_parse_data ?(equal = Stdlib.( = )) loc ctxt ty node expected = @@ -547,15 +484,14 @@ let test_parse_comb_data () = let open Script_typed_ir in let z = Script_int.zero_n in let z_prim = Micheline.Int (-1, Z.zero) in - let nat_ty = nat_t ~annot:None in + let nat_ty = nat_t in let pair_prim l = Prim (-1, D_Pair, l, []) in - let pair_ty ty1 ty2 = pair_t (-1) (ty1, None) (ty2, None) ~annot:None in + let pair_ty ty1 ty2 = pair_t (-1) (ty1, None) (ty2, None) in pair_ty nat_ty nat_ty >>??= fun pair_nat_nat_ty -> let pair_prim2 a b = pair_prim [a; b] in let pair_z_z_prim = pair_prim2 z_prim z_prim in - list_t (-1) nat_ty ~annot:None >>??= fun list_nat_ty -> - big_map_t (-1) (nat_key ~annot:None) nat_ty ~annot:None - >>??= fun big_map_nat_nat_ty -> + list_t (-1) nat_ty >>??= fun list_nat_ty -> + big_map_t (-1) nat_key nat_ty >>??= fun big_map_nat_nat_ty -> test_context_with_nat_nat_big_map () >>=? fun (ctxt, big_map_id) -> (* Pair 0 0 *) test_parse_data __LOC__ ctxt pair_nat_nat_ty pair_z_z_prim (z, z) @@ -626,7 +562,7 @@ let test_parse_comb_data () = let expected_big_map = let open Script_typed_ir in let diff = {map = Big_map_overlay.empty; size = 0} in - let nat_key_ty = nat_key ~annot:None in + let nat_key_ty = nat_key in {id = Some big_map_id; diff; key_type = nat_key_ty; value_type = nat_ty} in let equal (nat1, big_map1) (nat2, big_map2) = @@ -664,7 +600,7 @@ let test_parse_address () = test_parse_data __LOC__ ctxt - (address_t ~annot:None) + address_t (String (-1, "KT1FAKEFAKEFAKEFAKEFAKEFAKEFAKGGSE2x%")) {contract = kt1fake; entrypoint = Entrypoint.default} >>=? fun ctxt -> @@ -675,7 +611,7 @@ let test_parse_address () = test_parse_data __LOC__ ctxt - (address_t ~annot:None) + address_t (String (-1, "tz1fakefakefakefakefakefakefakcphLA5%")) {contract = tz1fake; entrypoint = Entrypoint.default} >|=? fun _ctxt -> () @@ -697,9 +633,9 @@ let test_unparse_comb_data () = let open Script_typed_ir in let z = Script_int.zero_n in let z_prim = Micheline.Int (-1, Z.zero) in - let nat_ty = nat_t ~annot:None in + let nat_ty = nat_t in let pair_prim l = Prim (-1, D_Pair, l, []) in - let pair_ty ty1 ty2 = pair_t (-1) (ty1, None) (ty2, None) ~annot:None in + let pair_ty ty1 ty2 = pair_t (-1) (ty1, None) (ty2, None) in pair_ty nat_ty nat_ty >>??= fun pair_nat_nat_ty -> let pair_prim2 a b = pair_prim [a; b] in let pair_z_z_prim = pair_prim2 z_prim z_prim in @@ -767,7 +703,7 @@ let rec gen_combs leaf arity = (* Checks the optimality of the Optimized Micheline representation for combs *) let test_optimal_comb () = let open Script_typed_ir in - let leaf_ty = nat_t ~annot:None in + let leaf_ty = nat_t in let leaf_mich = Int ((), Z.zero) in let leaf_v = Script_int.zero_n in let size_of_micheline mich = @@ -806,7 +742,7 @@ let test_optimal_comb () = @@ gen_combs leaf_mich arity >>=? fun () -> return ctxt ) in - let pair_ty ty1 ty2 = pair_t (-1) (ty1, None) (ty2, None) ~annot:None in + let pair_ty ty1 ty2 = pair_t (-1) (ty1, None) (ty2, None) in test_context () >>=? fun ctxt -> pair_ty leaf_ty leaf_ty >>??= fun comb2_ty -> let comb2_v = (leaf_v, leaf_v) in @@ -852,7 +788,7 @@ let test_contract_not_packable () = ctxt ~legacy:false (Prim (0, I_UNPACK, [Prim (0, T_unit, [], [])], [])) - (Item_t (Script_typed_ir.bytes_t ~annot:None, Bot_t)) + (Item_t (Script_typed_ir.bytes_t, Bot_t)) >>= function | Ok _ -> return_unit | Error _ -> Alcotest.failf "Could not parse UNPACK unit") @@ -863,7 +799,7 @@ let test_contract_not_packable () = ctxt ~legacy:false (Prim (0, I_UNPACK, [contract_unit], [])) - (Item_t (Script_typed_ir.bytes_t ~annot:None, Bot_t)) + (Item_t (Script_typed_ir.bytes_t, Bot_t)) >>= function | Ok _ -> Alcotest.failf diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml b/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml index c61f17a2146b..187af4ad03c1 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml @@ -347,9 +347,7 @@ let test_pack_unpack = comparable_data_arbitrary (fun (Ex_comparable_data (ty, x)) -> let oty = - match option_key (-1) ty ~annot:None with - | Ok ty -> ty - | Error _ -> assert false + match option_key (-1) ty with Ok ty -> ty | Error _ -> assert false in qcheck_eq ~cmp:(Script_comparable.compare_comparable oty) -- GitLab From 61a1dba150398912fa361925bf6f3c1ef3d662e2 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 11 Jan 2021 16:14:40 +0100 Subject: [PATCH 05/23] Proto/Michelson: remove merge_type_annot Always called with `None None`, always succeed with `None` --- .../lib_protocol/script_ir_annot.ml | 22 +------------------ .../lib_protocol/script_ir_annot.mli | 11 +--------- .../lib_protocol/script_ir_translator.ml | 7 ++---- 3 files changed, 4 insertions(+), 36 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 01fa09bea1d8..9d8c014b13e2 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -2,6 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019-2022 Nomadic Labs, *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -61,27 +62,6 @@ let field_annot_opt_eq_entrypoint_lax field_annot_opt entrypoint = | None -> false | Some a' -> Entrypoint.(a' = entrypoint)) -let merge_type_annot : - type error_trace. - legacy:bool -> - error_details:error_trace error_details -> - type_annot option -> - type_annot option -> - (type_annot option, error_trace) result = - fun ~legacy ~error_details annot1 annot2 -> - match (annot1, annot2) with - | (None, None) | (Some _, None) | (None, Some _) -> Result.return_none - | (Some (Type_annot a1), Some (Type_annot a2)) -> - if legacy || Non_empty_string.(a1 = a2) then ok annot1 - else - Error - (match error_details with - | Fast -> Inconsistent_types_fast - | Informative -> - trace_of_error - @@ Inconsistent_annotations - (":" ^ (a1 :> string), ":" ^ (a2 :> string))) - let merge_field_annot : type error_trace. legacy:bool -> diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index cf7c5f0cb51d..e4cb8ce5324f 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -2,6 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019-2022 Nomadic Labs, *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -53,16 +54,6 @@ val field_annot_opt_to_entrypoint_strict : val field_annot_opt_eq_entrypoint_lax : field_annot option -> Entrypoint.t -> bool -(** Merge type annotations. - @return an error {!Inconsistent_type_annotations} if they are both present - and different, unless [legacy] *) -val merge_type_annot : - legacy:bool -> - error_details:'error_trace Script_tc_errors.error_details -> - type_annot option -> - type_annot option -> - (type_annot option, 'error_trace) result - (** Merge field annotations. @return an error {!Inconsistent_type_annotations} if they are both present and different, unless [legacy] *) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 08a055a7490c..ae69fd3fac1e 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -723,9 +723,8 @@ let merge_type_metadata : 'a ty_metadata -> 'b ty_metadata -> ('a ty_metadata, error_trace) result = - fun ~legacy ~error_details {size = size_a} {size = size_b} -> - Type_size.merge ~error_details size_a size_b >>? fun size -> - merge_type_annot ~legacy ~error_details None None >|? fun _annot -> {size} + fun ~legacy:_ ~error_details {size = size_a} {size = size_b} -> + Type_size.merge ~error_details size_a size_b >|? fun size -> {size} let default_merge_type_error ty1 ty2 = let ty1 = serialize_ty_for_error ty1 in @@ -4065,8 +4064,6 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | ( Prim (loc, I_SUB, [], annot), Item_t (Timestamp_t _, Item_t (Timestamp_t _, rest)) ) -> check_var_annot loc annot >>?= fun () -> - merge_type_annot ~legacy ~error_details:Informative None None - >>?= fun _tname -> let instr = {apply = (fun kinfo k -> IDiff_timestamps (kinfo, k))} in let stack = Item_t (int_t, rest) in typed ctxt loc instr stack -- GitLab From 505d81c339472bc33d8348538e793abb7ecf0622 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 11 Jan 2021 16:14:40 +0100 Subject: [PATCH 06/23] Proto/Michelson: simplify merge_type_metadata `legacy` parameter was unused --- .../lib_protocol/script_ir_translator.ml | 93 +++++++------------ 1 file changed, 33 insertions(+), 60 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index ae69fd3fac1e..a461e4bc5fb8 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -718,12 +718,11 @@ type ('ta, 'tb) eq = Eq : ('same, 'same) eq let merge_type_metadata : type error_trace. - legacy:bool -> error_details:error_trace error_details -> 'a ty_metadata -> 'b ty_metadata -> ('a ty_metadata, error_trace) result = - fun ~legacy:_ ~error_details {size = size_a} {size = size_b} -> + fun ~error_details {size = size_a} {size = size_b} -> Type_size.merge ~error_details size_a size_b >|? fun size -> {size} let default_merge_type_error ty1 ty2 = @@ -758,8 +757,8 @@ let rec merge_comparable_types : let open Gas_monad in fun ~legacy ~error_details ta tb -> consume_gas Typecheck_costs.merge_cycle >>$ fun () -> - let merge_type_metadata ~legacy meta_a meta_b = - of_result @@ merge_type_metadata ~legacy ~error_details meta_a meta_b + let merge_type_metadata meta_a meta_b = + of_result @@ merge_type_metadata ~error_details meta_a meta_b in let merge_field_annot ~legacy annot_a annot_b = of_result @@ merge_field_annot ~legacy ~error_details annot_a annot_b @@ -768,8 +767,7 @@ let rec merge_comparable_types : ( (ta comparable_ty, tb comparable_ty) eq * ta comparable_ty, error_trace ) gas_monad = - merge_type_metadata ~legacy annot_a annot_b >>$ fun annot -> - return (eq, f annot) + merge_type_metadata annot_a annot_b >>$ fun annot -> return (eq, f annot) in match (ta, tb) with | (Unit_key annot_a, Unit_key annot_b) -> @@ -803,7 +801,7 @@ let rec merge_comparable_types : | ( Pair_key ((left_a, annot_left_a), (right_a, annot_right_a), annot_a), Pair_key ((left_b, annot_left_b), (right_b, annot_right_b), annot_b) ) -> - merge_type_metadata ~legacy annot_a annot_b >>$ fun annot -> + merge_type_metadata annot_a annot_b >>$ fun annot -> merge_field_annot ~legacy annot_left_a annot_left_b >>$ fun annot_left -> merge_field_annot ~legacy annot_right_a annot_right_b @@ -817,7 +815,7 @@ let rec merge_comparable_types : | ( Union_key ((left_a, annot_left_a), (right_a, annot_right_a), annot_a), Union_key ((left_b, annot_left_b), (right_b, annot_right_b), annot_b) ) -> - merge_type_metadata ~legacy annot_a annot_b >>$ fun annot -> + merge_type_metadata annot_a annot_b >>$ fun annot -> merge_field_annot ~legacy annot_left_a annot_left_b >>$ fun annot_left -> merge_field_annot ~legacy annot_right_a annot_right_b @@ -829,7 +827,7 @@ let rec merge_comparable_types : ( (Eq : (ta comparable_ty, tb comparable_ty) eq), Union_key ((left, annot_left), (right, annot_right), annot) ) | (Option_key (ta, annot_a), Option_key (tb, annot_b)) -> - merge_type_metadata ~legacy annot_a annot_b >>$ fun annot -> + merge_type_metadata annot_a annot_b >>$ fun annot -> merge_comparable_types ~legacy ~error_details ta tb >|$ fun (Eq, t) -> ((Eq : (ta comparable_ty, tb comparable_ty) eq), Option_key (t, annot)) | (_, _) -> @@ -886,7 +884,7 @@ let merge_types : let open Gas_monad in fun ~legacy ~error_details loc ty1 ty2 -> let merge_type_metadata tn1 tn2 = - of_result @@ merge_type_metadata ~legacy ~error_details tn1 tn2 + of_result @@ merge_type_metadata ~error_details tn1 tn2 |> Gas_monad.record_trace_eval ~error_details (fun () -> let ty1 = serialize_ty_for_error ty1 in let ty2 = serialize_ty_for_error ty2 in @@ -4071,8 +4069,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | ( Prim (loc, I_CONCAT, [], annot), Item_t (String_t tn1, Item_t (String_t tn2, rest)) ) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IConcat_string_pair (kinfo, k))} in typed ctxt loc instr (Item_t (String_t tname, rest)) | (Prim (loc, I_CONCAT, [], annot), Item_t (List_t (String_t tname, _), rest)) @@ -4095,8 +4092,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | ( Prim (loc, I_CONCAT, [], annot), Item_t (Bytes_t tn1, Item_t (Bytes_t tn2, rest)) ) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IConcat_bytes_pair (kinfo, k))} in let stack = Item_t (Bytes_t tname, rest) in typed ctxt loc instr stack @@ -4121,8 +4117,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | ( Prim (loc, I_ADD, [], annot), Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest)) ) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IAdd_tez (kinfo, k))} in let stack = Item_t (Mutez_t tname, rest) in typed ctxt loc instr stack @@ -4130,8 +4125,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest)) ) -> if legacy then check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> ISub_tez_legacy (kinfo, k))} in let stack = Item_t (Mutez_t tname, rest) in typed ctxt loc instr stack @@ -4139,8 +4133,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | ( Prim (loc, I_SUB_MUTEZ, [], annot), Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest)) ) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> ISub_tez (kinfo, k))} in let stack = Item_t (option_mutez'_t tname, rest) in typed ctxt loc instr stack @@ -4162,24 +4155,21 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_OR, [], annot), Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IOr (kinfo, k))} in let stack = Item_t (Bool_t tname, rest) in typed ctxt loc instr stack | ( Prim (loc, I_AND, [], annot), Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest)) ) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IAnd (kinfo, k))} in let stack = Item_t (Bool_t tname, rest) in typed ctxt loc instr stack | ( Prim (loc, I_XOR, [], annot), Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest)) ) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IXor (kinfo, k))} in let stack = Item_t (Bool_t tname, rest) in typed ctxt loc instr stack @@ -4217,8 +4207,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_ADD, [], annot), Item_t (Int_t tn1, Item_t (Int_t tn2, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IAdd_int (kinfo, k))} in let stack = Item_t (Int_t tname, rest) in typed ctxt loc instr stack @@ -4237,16 +4226,14 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_ADD, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IAdd_nat (kinfo, k))} in let stack = Item_t (Nat_t tname, rest) in typed ctxt loc instr stack | (Prim (loc, I_SUB, [], annot), Item_t (Int_t tn1, Item_t (Int_t tn2, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> ISub_int (kinfo, k))} in let stack = Item_t (Int_t tname, rest) in typed ctxt loc instr stack @@ -4265,16 +4252,14 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_SUB, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun _tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun _tname -> let instr = {apply = (fun kinfo k -> ISub_int (kinfo, k))} in let stack = Item_t (int_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_MUL, [], annot), Item_t (Int_t tn1, Item_t (Int_t tn2, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IMul_int (kinfo, k))} in let stack = Item_t (Int_t tname, rest) in typed ctxt loc instr stack @@ -4293,8 +4278,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_MUL, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IMul_nat (kinfo, k))} in let stack = Item_t (Nat_t tname, rest) in typed ctxt loc instr stack @@ -4307,16 +4291,14 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | ( Prim (loc, I_EDIV, [], annot), Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest)) ) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IEdiv_tez (kinfo, k))} in let stack = Item_t (option_pair_nat_mutez'_t tname, rest) in typed ctxt loc instr stack | (Prim (loc, I_EDIV, [], annot), Item_t (Int_t tn1, Item_t (Int_t tn2, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IEdiv_int (kinfo, k))} in let stack = Item_t (option_pair_int'_nat_t tname, rest) in typed ctxt loc instr stack @@ -4335,40 +4317,35 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_EDIV, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IEdiv_nat (kinfo, k))} in let stack = Item_t (option_pair_nat'_nat'_t tname, rest) in typed ctxt loc instr stack | (Prim (loc, I_LSL, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> ILsl_nat (kinfo, k))} in let stack = Item_t (Nat_t tname, rest) in typed ctxt loc instr stack | (Prim (loc, I_LSR, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> ILsr_nat (kinfo, k))} in let stack = Item_t (Nat_t tname, rest) in typed ctxt loc instr stack | (Prim (loc, I_OR, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IOr_nat (kinfo, k))} in let stack = Item_t (Nat_t tname, rest) in typed ctxt loc instr stack | (Prim (loc, I_AND, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IAnd_nat (kinfo, k))} in let stack = Item_t (Nat_t tname, rest) in typed ctxt loc instr stack @@ -4381,8 +4358,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_XOR, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IXor_nat (kinfo, k))} in let stack = Item_t (Nat_t tname, rest) in typed ctxt loc instr stack @@ -4718,24 +4694,21 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | ( Prim (loc, I_ADD, [], annot), Item_t (Bls12_381_g1_t tn1, Item_t (Bls12_381_g1_t tn2, rest)) ) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IAdd_bls12_381_g1 (kinfo, k))} in let stack = Item_t (Bls12_381_g1_t tname, rest) in typed ctxt loc instr stack | ( Prim (loc, I_ADD, [], annot), Item_t (Bls12_381_g2_t tn1, Item_t (Bls12_381_g2_t tn2, rest)) ) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IAdd_bls12_381_g2 (kinfo, k))} in let stack = Item_t (Bls12_381_g2_t tname, rest) in typed ctxt loc instr stack | ( Prim (loc, I_ADD, [], annot), Item_t (Bls12_381_fr_t tn1, Item_t (Bls12_381_fr_t tn2, rest)) ) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~legacy ~error_details:Informative tn1 tn2 - >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> let instr = {apply = (fun kinfo k -> IAdd_bls12_381_fr (kinfo, k))} in let stack = Item_t (Bls12_381_fr_t tname, rest) in typed ctxt loc instr stack -- GitLab From a11ed9b9d97183191982ddce5f2a985019c88cc2 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 11 Jan 2021 16:44:03 +0100 Subject: [PATCH 07/23] Proto/Michelson: unparse_type_annot None is [] --- src/proto_alpha/lib_plugin/plugin.ml | 115 ++++++++---------- .../lib_protocol/script_ir_annot.ml | 4 - .../lib_protocol/script_ir_annot.mli | 2 - .../lib_protocol/script_ir_translator.ml | 111 ++++++++--------- 4 files changed, 99 insertions(+), 133 deletions(-) diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index bc86d0369964..050a5abfcb13 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -1914,45 +1914,36 @@ module RPC = struct open Script_ir_translator open Micheline open Michelson_v1_primitives - open Script_ir_annot open Script_typed_ir let rec unparse_comparable_ty : type a loc. loc:loc -> a comparable_ty -> (loc, Script.prim) Micheline.node = fun ~loc -> function - | Unit_key _meta -> Prim (loc, T_unit, [], unparse_type_annot None) - | Never_key _meta -> Prim (loc, T_never, [], unparse_type_annot None) - | Int_key _meta -> Prim (loc, T_int, [], unparse_type_annot None) - | Nat_key _meta -> Prim (loc, T_nat, [], unparse_type_annot None) - | Signature_key _meta -> - Prim (loc, T_signature, [], unparse_type_annot None) - | String_key _meta -> Prim (loc, T_string, [], unparse_type_annot None) - | Bytes_key _meta -> Prim (loc, T_bytes, [], unparse_type_annot None) - | Mutez_key _meta -> Prim (loc, T_mutez, [], unparse_type_annot None) - | Bool_key _meta -> Prim (loc, T_bool, [], unparse_type_annot None) - | Key_hash_key _meta -> - Prim (loc, T_key_hash, [], unparse_type_annot None) - | Key_key _meta -> Prim (loc, T_key, [], unparse_type_annot None) - | Timestamp_key _meta -> - Prim (loc, T_timestamp, [], unparse_type_annot None) - | Address_key _meta -> Prim (loc, T_address, [], unparse_type_annot None) - | Chain_id_key _meta -> - Prim (loc, T_chain_id, [], unparse_type_annot None) + | Unit_key _meta -> Prim (loc, T_unit, [], []) + | Never_key _meta -> Prim (loc, T_never, [], []) + | Int_key _meta -> Prim (loc, T_int, [], []) + | Nat_key _meta -> Prim (loc, T_nat, [], []) + | Signature_key _meta -> Prim (loc, T_signature, [], []) + | String_key _meta -> Prim (loc, T_string, [], []) + | Bytes_key _meta -> Prim (loc, T_bytes, [], []) + | Mutez_key _meta -> Prim (loc, T_mutez, [], []) + | Bool_key _meta -> Prim (loc, T_bool, [], []) + | Key_hash_key _meta -> Prim (loc, T_key_hash, [], []) + | Key_key _meta -> Prim (loc, T_key, [], []) + | Timestamp_key _meta -> Prim (loc, T_timestamp, [], []) + | Address_key _meta -> Prim (loc, T_address, [], []) + | Chain_id_key _meta -> Prim (loc, T_chain_id, [], []) | Pair_key ((l, al), (r, ar), _meta) -> let tl = add_field_annot al (unparse_comparable_ty ~loc l) in let tr = add_field_annot ar (unparse_comparable_ty ~loc r) in - Prim (loc, T_pair, [tl; tr], unparse_type_annot None) + Prim (loc, T_pair, [tl; tr], []) | Union_key ((l, al), (r, ar), _meta) -> let tl = add_field_annot al (unparse_comparable_ty ~loc l) in let tr = add_field_annot ar (unparse_comparable_ty ~loc r) in - Prim (loc, T_or, [tl; tr], unparse_type_annot None) + Prim (loc, T_or, [tl; tr], []) | Option_key (t, _meta) -> - Prim - ( loc, - T_option, - [unparse_comparable_ty ~loc t], - unparse_type_annot None ) + Prim (loc, T_option, [unparse_comparable_ty ~loc t], []) let unparse_memo_size ~loc memo_size = let z = Alpha_context.Sapling.Memo_size.unparse_to_z memo_size in @@ -1963,39 +1954,36 @@ module RPC = struct fun ~loc ty -> let return (name, args, annot) = Prim (loc, name, args, annot) in match ty with - | Unit_t _meta -> return (T_unit, [], unparse_type_annot None) - | Int_t _meta -> return (T_int, [], unparse_type_annot None) - | Nat_t _meta -> return (T_nat, [], unparse_type_annot None) - | Signature_t _meta -> return (T_signature, [], unparse_type_annot None) - | String_t _meta -> return (T_string, [], unparse_type_annot None) - | Bytes_t _meta -> return (T_bytes, [], unparse_type_annot None) - | Mutez_t _meta -> return (T_mutez, [], unparse_type_annot None) - | Bool_t _meta -> return (T_bool, [], unparse_type_annot None) - | Key_hash_t _meta -> return (T_key_hash, [], unparse_type_annot None) - | Key_t _meta -> return (T_key, [], unparse_type_annot None) - | Timestamp_t _meta -> return (T_timestamp, [], unparse_type_annot None) - | Address_t _meta -> return (T_address, [], unparse_type_annot None) - | Operation_t _meta -> return (T_operation, [], unparse_type_annot None) - | Chain_id_t _meta -> return (T_chain_id, [], unparse_type_annot None) - | Never_t _meta -> return (T_never, [], unparse_type_annot None) - | Bls12_381_g1_t _meta -> - return (T_bls12_381_g1, [], unparse_type_annot None) - | Bls12_381_g2_t _meta -> - return (T_bls12_381_g2, [], unparse_type_annot None) - | Bls12_381_fr_t _meta -> - return (T_bls12_381_fr, [], unparse_type_annot None) + | Unit_t _meta -> return (T_unit, [], []) + | Int_t _meta -> return (T_int, [], []) + | Nat_t _meta -> return (T_nat, [], []) + | Signature_t _meta -> return (T_signature, [], []) + | String_t _meta -> return (T_string, [], []) + | Bytes_t _meta -> return (T_bytes, [], []) + | Mutez_t _meta -> return (T_mutez, [], []) + | Bool_t _meta -> return (T_bool, [], []) + | Key_hash_t _meta -> return (T_key_hash, [], []) + | Key_t _meta -> return (T_key, [], []) + | Timestamp_t _meta -> return (T_timestamp, [], []) + | Address_t _meta -> return (T_address, [], []) + | Operation_t _meta -> return (T_operation, [], []) + | Chain_id_t _meta -> return (T_chain_id, [], []) + | Never_t _meta -> return (T_never, [], []) + | Bls12_381_g1_t _meta -> return (T_bls12_381_g1, [], []) + | Bls12_381_g2_t _meta -> return (T_bls12_381_g2, [], []) + | Bls12_381_fr_t _meta -> return (T_bls12_381_fr, [], []) | Contract_t (ut, _meta) -> let t = unparse_ty ~loc ut in - return (T_contract, [t], unparse_type_annot None) + return (T_contract, [t], []) | Pair_t ((utl, l_field), (utr, r_field), _meta) -> - let annot = unparse_type_annot None in + let annot = [] in let utl = unparse_ty ~loc utl in let tl = add_field_annot l_field utl in let utr = unparse_ty ~loc utr in let tr = add_field_annot r_field utr in return (T_pair, [tl; tr], annot) | Union_t ((utl, l_field), (utr, r_field), _meta) -> - let annot = unparse_type_annot None in + let annot = [] in let utl = unparse_ty ~loc utl in let tl = add_field_annot l_field utl in let utr = unparse_ty ~loc utr in @@ -2004,40 +1992,35 @@ module RPC = struct | Lambda_t (uta, utr, _meta) -> let ta = unparse_ty ~loc uta in let tr = unparse_ty ~loc utr in - return (T_lambda, [ta; tr], unparse_type_annot None) + return (T_lambda, [ta; tr], []) | Option_t (ut, _meta) -> - let annot = unparse_type_annot None in + let annot = [] in let ut = unparse_ty ~loc ut in return (T_option, [ut], annot) | List_t (ut, _meta) -> let t = unparse_ty ~loc ut in - return (T_list, [t], unparse_type_annot None) + return (T_list, [t], []) | Ticket_t (ut, _meta) -> let t = unparse_comparable_ty ~loc ut in - return (T_ticket, [t], unparse_type_annot None) + return (T_ticket, [t], []) | Set_t (ut, _meta) -> let t = unparse_comparable_ty ~loc ut in - return (T_set, [t], unparse_type_annot None) + return (T_set, [t], []) | Map_t (uta, utr, _meta) -> let ta = unparse_comparable_ty ~loc uta in let tr = unparse_ty ~loc utr in - return (T_map, [ta; tr], unparse_type_annot None) + return (T_map, [ta; tr], []) | Big_map_t (uta, utr, _meta) -> let ta = unparse_comparable_ty ~loc uta in let tr = unparse_ty ~loc utr in - return (T_big_map, [ta; tr], unparse_type_annot None) + return (T_big_map, [ta; tr], []) | Sapling_transaction_t (memo_size, _meta) -> return - ( T_sapling_transaction, - [unparse_memo_size ~loc memo_size], - unparse_type_annot None ) + (T_sapling_transaction, [unparse_memo_size ~loc memo_size], []) | Sapling_state_t (memo_size, _meta) -> - return - ( T_sapling_state, - [unparse_memo_size ~loc memo_size], - unparse_type_annot None ) - | Chest_t _meta -> return (T_chest, [], unparse_type_annot None) - | Chest_key_t _meta -> return (T_chest_key, [], unparse_type_annot None) + return (T_sapling_state, [unparse_memo_size ~loc memo_size], []) + | Chest_t _meta -> return (T_chest, [], []) + | Chest_key_t _meta -> return (T_chest_key, [], []) end let run_operation_service ctxt () diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 9d8c014b13e2..03d01ffc7c58 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -42,10 +42,6 @@ module FOR_TESTS = struct Field_annot (Non_empty_string.of_string_exn s) end -let unparse_type_annot : type_annot option -> string list = function - | None -> [] - | Some (Type_annot a) -> [":" ^ (a :> string)] - let unparse_field_annot : field_annot option -> string list = function | None -> [] | Some (Field_annot a) -> ["%" ^ (a :> string)] diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index e4cb8ce5324f..f89216619c4b 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -38,8 +38,6 @@ end (** Unparse annotations to their string representation *) -val unparse_type_annot : type_annot option -> string list - val unparse_field_annot : field_annot option -> string list (** Converts a field annot option to an entrypoint. diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index a461e4bc5fb8..8f96448432ed 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -186,20 +186,20 @@ let add_field_annot a = function let rec unparse_comparable_ty_uncarbonated : type a loc. loc:loc -> a comparable_ty -> loc Script.michelson_node = fun ~loc -> function - | Unit_key _meta -> Prim (loc, T_unit, [], unparse_type_annot None) - | Never_key _meta -> Prim (loc, T_never, [], unparse_type_annot None) - | Int_key _meta -> Prim (loc, T_int, [], unparse_type_annot None) - | Nat_key _meta -> Prim (loc, T_nat, [], unparse_type_annot None) - | Signature_key _meta -> Prim (loc, T_signature, [], unparse_type_annot None) - | String_key _meta -> Prim (loc, T_string, [], unparse_type_annot None) - | Bytes_key _meta -> Prim (loc, T_bytes, [], unparse_type_annot None) - | Mutez_key _meta -> Prim (loc, T_mutez, [], unparse_type_annot None) - | Bool_key _meta -> Prim (loc, T_bool, [], unparse_type_annot None) - | Key_hash_key _meta -> Prim (loc, T_key_hash, [], unparse_type_annot None) - | Key_key _meta -> Prim (loc, T_key, [], unparse_type_annot None) - | Timestamp_key _meta -> Prim (loc, T_timestamp, [], unparse_type_annot None) - | Address_key _meta -> Prim (loc, T_address, [], unparse_type_annot None) - | Chain_id_key _meta -> Prim (loc, T_chain_id, [], unparse_type_annot None) + | Unit_key _meta -> Prim (loc, T_unit, [], []) + | Never_key _meta -> Prim (loc, T_never, [], []) + | Int_key _meta -> Prim (loc, T_int, [], []) + | Nat_key _meta -> Prim (loc, T_nat, [], []) + | Signature_key _meta -> Prim (loc, T_signature, [], []) + | String_key _meta -> Prim (loc, T_string, [], []) + | Bytes_key _meta -> Prim (loc, T_bytes, [], []) + | Mutez_key _meta -> Prim (loc, T_mutez, [], []) + | Bool_key _meta -> Prim (loc, T_bool, [], []) + | Key_hash_key _meta -> Prim (loc, T_key_hash, [], []) + | Key_key _meta -> Prim (loc, T_key, [], []) + | Timestamp_key _meta -> Prim (loc, T_timestamp, [], []) + | Address_key _meta -> Prim (loc, T_address, [], []) + | Chain_id_key _meta -> Prim (loc, T_chain_id, [], []) | Pair_key ((l, al), (r, ar), _meta) -> ( let tl = add_field_annot al (unparse_comparable_ty_uncarbonated ~loc l) in let tr = add_field_annot ar (unparse_comparable_ty_uncarbonated ~loc r) in @@ -207,19 +207,14 @@ let rec unparse_comparable_ty_uncarbonated : (* Note that the folding does not happen if the pair on the right has a field annotation because this annotation would be lost *) match tr with - | Prim (_, T_pair, ts, []) -> - Prim (loc, T_pair, tl :: ts, unparse_type_annot None) - | _ -> Prim (loc, T_pair, [tl; tr], unparse_type_annot None)) + | Prim (_, T_pair, ts, []) -> Prim (loc, T_pair, tl :: ts, []) + | _ -> Prim (loc, T_pair, [tl; tr], [])) | Union_key ((l, al), (r, ar), _meta) -> let tl = add_field_annot al (unparse_comparable_ty_uncarbonated ~loc l) in let tr = add_field_annot ar (unparse_comparable_ty_uncarbonated ~loc r) in - Prim (loc, T_or, [tl; tr], unparse_type_annot None) + Prim (loc, T_or, [tl; tr], []) | Option_key (t, _meta) -> - Prim - ( loc, - T_option, - [unparse_comparable_ty_uncarbonated ~loc t], - unparse_type_annot None ) + Prim (loc, T_option, [unparse_comparable_ty_uncarbonated ~loc t], []) let unparse_memo_size ~loc memo_size = let z = Sapling.Memo_size.unparse_to_z memo_size in @@ -230,29 +225,29 @@ let rec unparse_ty_uncarbonated : fun ~loc ty -> let prim (name, args, annot) = Prim (loc, name, args, annot) in match ty with - | Unit_t _meta -> prim (T_unit, [], unparse_type_annot None) - | Int_t _meta -> prim (T_int, [], unparse_type_annot None) - | Nat_t _meta -> prim (T_nat, [], unparse_type_annot None) - | Signature_t _meta -> prim (T_signature, [], unparse_type_annot None) - | String_t _meta -> prim (T_string, [], unparse_type_annot None) - | Bytes_t _meta -> prim (T_bytes, [], unparse_type_annot None) - | Mutez_t _meta -> prim (T_mutez, [], unparse_type_annot None) - | Bool_t _meta -> prim (T_bool, [], unparse_type_annot None) - | Key_hash_t _meta -> prim (T_key_hash, [], unparse_type_annot None) - | Key_t _meta -> prim (T_key, [], unparse_type_annot None) - | Timestamp_t _meta -> prim (T_timestamp, [], unparse_type_annot None) - | Address_t _meta -> prim (T_address, [], unparse_type_annot None) - | Operation_t _meta -> prim (T_operation, [], unparse_type_annot None) - | Chain_id_t _meta -> prim (T_chain_id, [], unparse_type_annot None) - | Never_t _meta -> prim (T_never, [], unparse_type_annot None) - | Bls12_381_g1_t _meta -> prim (T_bls12_381_g1, [], unparse_type_annot None) - | Bls12_381_g2_t _meta -> prim (T_bls12_381_g2, [], unparse_type_annot None) - | Bls12_381_fr_t _meta -> prim (T_bls12_381_fr, [], unparse_type_annot None) + | Unit_t _meta -> prim (T_unit, [], []) + | Int_t _meta -> prim (T_int, [], []) + | Nat_t _meta -> prim (T_nat, [], []) + | Signature_t _meta -> prim (T_signature, [], []) + | String_t _meta -> prim (T_string, [], []) + | Bytes_t _meta -> prim (T_bytes, [], []) + | Mutez_t _meta -> prim (T_mutez, [], []) + | Bool_t _meta -> prim (T_bool, [], []) + | Key_hash_t _meta -> prim (T_key_hash, [], []) + | Key_t _meta -> prim (T_key, [], []) + | Timestamp_t _meta -> prim (T_timestamp, [], []) + | Address_t _meta -> prim (T_address, [], []) + | Operation_t _meta -> prim (T_operation, [], []) + | Chain_id_t _meta -> prim (T_chain_id, [], []) + | Never_t _meta -> prim (T_never, [], []) + | Bls12_381_g1_t _meta -> prim (T_bls12_381_g1, [], []) + | Bls12_381_g2_t _meta -> prim (T_bls12_381_g2, [], []) + | Bls12_381_fr_t _meta -> prim (T_bls12_381_fr, [], []) | Contract_t (ut, _meta) -> let t = unparse_ty_uncarbonated ~loc ut in - prim (T_contract, [t], unparse_type_annot None) + prim (T_contract, [t], []) | Pair_t ((utl, l_field), (utr, r_field), _meta) -> - let annot = unparse_type_annot None in + let annot = [] in let utl = unparse_ty_uncarbonated ~loc utl in let tl = add_field_annot l_field utl in let utr = unparse_ty_uncarbonated ~loc utr in @@ -265,7 +260,7 @@ let rec unparse_ty_uncarbonated : | Prim (_, T_pair, ts, []) -> (T_pair, tl :: ts, annot) | _ -> (T_pair, [tl; tr], annot)) | Union_t ((utl, l_field), (utr, r_field), _meta) -> - let annot = unparse_type_annot None in + let annot = [] in let utl = unparse_ty_uncarbonated ~loc utl in let tl = add_field_annot l_field utl in let utr = unparse_ty_uncarbonated ~loc utr in @@ -274,40 +269,34 @@ let rec unparse_ty_uncarbonated : | Lambda_t (uta, utr, _meta) -> let ta = unparse_ty_uncarbonated ~loc uta in let tr = unparse_ty_uncarbonated ~loc utr in - prim (T_lambda, [ta; tr], unparse_type_annot None) + prim (T_lambda, [ta; tr], []) | Option_t (ut, _meta) -> - let annot = unparse_type_annot None in + let annot = [] in let ut = unparse_ty_uncarbonated ~loc ut in prim (T_option, [ut], annot) | List_t (ut, _meta) -> let t = unparse_ty_uncarbonated ~loc ut in - prim (T_list, [t], unparse_type_annot None) + prim (T_list, [t], []) | Ticket_t (ut, _meta) -> let t = unparse_comparable_ty_uncarbonated ~loc ut in - prim (T_ticket, [t], unparse_type_annot None) + prim (T_ticket, [t], []) | Set_t (ut, _meta) -> let t = unparse_comparable_ty_uncarbonated ~loc ut in - prim (T_set, [t], unparse_type_annot None) + prim (T_set, [t], []) | Map_t (uta, utr, _meta) -> let ta = unparse_comparable_ty_uncarbonated ~loc uta in let tr = unparse_ty_uncarbonated ~loc utr in - prim (T_map, [ta; tr], unparse_type_annot None) + prim (T_map, [ta; tr], []) | Big_map_t (uta, utr, _meta) -> let ta = unparse_comparable_ty_uncarbonated ~loc uta in let tr = unparse_ty_uncarbonated ~loc utr in - prim (T_big_map, [ta; tr], unparse_type_annot None) + prim (T_big_map, [ta; tr], []) | Sapling_transaction_t (memo_size, _meta) -> - prim - ( T_sapling_transaction, - [unparse_memo_size ~loc memo_size], - unparse_type_annot None ) + prim (T_sapling_transaction, [unparse_memo_size ~loc memo_size], []) | Sapling_state_t (memo_size, _meta) -> - prim - ( T_sapling_state, - [unparse_memo_size ~loc memo_size], - unparse_type_annot None ) - | Chest_key_t _meta -> prim (T_chest_key, [], unparse_type_annot None) - | Chest_t _meta -> prim (T_chest, [], unparse_type_annot None) + prim (T_sapling_state, [unparse_memo_size ~loc memo_size], []) + | Chest_key_t _meta -> prim (T_chest_key, [], []) + | Chest_t _meta -> prim (T_chest, [], []) let unparse_ty ~loc ctxt ty = Gas.consume ctxt (Unparse_costs.unparse_type ty) >|? fun ctxt -> -- GitLab From e21b4f08808f4eae15d3e7a93fbcdc7e66001bce Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 6 Jan 2022 00:28:06 +0100 Subject: [PATCH 08/23] Proto/Michelson: minor simplification in parse_ty --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 8f96448432ed..24cb06f843aa 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1512,9 +1512,9 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : (* legacy semantics with (broken) field annotations *) extract_field_annot ut >>? fun (ut, _some_constr) -> parse_composed_type_annot loc annot - >>? fun (ty_name, _none_constr, _) -> ok (ut, ty_name) - else parse_type_annot loc annot >>? fun annot -> ok (ut, annot)) - >>? fun (ut, _annot) -> + >>? fun (_ty_name, _none_constr, _) -> ok ut + else parse_type_annot loc annot >>? fun _annot -> ok ut) + >>? fun ut -> parse_ty ctxt ~stack_depth:(stack_depth + 1) -- GitLab From 0a39914833c4f69cca7c8a87cb16aacabaf9bdc1 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 11 Jan 2021 16:31:01 +0100 Subject: [PATCH 09/23] Proto/Michelson: simplify parse_type_annot Returned value was always ignored --- .../lib_protocol/script_ir_annot.ml | 6 +- .../lib_protocol/script_ir_annot.mli | 3 +- .../lib_protocol/script_ir_translator.ml | 105 ++++++++---------- 3 files changed, 53 insertions(+), 61 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 03d01ffc7c58..49b31c42dbed 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -195,12 +195,12 @@ let get_two_annot loc = function | [a; b] -> ok (a, b) | _ -> error (Unexpected_annotation loc) -let parse_type_annot : - Script.location -> string list -> type_annot option tzresult = +let parse_type_annot : Script.location -> string list -> unit tzresult = fun loc annot -> parse_annots loc annot >>? classify_annot loc >>? fun (vars, types, fields) -> error_unexpected_annot loc vars >>? fun () -> - error_unexpected_annot loc fields >>? fun () -> get_one_annot loc types + error_unexpected_annot loc fields >>? fun () -> + get_one_annot loc types >|? fun _a -> () let parse_composed_type_annot : Script.location -> diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index f89216619c4b..b031a1312e68 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -66,8 +66,7 @@ val merge_field_annot : val error_unexpected_annot : Script.location -> 'a list -> unit tzresult (** Parse a type annotation only. *) -val parse_type_annot : - Script.location -> string list -> type_annot option tzresult +val parse_type_annot : Script.location -> string list -> unit tzresult (** Parse a field annotation only. *) val parse_field_annot : diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 24cb06f843aa..a350a9d60efa 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1147,46 +1147,43 @@ let[@coq_struct "ty"] rec parse_comparable_ty : else match ty with | Prim (loc, T_unit, [], annot) -> - parse_type_annot loc annot >|? fun _annot -> + parse_type_annot loc annot >|? fun () -> (Ex_comparable_ty unit_key, ctxt) | Prim (loc, T_never, [], annot) -> - parse_type_annot loc annot >|? fun _annot -> + parse_type_annot loc annot >|? fun () -> (Ex_comparable_ty never_key, ctxt) | Prim (loc, T_int, [], annot) -> - parse_type_annot loc annot >|? fun _annot -> - (Ex_comparable_ty int_key, ctxt) + parse_type_annot loc annot >|? fun () -> (Ex_comparable_ty int_key, ctxt) | Prim (loc, T_nat, [], annot) -> - parse_type_annot loc annot >|? fun _annot -> - (Ex_comparable_ty nat_key, ctxt) + parse_type_annot loc annot >|? fun () -> (Ex_comparable_ty nat_key, ctxt) | Prim (loc, T_signature, [], annot) -> - parse_type_annot loc annot >|? fun _annot -> + parse_type_annot loc annot >|? fun () -> (Ex_comparable_ty signature_key, ctxt) | Prim (loc, T_string, [], annot) -> - parse_type_annot loc annot >|? fun _annot -> + parse_type_annot loc annot >|? fun () -> (Ex_comparable_ty string_key, ctxt) | Prim (loc, T_bytes, [], annot) -> - parse_type_annot loc annot >|? fun _annot -> + parse_type_annot loc annot >|? fun () -> (Ex_comparable_ty bytes_key, ctxt) | Prim (loc, T_mutez, [], annot) -> - parse_type_annot loc annot >|? fun _annot -> + parse_type_annot loc annot >|? fun () -> (Ex_comparable_ty mutez_key, ctxt) | Prim (loc, T_bool, [], annot) -> - parse_type_annot loc annot >|? fun _annot -> + parse_type_annot loc annot >|? fun () -> (Ex_comparable_ty bool_key, ctxt) | Prim (loc, T_key_hash, [], annot) -> - parse_type_annot loc annot >|? fun _annot -> + parse_type_annot loc annot >|? fun () -> (Ex_comparable_ty key_hash_key, ctxt) | Prim (loc, T_key, [], annot) -> - parse_type_annot loc annot >|? fun _annot -> - (Ex_comparable_ty key_key, ctxt) + parse_type_annot loc annot >|? fun () -> (Ex_comparable_ty key_key, ctxt) | Prim (loc, T_timestamp, [], annot) -> - parse_type_annot loc annot >|? fun _annot -> + parse_type_annot loc annot >|? fun () -> (Ex_comparable_ty timestamp_key, ctxt) | Prim (loc, T_chain_id, [], annot) -> - parse_type_annot loc annot >|? fun _annot -> + parse_type_annot loc annot >|? fun () -> (Ex_comparable_ty chain_id_key, ctxt) | Prim (loc, T_address, [], annot) -> - parse_type_annot loc annot >|? fun _annot -> + parse_type_annot loc annot >|? fun () -> (Ex_comparable_ty address_key, ctxt) | Prim ( loc, @@ -1197,7 +1194,7 @@ let[@coq_struct "ty"] rec parse_comparable_ty : _ ) -> error (Invalid_arity (loc, prim, 0, List.length l)) | Prim (loc, T_pair, left :: right, annot) -> - parse_type_annot loc annot >>? fun _annot -> + parse_type_annot loc annot >>? fun () -> extract_field_annot left >>? fun (left, left_annot) -> (match right with | [right] -> extract_field_annot right @@ -1212,7 +1209,7 @@ let[@coq_struct "ty"] rec parse_comparable_ty : pair_key loc (left, left_annot) (right, right_annot) >|? fun ty -> (Ex_comparable_ty ty, ctxt) | Prim (loc, T_or, [left; right], annot) -> - parse_type_annot loc annot >>? fun _annot -> + parse_type_annot loc annot >>? fun () -> extract_field_annot left >>? fun (left, left_annot) -> extract_field_annot right >>? fun (right, right_annot) -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt right @@ -1224,7 +1221,7 @@ let[@coq_struct "ty"] rec parse_comparable_ty : | Prim (loc, ((T_pair | T_or) as prim), l, _) -> error (Invalid_arity (loc, prim, 2, List.length l)) | Prim (loc, T_option, [t], annot) -> - parse_type_annot loc annot >>? fun _annot -> + parse_type_annot loc annot >>? fun () -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t >>? fun (Ex_comparable_ty t, ctxt) -> option_key loc t >|? fun ty -> (Ex_comparable_ty ty, ctxt) @@ -1391,56 +1388,52 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : else match node with | Prim (loc, T_unit, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty unit_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty unit_t, ctxt) | Prim (loc, T_int, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty int_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty int_t, ctxt) | Prim (loc, T_nat, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty nat_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty nat_t, ctxt) | Prim (loc, T_string, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty string_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty string_t, ctxt) | Prim (loc, T_bytes, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty bytes_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty bytes_t, ctxt) | Prim (loc, T_mutez, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty mutez_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty mutez_t, ctxt) | Prim (loc, T_bool, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty bool_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty bool_t, ctxt) | Prim (loc, T_key, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty key_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty key_t, ctxt) | Prim (loc, T_key_hash, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty key_hash_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty key_hash_t, ctxt) | Prim (loc, T_chest_key, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty chest_key_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty chest_key_t, ctxt) | Prim (loc, T_chest, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty chest_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty chest_t, ctxt) | Prim (loc, T_timestamp, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty timestamp_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty timestamp_t, ctxt) | Prim (loc, T_address, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty address_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty address_t, ctxt) | Prim (loc, T_signature, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty signature_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty signature_t, ctxt) | Prim (loc, T_operation, [], annot) -> if allow_operation then - parse_type_annot loc annot >>? fun _annot -> - ok (Ex_ty operation_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty operation_t, ctxt) else error (Unexpected_operation loc) | Prim (loc, T_chain_id, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty chain_id_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty chain_id_t, ctxt) | Prim (loc, T_never, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> ok (Ex_ty never_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty never_t, ctxt) | Prim (loc, T_bls12_381_g1, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> - ok (Ex_ty bls12_381_g1_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty bls12_381_g1_t, ctxt) | Prim (loc, T_bls12_381_g2, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> - ok (Ex_ty bls12_381_g2_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty bls12_381_g2_t, ctxt) | Prim (loc, T_bls12_381_fr, [], annot) -> - parse_type_annot loc annot >>? fun _annot -> - ok (Ex_ty bls12_381_fr_t, ctxt) + parse_type_annot loc annot >>? fun () -> ok (Ex_ty bls12_381_fr_t, ctxt) | Prim (loc, T_contract, [utl], annot) -> if allow_contract then parse_parameter_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy utl >>? fun (Ex_ty tl, ctxt) -> - parse_type_annot loc annot >>? fun _annot -> + parse_type_annot loc annot >>? fun () -> contract_t loc tl >|? fun ty -> (Ex_ty ty, ctxt) else error (Unexpected_contract loc) | Prim (loc, T_pair, utl :: utr, annot) -> @@ -1471,7 +1464,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : ~allow_ticket utr >>? fun (Ex_ty tr, ctxt) -> - parse_type_annot loc annot >>? fun _annot -> + parse_type_annot loc annot >>? fun () -> pair_t loc (tl, left_field) (tr, right_field) >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_or, [utl; utr], annot) -> @@ -1497,7 +1490,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : ~allow_ticket utr >>? fun (Ex_ty tr, ctxt) -> - parse_type_annot loc annot >>? fun _annot -> + parse_type_annot loc annot >>? fun () -> union_t loc (tl, left_constr) (tr, right_constr) >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_lambda, [uta; utr], annot) -> @@ -1505,7 +1498,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : >>? fun (Ex_ty ta, ctxt) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy utr >>? fun (Ex_ty tr, ctxt) -> - parse_type_annot loc annot >>? fun _annot -> + parse_type_annot loc annot >>? fun () -> lambda_t loc ta tr >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_option, [ut], annot) -> (if legacy then @@ -1513,7 +1506,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : extract_field_annot ut >>? fun (ut, _some_constr) -> parse_composed_type_annot loc annot >>? fun (_ty_name, _none_constr, _) -> ok ut - else parse_type_annot loc annot >>? fun _annot -> ok ut) + else parse_type_annot loc annot >>? fun () -> ok ut) >>? fun ut -> parse_ty ctxt @@ -1537,19 +1530,19 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : ~allow_ticket ut >>? fun (Ex_ty t, ctxt) -> - parse_type_annot loc annot >>? fun _annot -> + parse_type_annot loc annot >>? fun () -> list_t loc t >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_ticket, [ut], annot) -> if allow_ticket then parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> - parse_type_annot loc annot >>? fun _annot -> + parse_type_annot loc annot >>? fun () -> ticket_t loc t >|? fun ty -> (Ex_ty ty, ctxt) else error (Unexpected_ticket loc) | Prim (loc, T_set, [ut], annot) -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> - parse_type_annot loc annot >>? fun _annot -> + parse_type_annot loc annot >>? fun () -> set_t loc t >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_map, [uta; utr], annot) -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt uta @@ -1564,10 +1557,10 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : ~allow_ticket utr >>? fun (Ex_ty tr, ctxt) -> - parse_type_annot loc annot >>? fun _annot -> + parse_type_annot loc annot >>? fun () -> map_t loc ta tr >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_sapling_transaction, [memo_size], annot) -> - parse_type_annot loc annot >>? fun _annot -> + parse_type_annot loc annot >>? fun () -> parse_memo_size memo_size >|? fun memo_size -> (Ex_ty (sapling_transaction_t ~memo_size), ctxt) (* @@ -1579,7 +1572,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : | Prim (loc, T_big_map, args, annot) when allow_lazy_storage -> (parse_big_map_ty [@tailcall]) ctxt ~stack_depth ~legacy loc args annot | Prim (loc, T_sapling_state, [memo_size], annot) when allow_lazy_storage -> - parse_type_annot loc annot >>? fun _annot -> + parse_type_annot loc annot >>? fun () -> parse_memo_size memo_size >|? fun memo_size -> (Ex_ty (sapling_state_t ~memo_size), ctxt) | Prim (loc, (T_big_map | T_sapling_state), _, _) -> @@ -1648,7 +1641,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma ~legacy value_ty >>? fun (Ex_ty value_ty, ctxt) -> - parse_type_annot big_map_loc map_annot >>? fun _annot -> + parse_type_annot big_map_loc map_annot >>? fun () -> big_map_t big_map_loc key_ty value_ty >|? fun big_map_ty -> (Ex_ty big_map_ty, ctxt) | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) -- GitLab From 1cacd759adaafeb6713a5b92612957b70978e098 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 11 Jan 2021 16:36:13 +0100 Subject: [PATCH 10/23] Proto/Michelson: simplify parse_composed_type First returned value was always ignored --- src/proto_alpha/lib_protocol/script_ir_annot.ml | 6 +++--- src/proto_alpha/lib_protocol/script_ir_annot.mli | 2 +- src/proto_alpha/lib_protocol/script_ir_translator.ml | 5 ++--- 3 files changed, 6 insertions(+), 7 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 49b31c42dbed..61358ab15ff4 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -205,12 +205,12 @@ let parse_type_annot : Script.location -> string list -> unit tzresult = let parse_composed_type_annot : Script.location -> string list -> - (type_annot option * field_annot option * field_annot option) tzresult = + (field_annot option * field_annot option) tzresult = fun loc annot -> parse_annots loc annot >>? classify_annot loc >>? fun (vars, types, fields) -> error_unexpected_annot loc vars >>? fun () -> - get_one_annot loc types >>? fun t -> - get_two_annot loc fields >|? fun (f1, f2) -> (t, f1, f2) + get_one_annot loc types >>? fun _t -> + get_two_annot loc fields >|? fun (f1, f2) -> (f1, f2) let parse_field_annot : Script.location -> string list -> field_annot option tzresult = diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index b031a1312e68..6761b7926f1f 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -77,7 +77,7 @@ val parse_field_annot : val parse_composed_type_annot : Script.location -> string list -> - (type_annot option * field_annot option * field_annot option) tzresult + (field_annot option * field_annot option) tzresult (** Extract and remove a field annotation from a node *) val extract_field_annot : diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index a350a9d60efa..d10f748ebf43 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1504,8 +1504,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : (if legacy then (* legacy semantics with (broken) field annotations *) extract_field_annot ut >>? fun (ut, _some_constr) -> - parse_composed_type_annot loc annot - >>? fun (_ty_name, _none_constr, _) -> ok ut + parse_composed_type_annot loc annot >>? fun (_none_constr, _) -> ok ut else parse_type_annot loc annot >>? fun () -> ok ut) >>? fun ut -> parse_ty @@ -1697,7 +1696,7 @@ let parse_storage_ty : remaining_storage >>? fun (Ex_ty remaining_storage, ctxt) -> parse_composed_type_annot loc storage_annot - >>? fun (_annot, map_field, storage_field) -> + >>? fun (map_field, storage_field) -> pair_t loc (big_map_ty, map_field) (remaining_storage, storage_field) >|? fun ty -> (Ex_ty ty, ctxt)) | _ -> (parse_normal_storage_ty [@tailcall]) ctxt ~stack_depth ~legacy node -- GitLab From bd27332d0fd745037332a77ba22cc19c3741470c Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 11 Jan 2021 16:39:57 +0100 Subject: [PATCH 11/23] Proto/Michelson: simplify parse_constr_annot First returned value was always ignored --- src/proto_alpha/lib_protocol/script_ir_annot.ml | 6 +++--- src/proto_alpha/lib_protocol/script_ir_annot.mli | 2 +- src/proto_alpha/lib_protocol/script_ir_translator.ml | 6 +++--- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 61358ab15ff4..1628aef430ca 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -263,15 +263,15 @@ let ignore_special f = let parse_constr_annot : Script.location -> string list -> - (type_annot option * field_annot option * field_annot option) tzresult = + (field_annot option * field_annot option) tzresult = fun loc annot -> parse_annots ~allow_special_field:true loc annot >>? classify_annot loc >>? fun (vars, types, fields) -> get_one_annot loc vars >>? fun (_v : var_annot option) -> - get_one_annot loc types >>? fun t -> + get_one_annot loc types >>? fun (_t : type_annot option) -> get_two_annot loc fields >>? fun (f1, f2) -> ignore_special f1 >>? fun f1 -> - ignore_special f2 >|? fun f2 -> (t, f1, f2) + ignore_special f2 >|? fun f2 -> (f1, f2) let check_two_var_annot : Script.location -> string list -> unit tzresult = fun loc annot -> diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index 6761b7926f1f..b199de40287a 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -97,7 +97,7 @@ val is_allowed_char : char -> bool val parse_constr_annot : Script.location -> string list -> - (type_annot option * field_annot option * field_annot option) tzresult + (field_annot option * field_annot option) tzresult val check_two_var_annot : Script.location -> string list -> unit tzresult diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index d10f748ebf43..6c2c79b87dda 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -3135,7 +3135,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : Lwt.return @@ merge_branches ~legacy ctxt loc btr bfr {branch} (* pairs *) | (Prim (loc, I_PAIR, [], annot), Item_t (a, Item_t (b, rest))) -> - parse_constr_annot loc annot >>?= fun (_ty_name, l_field, r_field) -> + parse_constr_annot loc annot >>?= fun (l_field, r_field) -> pair_t loc (a, l_field) (b, r_field) >>?= fun ty -> let stack_ty = Item_t (ty, rest) in let cons_pair = {apply = (fun kinfo k -> ICons_pair (kinfo, k))} in @@ -3280,7 +3280,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest)) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tr >>?= fun (Ex_ty tr, ctxt) -> - parse_constr_annot loc annot >>?= fun (_tname, l_field, r_field) -> + parse_constr_annot loc annot >>?= fun (l_field, r_field) -> let cons_left = {apply = (fun kinfo k -> ICons_left (kinfo, k))} in union_t loc (tl, l_field) (tr, r_field) >>?= fun ty -> let stack_ty = Item_t (ty, rest) in @@ -3288,7 +3288,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest)) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tl >>?= fun (Ex_ty tl, ctxt) -> - parse_constr_annot loc annot >>?= fun (_tname, l_field, r_field) -> + parse_constr_annot loc annot >>?= fun (l_field, r_field) -> let cons_right = {apply = (fun kinfo k -> ICons_right (kinfo, k))} in union_t loc (tl, l_field) (tr, r_field) >>?= fun ty -> let stack_ty = Item_t (ty, rest) in -- GitLab From 99d6e3c30a51076c180812ef6d1561f6a1361c52 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 11 Jan 2021 16:47:14 +0100 Subject: [PATCH 12/23] Proto/Michelson: simplify parse_var_type_annot Returned value was always ignored --- .../lib_protocol/script_ir_annot.ml | 5 ++-- .../lib_protocol/script_ir_annot.mli | 3 +-- .../lib_protocol/script_ir_translator.ml | 26 +++++++++---------- 3 files changed, 16 insertions(+), 18 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 1628aef430ca..1bdcb72aa039 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -307,10 +307,9 @@ let parse_entrypoint_annot : get_one_annot loc fields >>? fun f -> get_one_annot loc vars >|? fun (_v : var_annot option) -> f -let parse_var_type_annot : - Script.location -> string list -> type_annot option tzresult = +let parse_var_type_annot : Script.location -> string list -> unit tzresult = fun loc annot -> parse_annots loc annot >>? classify_annot loc >>? fun (vars, types, fields) -> error_unexpected_annot loc fields >>? fun () -> get_one_annot loc vars >>? fun (_v : var_annot option) -> - get_one_annot loc types + get_one_annot loc types >|? fun (_t : type_annot option) -> () diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index b199de40287a..9bbe2bda40ce 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -112,5 +112,4 @@ val parse_unpair_annot : val parse_entrypoint_annot : Script.location -> string list -> field_annot option tzresult -val parse_var_type_annot : - Script.location -> string list -> type_annot option tzresult +val parse_var_type_annot : Script.location -> string list -> unit tzresult diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 6c2c79b87dda..450a54a86424 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -3057,25 +3057,25 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let const = {apply = (fun kinfo k -> IConst (kinfo, v, k))} in typed ctxt loc const (Item_t (t, stack)) | (Prim (loc, I_UNIT, [], annot), stack) -> - parse_var_type_annot loc annot >>?= fun _ty_name -> + parse_var_type_annot loc annot >>?= fun () -> let const = {apply = (fun kinfo k -> IConst (kinfo, (), k))} in typed ctxt loc const (Item_t (unit_t, stack)) (* options *) | (Prim (loc, I_SOME, [], annot), Item_t (t, rest)) -> - parse_var_type_annot loc annot >>?= fun _ty_name -> + parse_var_type_annot loc annot >>?= fun () -> let cons_some = {apply = (fun kinfo k -> ICons_some (kinfo, k))} in option_t loc t >>?= fun ty -> typed ctxt loc cons_some (Item_t (ty, rest)) | (Prim (loc, I_NONE, [t], annot), stack) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> - parse_var_type_annot loc annot >>?= fun _ty_name -> + parse_var_type_annot loc annot >>?= fun () -> let cons_none = {apply = (fun kinfo k -> ICons_none (kinfo, k))} in option_t loc t >>?= fun ty -> let stack_ty = Item_t (ty, stack) in typed ctxt loc cons_none stack_ty | (Prim (loc, I_MAP, [body], annot), Item_t (Option_t (t, _), rest)) -> ( check_kind [Seq_kind] body >>?= fun () -> - parse_var_type_annot loc annot >>?= fun _opt_ty_name -> + parse_var_type_annot loc annot >>?= fun () -> non_terminal_recursion ?type_logger ~legacy @@ -3333,7 +3333,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_NIL, [t], annot), stack) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> - parse_var_type_annot loc annot >>?= fun _ty_name -> + parse_var_type_annot loc annot >>?= fun () -> let nil = {apply = (fun kinfo k -> INil (kinfo, k))} in list_t loc t >>?= fun ty -> typed ctxt loc nil (Item_t (ty, stack)) | ( Prim (loc, I_CONS, [], annot), @@ -3374,13 +3374,13 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : in Lwt.return @@ merge_branches ~legacy ctxt loc btr bfr {branch} | (Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest)) -> - parse_var_type_annot loc annot >>?= fun _tname -> + parse_var_type_annot loc annot >>?= fun () -> let list_size = {apply = (fun kinfo k -> IList_size (kinfo, k))} in typed ctxt loc list_size (Item_t (nat_t, rest)) | (Prim (loc, I_MAP, [body], annot), Item_t (List_t (elt, _), starting_rest)) -> ( check_kind [Seq_kind] body >>?= fun () -> - parse_var_type_annot loc annot >>?= fun _list_ty_name -> + parse_var_type_annot loc annot >>?= fun () -> non_terminal_recursion ?type_logger tc_context @@ -3455,7 +3455,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_EMPTY_SET, [t], annot), rest) -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t >>?= fun (Ex_comparable_ty t, ctxt) -> - parse_var_type_annot loc annot >>?= fun _tname -> + parse_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_set (kinfo, t, k))} in set_t loc t >>?= fun ty -> typed ctxt loc instr (Item_t (ty, rest)) | (Prim (loc, I_ITER, [body], annot), Item_t (Set_t (comp_elt, _), rest)) -> ( @@ -3498,7 +3498,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : ) | (Prim (loc, I_MEM, [], annot), Item_t (v, Item_t (Set_t (elt, _), rest))) -> let elt = ty_of_comparable_ty elt in - parse_var_type_annot loc annot >>?= fun _tname -> + parse_var_type_annot loc annot >>?= fun () -> check_item_ty ctxt elt v loc I_MEM 1 2 >>?= fun (Eq, _, ctxt) -> let instr = {apply = (fun kinfo k -> ISet_mem (kinfo, k))} in (typed ctxt loc instr (Item_t (bool_t, rest)) @@ -3521,14 +3521,14 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : >>?= fun (Ex_comparable_ty tk, ctxt) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> - parse_var_type_annot loc annot >>?= fun _ty_name -> + parse_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_map (kinfo, tk, k))} in map_t loc tk tv >>?= fun ty -> typed ctxt loc instr (Item_t (ty, stack)) | ( Prim (loc, I_MAP, [body], annot), Item_t (Map_t (ck, elt, _), starting_rest) ) -> ( let k = ty_of_comparable_ty ck in check_kind [Seq_kind] body >>?= fun () -> - parse_var_type_annot loc annot >>?= fun _ty_name -> + parse_var_type_annot loc annot >>?= fun () -> pair_t loc (k, None) (elt, None) >>?= fun ty -> non_terminal_recursion ?type_logger @@ -3660,7 +3660,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : >>?= fun (Ex_comparable_ty tk, ctxt) -> parse_big_map_value_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> - parse_var_type_annot loc annot >>?= fun _ty_name -> + parse_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_big_map (kinfo, tk, tv, k))} in @@ -4421,7 +4421,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t _, rest)) -> parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> - parse_var_type_annot loc annot >>?= fun _ty_name -> + parse_var_type_annot loc annot >>?= fun () -> option_t loc t >>?= fun res_ty -> let instr = {apply = (fun kinfo k -> IUnpack (kinfo, t, k))} in let stack = Item_t (res_ty, rest) in -- GitLab From f44b46bf519a52a9357dce1f6b36476723d935ab Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 6 Jan 2022 00:53:40 +0100 Subject: [PATCH 13/23] Proto/Michelson: simplify smart type constructors --- .../lib_protocol/script_ir_translator.ml | 36 +++++++++---------- .../lib_protocol/script_typed_ir.ml | 22 ++++-------- .../lib_protocol/script_typed_ir.mli | 18 ++++------ 3 files changed, 30 insertions(+), 46 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 450a54a86424..e1b74baa183d 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -4059,10 +4059,10 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let instr = {apply = (fun kinfo k -> IConcat_string (kinfo, k))} in typed ctxt loc instr (Item_t (String_t tname, rest)) | ( Prim (loc, I_SLICE, [], annot), - Item_t (Nat_t _, Item_t (Nat_t _, Item_t (String_t tname, rest))) ) -> + Item_t (Nat_t _, Item_t (Nat_t _, Item_t (String_t _, rest))) ) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISlice_string (kinfo, k))} in - let stack = Item_t (option_string'_t tname, rest) in + let stack = Item_t (option_string_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_SIZE, [], annot), Item_t (String_t _, rest)) -> check_var_annot loc annot >>?= fun () -> @@ -4084,10 +4084,10 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (Bytes_t tname, rest) in typed ctxt loc instr stack | ( Prim (loc, I_SLICE, [], annot), - Item_t (Nat_t _, Item_t (Nat_t _, Item_t (Bytes_t tname, rest))) ) -> + Item_t (Nat_t _, Item_t (Nat_t _, Item_t (Bytes_t _, rest))) ) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISlice_bytes (kinfo, k))} in - let stack = Item_t (option_bytes'_t tname, rest) in + let stack = Item_t (option_bytes_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_SIZE, [], annot), Item_t (Bytes_t _, rest)) -> check_var_annot loc annot >>?= fun () -> @@ -4114,9 +4114,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | ( Prim (loc, I_SUB_MUTEZ, [], annot), Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest)) ) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun _tname -> let instr = {apply = (fun kinfo k -> ISub_tez (kinfo, k))} in - let stack = Item_t (option_mutez'_t tname, rest) in + let stack = Item_t (option_mutez_t, rest) in typed ctxt loc instr stack | ( Prim (loc, I_MUL, [], annot), Item_t (Mutez_t tname, Item_t (Nat_t _, rest)) ) -> @@ -4264,43 +4264,43 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (Nat_t tname, rest) in typed ctxt loc instr stack | ( Prim (loc, I_EDIV, [], annot), - Item_t (Mutez_t tname, Item_t (Nat_t _, rest)) ) -> + Item_t (Mutez_t _, Item_t (Nat_t _, rest)) ) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEdiv_teznat (kinfo, k))} in - let stack = Item_t (option_pair_mutez'_mutez'_t tname, rest) in + let stack = Item_t (option_pair_mutez_mutez_t, rest) in typed ctxt loc instr stack | ( Prim (loc, I_EDIV, [], annot), Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest)) ) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun _tname -> let instr = {apply = (fun kinfo k -> IEdiv_tez (kinfo, k))} in - let stack = Item_t (option_pair_nat_mutez'_t tname, rest) in + let stack = Item_t (option_pair_nat_mutez_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_EDIV, [], annot), Item_t (Int_t tn1, Item_t (Int_t tn2, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun _tname -> let instr = {apply = (fun kinfo k -> IEdiv_int (kinfo, k))} in - let stack = Item_t (option_pair_int'_nat_t tname, rest) in + let stack = Item_t (option_pair_int_nat_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_EDIV, [], annot), Item_t (Int_t tname, Item_t (Nat_t _, rest))) + | (Prim (loc, I_EDIV, [], annot), Item_t (Int_t _, Item_t (Nat_t _, rest))) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEdiv_int (kinfo, k))} in - let stack = Item_t (option_pair_int'_nat_t tname, rest) in + let stack = Item_t (option_pair_int_nat_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_EDIV, [], annot), Item_t (Nat_t tname, Item_t (Int_t _, rest))) + | (Prim (loc, I_EDIV, [], annot), Item_t (Nat_t _, Item_t (Int_t _, rest))) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEdiv_nat (kinfo, k))} in - let stack = Item_t (option_pair_int_nat'_t tname, rest) in + let stack = Item_t (option_pair_int_nat_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_EDIV, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun tname -> + merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun _tname -> let instr = {apply = (fun kinfo k -> IEdiv_nat (kinfo, k))} in - let stack = Item_t (option_pair_nat'_nat'_t tname, rest) in + let stack = Item_t (option_pair_nat_nat_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_LSL, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest))) -> diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 9b9ea808df3d..b9082b2a8fc7 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -1853,11 +1853,11 @@ let lambda_t loc l r = let option_t loc t = Type_size.compound1 loc (ty_size t) >|? fun size -> Option_t (t, {size}) -let option_mutez'_t _meta = Option_t (mutez_t, {size = Type_size.two}) +let option_mutez_t = Option_t (mutez_t, {size = Type_size.two}) -let option_string'_t _meta = Option_t (string_t, {size = Type_size.two}) +let option_string_t = Option_t (string_t, {size = Type_size.two}) -let option_bytes'_t _meta = Option_t (bytes_t, {size = Type_size.two}) +let option_bytes_t = Option_t (bytes_t, {size = Type_size.two}) let option_nat_t = Option_t (nat_t, {size = Type_size.two}) @@ -1866,27 +1866,17 @@ let option_pair_nat_nat_t = ( Pair_t ((nat_t, None), (nat_t, None), {size = Type_size.three}), {size = Type_size.four} ) -let option_pair_nat'_nat'_t _meta = - Option_t - ( Pair_t ((nat_t, None), (nat_t, None), {size = Type_size.three}), - {size = Type_size.four} ) - -let option_pair_nat_mutez'_t _meta = +let option_pair_nat_mutez_t = Option_t ( Pair_t ((nat_t, None), (mutez_t, None), {size = Type_size.three}), {size = Type_size.four} ) -let option_pair_mutez'_mutez'_t _meta = +let option_pair_mutez_mutez_t = Option_t ( Pair_t ((mutez_t, None), (mutez_t, None), {size = Type_size.three}), {size = Type_size.four} ) -let option_pair_int'_nat_t _meta = - Option_t - ( Pair_t ((int_t, None), (nat_t, None), {size = Type_size.three}), - {size = Type_size.four} ) - -let option_pair_int_nat'_t _meta = +let option_pair_int_nat_t = Option_t ( Pair_t ((int_t, None), (nat_t, None), {size = Type_size.three}), {size = Type_size.four} ) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 6bca003f7ab1..fc0351f6426c 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -1579,27 +1579,21 @@ val lambda_t : val option_t : Script.location -> 'v ty -> 'v option ty tzresult -(* the quote is used to indicate where the annotation will go *) +val option_mutez_t : Tez.t option ty -val option_mutez'_t : _ ty_metadata -> Tez.t option ty +val option_string_t : Script_string.t option ty -val option_string'_t : _ ty_metadata -> Script_string.t option ty - -val option_bytes'_t : _ ty_metadata -> Bytes.t option ty +val option_bytes_t : Bytes.t option ty val option_nat_t : n num option ty val option_pair_nat_nat_t : (n num, n num) pair option ty -val option_pair_nat'_nat'_t : _ ty_metadata -> (n num, n num) pair option ty - -val option_pair_nat_mutez'_t : _ ty_metadata -> (n num, Tez.t) pair option ty - -val option_pair_mutez'_mutez'_t : _ ty_metadata -> (Tez.t, Tez.t) pair option ty +val option_pair_nat_mutez_t : (n num, Tez.t) pair option ty -val option_pair_int'_nat_t : _ ty_metadata -> (z num, n num) pair option ty +val option_pair_mutez_mutez_t : (Tez.t, Tez.t) pair option ty -val option_pair_int_nat'_t : _ ty_metadata -> (z num, n num) pair option ty +val option_pair_int_nat_t : (z num, n num) pair option ty val list_t : Script.location -> 'v ty -> 'v boxed_list ty tzresult -- GitLab From d168d97b48a77b6df46131ad8a810bc66bb5dbb2 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 6 Jan 2022 00:59:20 +0100 Subject: [PATCH 14/23] Proto/Michelson: remove useless calls to merge_type_metadata These calls are on metadata of types of the same size so always succeed --- .../lib_protocol/script_ir_translator.ml | 30 +++++++------------ 1 file changed, 10 insertions(+), 20 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index e1b74baa183d..b76bd87fad38 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -4112,9 +4112,8 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc instr stack else fail (Deprecated_instruction I_SUB) | ( Prim (loc, I_SUB_MUTEZ, [], annot), - Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest)) ) -> + Item_t (Mutez_t _, Item_t (Mutez_t _, rest)) ) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun _tname -> let instr = {apply = (fun kinfo k -> ISub_tez (kinfo, k))} in let stack = Item_t (option_mutez_t, rest) in typed ctxt loc instr stack @@ -4230,10 +4229,8 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let instr = {apply = (fun kinfo k -> ISub_int (kinfo, k))} in let stack = Item_t (Int_t tname, rest) in typed ctxt loc instr stack - | (Prim (loc, I_SUB, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest))) - -> + | (Prim (loc, I_SUB, [], annot), Item_t (Nat_t _, Item_t (Nat_t _, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun _tname -> let instr = {apply = (fun kinfo k -> ISub_int (kinfo, k))} in let stack = Item_t (int_t, rest) in typed ctxt loc instr stack @@ -4263,42 +4260,35 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let instr = {apply = (fun kinfo k -> IMul_nat (kinfo, k))} in let stack = Item_t (Nat_t tname, rest) in typed ctxt loc instr stack - | ( Prim (loc, I_EDIV, [], annot), - Item_t (Mutez_t _, Item_t (Nat_t _, rest)) ) -> + | (Prim (loc, I_EDIV, [], annot), Item_t (Mutez_t _, Item_t (Nat_t _, rest))) + -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEdiv_teznat (kinfo, k))} in let stack = Item_t (option_pair_mutez_mutez_t, rest) in typed ctxt loc instr stack - | ( Prim (loc, I_EDIV, [], annot), - Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest)) ) -> + | (Prim (loc, I_EDIV, [], annot), Item_t (Mutez_t _, Item_t (Mutez_t _, rest))) + -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun _tname -> let instr = {apply = (fun kinfo k -> IEdiv_tez (kinfo, k))} in let stack = Item_t (option_pair_nat_mutez_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_EDIV, [], annot), Item_t (Int_t tn1, Item_t (Int_t tn2, rest))) - -> + | (Prim (loc, I_EDIV, [], annot), Item_t (Int_t _, Item_t (Int_t _, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun _tname -> let instr = {apply = (fun kinfo k -> IEdiv_int (kinfo, k))} in let stack = Item_t (option_pair_int_nat_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_EDIV, [], annot), Item_t (Int_t _, Item_t (Nat_t _, rest))) - -> + | (Prim (loc, I_EDIV, [], annot), Item_t (Int_t _, Item_t (Nat_t _, rest))) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEdiv_int (kinfo, k))} in let stack = Item_t (option_pair_int_nat_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_EDIV, [], annot), Item_t (Nat_t _, Item_t (Int_t _, rest))) - -> + | (Prim (loc, I_EDIV, [], annot), Item_t (Nat_t _, Item_t (Int_t _, rest))) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEdiv_nat (kinfo, k))} in let stack = Item_t (option_pair_int_nat_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_EDIV, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest))) - -> + | (Prim (loc, I_EDIV, [], annot), Item_t (Nat_t _, Item_t (Nat_t _, rest))) -> check_var_annot loc annot >>?= fun () -> - merge_type_metadata ~error_details:Informative tn1 tn2 >>?= fun _tname -> let instr = {apply = (fun kinfo k -> IEdiv_nat (kinfo, k))} in let stack = Item_t (option_pair_nat_nat_t, rest) in typed ctxt loc instr stack -- GitLab From 4387b306f5589d7e9f3e885e0e3159e1f1e821de Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 12 Jan 2022 16:51:54 +0100 Subject: [PATCH 15/23] Proto/Michelson: rename parse_var_annot into check_var_annot --- .../lib_protocol/script_ir_annot.ml | 2 +- .../lib_protocol/script_ir_annot.mli | 2 +- .../lib_protocol/script_ir_translator.ml | 98 +++++++++---------- 3 files changed, 51 insertions(+), 51 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 1bdcb72aa039..4744b7e30c6b 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -195,7 +195,7 @@ let get_two_annot loc = function | [a; b] -> ok (a, b) | _ -> error (Unexpected_annotation loc) -let parse_type_annot : Script.location -> string list -> unit tzresult = +let check_type_annot : Script.location -> string list -> unit tzresult = fun loc annot -> parse_annots loc annot >>? classify_annot loc >>? fun (vars, types, fields) -> error_unexpected_annot loc vars >>? fun () -> diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index 9bbe2bda40ce..ae4159ad3584 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -66,7 +66,7 @@ val merge_field_annot : val error_unexpected_annot : Script.location -> 'a list -> unit tzresult (** Parse a type annotation only. *) -val parse_type_annot : Script.location -> string list -> unit tzresult +val check_type_annot : Script.location -> string list -> unit tzresult (** Parse a field annotation only. *) val parse_field_annot : diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index b76bd87fad38..ac38354a34e7 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1147,43 +1147,43 @@ let[@coq_struct "ty"] rec parse_comparable_ty : else match ty with | Prim (loc, T_unit, [], annot) -> - parse_type_annot loc annot >|? fun () -> + check_type_annot loc annot >|? fun () -> (Ex_comparable_ty unit_key, ctxt) | Prim (loc, T_never, [], annot) -> - parse_type_annot loc annot >|? fun () -> + check_type_annot loc annot >|? fun () -> (Ex_comparable_ty never_key, ctxt) | Prim (loc, T_int, [], annot) -> - parse_type_annot loc annot >|? fun () -> (Ex_comparable_ty int_key, ctxt) + check_type_annot loc annot >|? fun () -> (Ex_comparable_ty int_key, ctxt) | Prim (loc, T_nat, [], annot) -> - parse_type_annot loc annot >|? fun () -> (Ex_comparable_ty nat_key, ctxt) + check_type_annot loc annot >|? fun () -> (Ex_comparable_ty nat_key, ctxt) | Prim (loc, T_signature, [], annot) -> - parse_type_annot loc annot >|? fun () -> + check_type_annot loc annot >|? fun () -> (Ex_comparable_ty signature_key, ctxt) | Prim (loc, T_string, [], annot) -> - parse_type_annot loc annot >|? fun () -> + check_type_annot loc annot >|? fun () -> (Ex_comparable_ty string_key, ctxt) | Prim (loc, T_bytes, [], annot) -> - parse_type_annot loc annot >|? fun () -> + check_type_annot loc annot >|? fun () -> (Ex_comparable_ty bytes_key, ctxt) | Prim (loc, T_mutez, [], annot) -> - parse_type_annot loc annot >|? fun () -> + check_type_annot loc annot >|? fun () -> (Ex_comparable_ty mutez_key, ctxt) | Prim (loc, T_bool, [], annot) -> - parse_type_annot loc annot >|? fun () -> + check_type_annot loc annot >|? fun () -> (Ex_comparable_ty bool_key, ctxt) | Prim (loc, T_key_hash, [], annot) -> - parse_type_annot loc annot >|? fun () -> + check_type_annot loc annot >|? fun () -> (Ex_comparable_ty key_hash_key, ctxt) | Prim (loc, T_key, [], annot) -> - parse_type_annot loc annot >|? fun () -> (Ex_comparable_ty key_key, ctxt) + check_type_annot loc annot >|? fun () -> (Ex_comparable_ty key_key, ctxt) | Prim (loc, T_timestamp, [], annot) -> - parse_type_annot loc annot >|? fun () -> + check_type_annot loc annot >|? fun () -> (Ex_comparable_ty timestamp_key, ctxt) | Prim (loc, T_chain_id, [], annot) -> - parse_type_annot loc annot >|? fun () -> + check_type_annot loc annot >|? fun () -> (Ex_comparable_ty chain_id_key, ctxt) | Prim (loc, T_address, [], annot) -> - parse_type_annot loc annot >|? fun () -> + check_type_annot loc annot >|? fun () -> (Ex_comparable_ty address_key, ctxt) | Prim ( loc, @@ -1194,7 +1194,7 @@ let[@coq_struct "ty"] rec parse_comparable_ty : _ ) -> error (Invalid_arity (loc, prim, 0, List.length l)) | Prim (loc, T_pair, left :: right, annot) -> - parse_type_annot loc annot >>? fun () -> + check_type_annot loc annot >>? fun () -> extract_field_annot left >>? fun (left, left_annot) -> (match right with | [right] -> extract_field_annot right @@ -1209,7 +1209,7 @@ let[@coq_struct "ty"] rec parse_comparable_ty : pair_key loc (left, left_annot) (right, right_annot) >|? fun ty -> (Ex_comparable_ty ty, ctxt) | Prim (loc, T_or, [left; right], annot) -> - parse_type_annot loc annot >>? fun () -> + check_type_annot loc annot >>? fun () -> extract_field_annot left >>? fun (left, left_annot) -> extract_field_annot right >>? fun (right, right_annot) -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt right @@ -1221,7 +1221,7 @@ let[@coq_struct "ty"] rec parse_comparable_ty : | Prim (loc, ((T_pair | T_or) as prim), l, _) -> error (Invalid_arity (loc, prim, 2, List.length l)) | Prim (loc, T_option, [t], annot) -> - parse_type_annot loc annot >>? fun () -> + check_type_annot loc annot >>? fun () -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t >>? fun (Ex_comparable_ty t, ctxt) -> option_key loc t >|? fun ty -> (Ex_comparable_ty ty, ctxt) @@ -1388,52 +1388,52 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : else match node with | Prim (loc, T_unit, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty unit_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty unit_t, ctxt) | Prim (loc, T_int, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty int_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty int_t, ctxt) | Prim (loc, T_nat, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty nat_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty nat_t, ctxt) | Prim (loc, T_string, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty string_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty string_t, ctxt) | Prim (loc, T_bytes, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty bytes_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty bytes_t, ctxt) | Prim (loc, T_mutez, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty mutez_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty mutez_t, ctxt) | Prim (loc, T_bool, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty bool_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty bool_t, ctxt) | Prim (loc, T_key, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty key_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty key_t, ctxt) | Prim (loc, T_key_hash, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty key_hash_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty key_hash_t, ctxt) | Prim (loc, T_chest_key, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty chest_key_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty chest_key_t, ctxt) | Prim (loc, T_chest, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty chest_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty chest_t, ctxt) | Prim (loc, T_timestamp, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty timestamp_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty timestamp_t, ctxt) | Prim (loc, T_address, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty address_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty address_t, ctxt) | Prim (loc, T_signature, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty signature_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty signature_t, ctxt) | Prim (loc, T_operation, [], annot) -> if allow_operation then - parse_type_annot loc annot >>? fun () -> ok (Ex_ty operation_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty operation_t, ctxt) else error (Unexpected_operation loc) | Prim (loc, T_chain_id, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty chain_id_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty chain_id_t, ctxt) | Prim (loc, T_never, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty never_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty never_t, ctxt) | Prim (loc, T_bls12_381_g1, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty bls12_381_g1_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty bls12_381_g1_t, ctxt) | Prim (loc, T_bls12_381_g2, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty bls12_381_g2_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty bls12_381_g2_t, ctxt) | Prim (loc, T_bls12_381_fr, [], annot) -> - parse_type_annot loc annot >>? fun () -> ok (Ex_ty bls12_381_fr_t, ctxt) + check_type_annot loc annot >>? fun () -> ok (Ex_ty bls12_381_fr_t, ctxt) | Prim (loc, T_contract, [utl], annot) -> if allow_contract then parse_parameter_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy utl >>? fun (Ex_ty tl, ctxt) -> - parse_type_annot loc annot >>? fun () -> + check_type_annot loc annot >>? fun () -> contract_t loc tl >|? fun ty -> (Ex_ty ty, ctxt) else error (Unexpected_contract loc) | Prim (loc, T_pair, utl :: utr, annot) -> @@ -1464,7 +1464,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : ~allow_ticket utr >>? fun (Ex_ty tr, ctxt) -> - parse_type_annot loc annot >>? fun () -> + check_type_annot loc annot >>? fun () -> pair_t loc (tl, left_field) (tr, right_field) >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_or, [utl; utr], annot) -> @@ -1490,7 +1490,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : ~allow_ticket utr >>? fun (Ex_ty tr, ctxt) -> - parse_type_annot loc annot >>? fun () -> + check_type_annot loc annot >>? fun () -> union_t loc (tl, left_constr) (tr, right_constr) >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_lambda, [uta; utr], annot) -> @@ -1498,14 +1498,14 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : >>? fun (Ex_ty ta, ctxt) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy utr >>? fun (Ex_ty tr, ctxt) -> - parse_type_annot loc annot >>? fun () -> + check_type_annot loc annot >>? fun () -> lambda_t loc ta tr >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_option, [ut], annot) -> (if legacy then (* legacy semantics with (broken) field annotations *) extract_field_annot ut >>? fun (ut, _some_constr) -> parse_composed_type_annot loc annot >>? fun (_none_constr, _) -> ok ut - else parse_type_annot loc annot >>? fun () -> ok ut) + else check_type_annot loc annot >>? fun () -> ok ut) >>? fun ut -> parse_ty ctxt @@ -1529,19 +1529,19 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : ~allow_ticket ut >>? fun (Ex_ty t, ctxt) -> - parse_type_annot loc annot >>? fun () -> + check_type_annot loc annot >>? fun () -> list_t loc t >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_ticket, [ut], annot) -> if allow_ticket then parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> - parse_type_annot loc annot >>? fun () -> + check_type_annot loc annot >>? fun () -> ticket_t loc t >|? fun ty -> (Ex_ty ty, ctxt) else error (Unexpected_ticket loc) | Prim (loc, T_set, [ut], annot) -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> - parse_type_annot loc annot >>? fun () -> + check_type_annot loc annot >>? fun () -> set_t loc t >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_map, [uta; utr], annot) -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt uta @@ -1556,10 +1556,10 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : ~allow_ticket utr >>? fun (Ex_ty tr, ctxt) -> - parse_type_annot loc annot >>? fun () -> + check_type_annot loc annot >>? fun () -> map_t loc ta tr >|? fun ty -> (Ex_ty ty, ctxt) | Prim (loc, T_sapling_transaction, [memo_size], annot) -> - parse_type_annot loc annot >>? fun () -> + check_type_annot loc annot >>? fun () -> parse_memo_size memo_size >|? fun memo_size -> (Ex_ty (sapling_transaction_t ~memo_size), ctxt) (* @@ -1571,7 +1571,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_ty : | Prim (loc, T_big_map, args, annot) when allow_lazy_storage -> (parse_big_map_ty [@tailcall]) ctxt ~stack_depth ~legacy loc args annot | Prim (loc, T_sapling_state, [memo_size], annot) when allow_lazy_storage -> - parse_type_annot loc annot >>? fun () -> + check_type_annot loc annot >>? fun () -> parse_memo_size memo_size >|? fun memo_size -> (Ex_ty (sapling_state_t ~memo_size), ctxt) | Prim (loc, (T_big_map | T_sapling_state), _, _) -> @@ -1640,7 +1640,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma ~legacy value_ty >>? fun (Ex_ty value_ty, ctxt) -> - parse_type_annot big_map_loc map_annot >>? fun () -> + check_type_annot big_map_loc map_annot >>? fun () -> big_map_t big_map_loc key_ty value_ty >|? fun big_map_ty -> (Ex_ty big_map_ty, ctxt) | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) -- GitLab From 75b3a88b239501ad9b37c3a1063e71bb6e348882 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 12 Jan 2022 16:52:21 +0100 Subject: [PATCH 16/23] Proto/Michelson: rename parse_var_type_annot into check_var_type_annot --- .../lib_protocol/script_ir_annot.ml | 2 +- .../lib_protocol/script_ir_annot.mli | 2 +- .../lib_protocol/script_ir_translator.ml | 26 +++++++++---------- 3 files changed, 15 insertions(+), 15 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 4744b7e30c6b..f617efc9b626 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -307,7 +307,7 @@ let parse_entrypoint_annot : get_one_annot loc fields >>? fun f -> get_one_annot loc vars >|? fun (_v : var_annot option) -> f -let parse_var_type_annot : Script.location -> string list -> unit tzresult = +let check_var_type_annot : Script.location -> string list -> unit tzresult = fun loc annot -> parse_annots loc annot >>? classify_annot loc >>? fun (vars, types, fields) -> error_unexpected_annot loc fields >>? fun () -> diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index ae4159ad3584..4860789c8076 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -112,4 +112,4 @@ val parse_unpair_annot : val parse_entrypoint_annot : Script.location -> string list -> field_annot option tzresult -val parse_var_type_annot : Script.location -> string list -> unit tzresult +val check_var_type_annot : Script.location -> string list -> unit tzresult diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index ac38354a34e7..fc8f93c9181b 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -3057,25 +3057,25 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let const = {apply = (fun kinfo k -> IConst (kinfo, v, k))} in typed ctxt loc const (Item_t (t, stack)) | (Prim (loc, I_UNIT, [], annot), stack) -> - parse_var_type_annot loc annot >>?= fun () -> + check_var_type_annot loc annot >>?= fun () -> let const = {apply = (fun kinfo k -> IConst (kinfo, (), k))} in typed ctxt loc const (Item_t (unit_t, stack)) (* options *) | (Prim (loc, I_SOME, [], annot), Item_t (t, rest)) -> - parse_var_type_annot loc annot >>?= fun () -> + check_var_type_annot loc annot >>?= fun () -> let cons_some = {apply = (fun kinfo k -> ICons_some (kinfo, k))} in option_t loc t >>?= fun ty -> typed ctxt loc cons_some (Item_t (ty, rest)) | (Prim (loc, I_NONE, [t], annot), stack) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> - parse_var_type_annot loc annot >>?= fun () -> + check_var_type_annot loc annot >>?= fun () -> let cons_none = {apply = (fun kinfo k -> ICons_none (kinfo, k))} in option_t loc t >>?= fun ty -> let stack_ty = Item_t (ty, stack) in typed ctxt loc cons_none stack_ty | (Prim (loc, I_MAP, [body], annot), Item_t (Option_t (t, _), rest)) -> ( check_kind [Seq_kind] body >>?= fun () -> - parse_var_type_annot loc annot >>?= fun () -> + check_var_type_annot loc annot >>?= fun () -> non_terminal_recursion ?type_logger ~legacy @@ -3333,7 +3333,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_NIL, [t], annot), stack) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> - parse_var_type_annot loc annot >>?= fun () -> + check_var_type_annot loc annot >>?= fun () -> let nil = {apply = (fun kinfo k -> INil (kinfo, k))} in list_t loc t >>?= fun ty -> typed ctxt loc nil (Item_t (ty, stack)) | ( Prim (loc, I_CONS, [], annot), @@ -3374,13 +3374,13 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : in Lwt.return @@ merge_branches ~legacy ctxt loc btr bfr {branch} | (Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest)) -> - parse_var_type_annot loc annot >>?= fun () -> + check_var_type_annot loc annot >>?= fun () -> let list_size = {apply = (fun kinfo k -> IList_size (kinfo, k))} in typed ctxt loc list_size (Item_t (nat_t, rest)) | (Prim (loc, I_MAP, [body], annot), Item_t (List_t (elt, _), starting_rest)) -> ( check_kind [Seq_kind] body >>?= fun () -> - parse_var_type_annot loc annot >>?= fun () -> + check_var_type_annot loc annot >>?= fun () -> non_terminal_recursion ?type_logger tc_context @@ -3455,7 +3455,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_EMPTY_SET, [t], annot), rest) -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t >>?= fun (Ex_comparable_ty t, ctxt) -> - parse_var_type_annot loc annot >>?= fun () -> + check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_set (kinfo, t, k))} in set_t loc t >>?= fun ty -> typed ctxt loc instr (Item_t (ty, rest)) | (Prim (loc, I_ITER, [body], annot), Item_t (Set_t (comp_elt, _), rest)) -> ( @@ -3498,7 +3498,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : ) | (Prim (loc, I_MEM, [], annot), Item_t (v, Item_t (Set_t (elt, _), rest))) -> let elt = ty_of_comparable_ty elt in - parse_var_type_annot loc annot >>?= fun () -> + check_var_type_annot loc annot >>?= fun () -> check_item_ty ctxt elt v loc I_MEM 1 2 >>?= fun (Eq, _, ctxt) -> let instr = {apply = (fun kinfo k -> ISet_mem (kinfo, k))} in (typed ctxt loc instr (Item_t (bool_t, rest)) @@ -3521,14 +3521,14 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : >>?= fun (Ex_comparable_ty tk, ctxt) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> - parse_var_type_annot loc annot >>?= fun () -> + check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_map (kinfo, tk, k))} in map_t loc tk tv >>?= fun ty -> typed ctxt loc instr (Item_t (ty, stack)) | ( Prim (loc, I_MAP, [body], annot), Item_t (Map_t (ck, elt, _), starting_rest) ) -> ( let k = ty_of_comparable_ty ck in check_kind [Seq_kind] body >>?= fun () -> - parse_var_type_annot loc annot >>?= fun () -> + check_var_type_annot loc annot >>?= fun () -> pair_t loc (k, None) (elt, None) >>?= fun ty -> non_terminal_recursion ?type_logger @@ -3660,7 +3660,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : >>?= fun (Ex_comparable_ty tk, ctxt) -> parse_big_map_value_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> - parse_var_type_annot loc annot >>?= fun () -> + check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_big_map (kinfo, tk, tv, k))} in @@ -4411,7 +4411,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | (Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t _, rest)) -> parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> - parse_var_type_annot loc annot >>?= fun () -> + check_var_type_annot loc annot >>?= fun () -> option_t loc t >>?= fun res_ty -> let instr = {apply = (fun kinfo k -> IUnpack (kinfo, t, k))} in let stack = Item_t (res_ty, rest) in -- GitLab From 81c11b69ec7ffe47aaa93f52e8de2526d90a8682 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 12 Jan 2022 17:38:44 +0100 Subject: [PATCH 17/23] Proto/Michelson: optimize type metadata --- src/proto_alpha/lib_protocol/script_typed_ir.ml | 2 +- src/proto_alpha/lib_protocol/script_typed_ir.mli | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index b9082b2a8fc7..3d22feafec8c 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -310,7 +310,7 @@ type empty_cell = EmptyCell type end_of_stack = empty_cell * empty_cell -type 'a ty_metadata = {size : 'a Type_size.t} +type 'a ty_metadata = {size : 'a Type_size.t} [@@unboxed] type _ comparable_ty = | Unit_key : unit ty_metadata -> unit comparable_ty diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index fc0351f6426c..4f1225e63d3c 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -188,7 +188,7 @@ module Type_size : sig val to_int : 'a t -> Saturation_repr.mul_safe Saturation_repr.t end -type 'a ty_metadata = {size : 'a Type_size.t} +type 'a ty_metadata = {size : 'a Type_size.t} [@@unboxed] type _ comparable_ty = | Unit_key : unit ty_metadata -> unit comparable_ty -- GitLab From 79e5dc5b71ad8d6504c7d8cf6343d266313c5ab2 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 12 Jan 2022 17:39:01 +0100 Subject: [PATCH 18/23] Proto/Michelson: update ty_size --- .../lib_protocol/script_typed_ir_size.ml | 111 ++++++++++-------- 1 file changed, 61 insertions(+), 50 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index a87dfa951d57..bd50d9f0cbb4 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -33,72 +33,83 @@ let script_string_size s = Script_string.to_string s |> string_size let sapling_memo_size_size = !!0 let (comparable_ty_size, ty_size) = - let base _meta = hh3w in + let base_basic _meta = + !!0 + (* Basic types count for 0 because they are all static values, hence shared + and not counted by `reachable_words`. + On the other hand compound types are functions, hence not shared. *) + in + let base_compound _meta = h1w in let apply_comparable : type a. nodes_and_size -> a comparable_ty -> nodes_and_size = fun accu cty -> match cty with - | Unit_key a -> ret_succ_adding accu (base a) - | Int_key a -> ret_succ_adding accu (base a) - | Nat_key a -> ret_succ_adding accu (base a) - | Signature_key a -> ret_succ_adding accu (base a) - | String_key a -> ret_succ_adding accu (base a) - | Bytes_key a -> ret_succ_adding accu (base a) - | Mutez_key a -> ret_succ_adding accu (base a) - | Key_hash_key a -> ret_succ_adding accu (base a) - | Key_key a -> ret_succ_adding accu (base a) - | Timestamp_key a -> ret_succ_adding accu (base a) - | Address_key a -> ret_succ_adding accu (base a) - | Bool_key a -> ret_succ_adding accu (base a) - | Chain_id_key a -> ret_succ_adding accu (base a) - | Never_key a -> ret_succ_adding accu (base a) + | Unit_key a -> ret_succ_adding accu (base_basic a) + | Int_key a -> ret_succ_adding accu (base_basic a) + | Nat_key a -> ret_succ_adding accu (base_basic a) + | Signature_key a -> ret_succ_adding accu (base_basic a) + | String_key a -> ret_succ_adding accu (base_basic a) + | Bytes_key a -> ret_succ_adding accu (base_basic a) + | Mutez_key a -> ret_succ_adding accu (base_basic a) + | Key_hash_key a -> ret_succ_adding accu (base_basic a) + | Key_key a -> ret_succ_adding accu (base_basic a) + | Timestamp_key a -> ret_succ_adding accu (base_basic a) + | Address_key a -> ret_succ_adding accu (base_basic a) + | Bool_key a -> ret_succ_adding accu (base_basic a) + | Chain_id_key a -> ret_succ_adding accu (base_basic a) + | Never_key a -> ret_succ_adding accu (base_basic a) | Pair_key ((_ty1, _fa1), (_ty2, _fa2), a) -> - ret_succ_adding accu @@ (base a +! hh6w) + ret_succ_adding accu @@ (base_compound a +! hh6w) | Union_key ((_ty1, _fa1), (_ty2, _fa2), a) -> - ret_succ_adding accu @@ (base a +! hh6w) - | Option_key (_ty, a) -> ret_succ_adding accu @@ (base a +! word_size) + ret_succ_adding accu @@ (base_compound a +! hh6w) + | Option_key (_ty, a) -> + ret_succ_adding accu @@ (base_compound a +! word_size) and apply : type a. nodes_and_size -> a ty -> nodes_and_size = fun accu ty -> match ty with - | Unit_t a -> ret_succ_adding accu @@ base a - | Int_t a -> ret_succ_adding accu @@ base a - | Nat_t a -> ret_succ_adding accu @@ base a - | Signature_t a -> ret_succ_adding accu @@ base a - | String_t a -> ret_succ_adding accu @@ base a - | Bytes_t a -> ret_succ_adding accu @@ base a - | Mutez_t a -> ret_succ_adding accu @@ base a - | Key_hash_t a -> ret_succ_adding accu @@ base a - | Key_t a -> ret_succ_adding accu @@ base a - | Timestamp_t a -> ret_succ_adding accu @@ base a - | Address_t a -> ret_succ_adding accu @@ base a - | Bool_t a -> ret_succ_adding accu @@ base a - | Operation_t a -> ret_succ_adding accu @@ base a - | Chain_id_t a -> ret_succ_adding accu @@ base a - | Never_t a -> ret_succ_adding accu @@ base a - | Bls12_381_g1_t a -> ret_succ_adding accu @@ base a - | Bls12_381_g2_t a -> ret_succ_adding accu @@ base a - | Bls12_381_fr_t a -> ret_succ_adding accu @@ base a - | Chest_key_t a -> ret_succ_adding accu @@ base a - | Chest_t a -> ret_succ_adding accu @@ base a + | Unit_t a -> ret_succ_adding accu @@ base_basic a + | Int_t a -> ret_succ_adding accu @@ base_basic a + | Nat_t a -> ret_succ_adding accu @@ base_basic a + | Signature_t a -> ret_succ_adding accu @@ base_basic a + | String_t a -> ret_succ_adding accu @@ base_basic a + | Bytes_t a -> ret_succ_adding accu @@ base_basic a + | Mutez_t a -> ret_succ_adding accu @@ base_basic a + | Key_hash_t a -> ret_succ_adding accu @@ base_basic a + | Key_t a -> ret_succ_adding accu @@ base_basic a + | Timestamp_t a -> ret_succ_adding accu @@ base_basic a + | Address_t a -> ret_succ_adding accu @@ base_basic a + | Bool_t a -> ret_succ_adding accu @@ base_basic a + | Operation_t a -> ret_succ_adding accu @@ base_basic a + | Chain_id_t a -> ret_succ_adding accu @@ base_basic a + | Never_t a -> ret_succ_adding accu @@ base_basic a + | Bls12_381_g1_t a -> ret_succ_adding accu @@ base_basic a + | Bls12_381_g2_t a -> ret_succ_adding accu @@ base_basic a + | Bls12_381_fr_t a -> ret_succ_adding accu @@ base_basic a + | Chest_key_t a -> ret_succ_adding accu @@ base_basic a + | Chest_t a -> ret_succ_adding accu @@ base_basic a | Pair_t ((_ty1, _fa1), (_ty2, _fa2), a) -> - ret_succ_adding accu @@ (base a +! hh6w) + ret_succ_adding accu @@ (base_compound a +! hh6w) | Union_t ((_ty1, _fa1), (_ty2, _fa2), a) -> - ret_succ_adding accu @@ (base a +! hh6w) + ret_succ_adding accu @@ (base_compound a +! hh6w) | Lambda_t (_ty1, _ty2, a) -> - ret_succ_adding accu @@ (base a +! (word_size *? 2)) - | Option_t (_ty, a) -> ret_succ_adding accu @@ (base a +! word_size) - | List_t (_ty, a) -> ret_succ_adding accu @@ (base a +! word_size) - | Set_t (_cty, a) -> ret_succ_adding accu @@ (base a +! word_size) + ret_succ_adding accu @@ (base_compound a +! (word_size *? 2)) + | Option_t (_ty, a) -> ret_succ_adding accu @@ (base_compound a +! word_size) + | List_t (_ty, a) -> ret_succ_adding accu @@ (base_compound a +! word_size) + | Set_t (_cty, a) -> ret_succ_adding accu @@ (base_compound a +! word_size) | Map_t (_cty, _ty, a) -> - ret_succ_adding accu @@ (base a +! (word_size *? 2)) + ret_succ_adding accu @@ (base_compound a +! (word_size *? 2)) | Big_map_t (_cty, _ty, a) -> - ret_succ_adding accu @@ (base a +! (word_size *? 2)) - | Contract_t (_ty, a) -> ret_succ_adding accu @@ (base a +! word_size) + ret_succ_adding accu @@ (base_compound a +! (word_size *? 2)) + | Contract_t (_ty, a) -> + ret_succ_adding accu @@ (base_compound a +! word_size) | Sapling_transaction_t (_m, a) -> - ret_succ_adding accu @@ (base a +! sapling_memo_size_size +! word_size) + ret_succ_adding accu + @@ (base_compound a +! sapling_memo_size_size +! word_size) | Sapling_state_t (_m, a) -> - ret_succ_adding accu @@ (base a +! sapling_memo_size_size +! word_size) - | Ticket_t (_cty, a) -> ret_succ_adding accu @@ (base a +! word_size) + ret_succ_adding accu + @@ (base_compound a +! sapling_memo_size_size +! word_size) + | Ticket_t (_cty, a) -> + ret_succ_adding accu @@ (base_compound a +! word_size) in let f = ({apply; apply_comparable} : nodes_and_size ty_traverse) in ( (fun cty -> comparable_ty_traverse cty zero f), -- GitLab From 09c7cb9df034d16ae212e07fa14cfffae76a8523 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 12 Jan 2022 18:47:27 +0100 Subject: [PATCH 19/23] Proto/Tests: bump lambda size expected mean I got a little bit more than 1.2 :-/ --- .../test/integration/michelson/test_script_typed_ir_size.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml index 634f69c766ff..18407d30e656 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml @@ -357,7 +357,7 @@ module Tests = struct let check_lambda_size_stats () = check_stats "lambda_size" - ~expected_mean:(1., 0.2) + ~expected_mean:(1., 0.25) ~expected_stddev:(0., 0.1) ~expected_ratios:(1., 0.4) end -- GitLab From f424d03034252808997cdfd82304a91dfbe58e82 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 12 Jan 2022 19:08:23 +0100 Subject: [PATCH 20/23] Tests/Python: regenerate typechecking traces --- ...ck::test_typecheck[attic--accounts.tz].out | 182 ++++--- ...est_typecheck[macros--unpair_macro.tz].out | 20 +- ...k[mini_scenarios--generic_multisig.tz].out | 353 +++++-------- ...ck[mini_scenarios--legacy_multisig.tz].out | 475 ++++++++---------- ...[mini_scenarios--weather_insurance.tz].out | 160 +++--- ...check::test_typecheck[opcodes--and.tz].out | 2 +- ...check::test_typecheck[opcodes--car.tz].out | 8 +- ...check::test_typecheck[opcodes--cdr.tz].out | 8 +- ...::test_typecheck[opcodes--map_iter.tz].out | 40 +- 9 files changed, 543 insertions(+), 705 deletions(-) diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[attic--accounts.tz].out b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[attic--accounts.tz].out index 2d6e91f2af71..9044ed78bb7e 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[attic--accounts.tz].out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[attic--accounts.tz].out @@ -9,76 +9,72 @@ Gas remaining: 1039925.145 units remaining code { DUP /* [ pair (or (key_hash %Initialize) (pair %Withdraw (key %from) (mutez %withdraw_amount) (signature %sig))) - (map :stored_balance key_hash mutez) + (map key_hash mutez) : pair (or (key_hash %Initialize) (pair %Withdraw (key %from) (mutez %withdraw_amount) (signature %sig))) - (map :stored_balance key_hash mutez) ] */ ; + (map key_hash mutez) ] */ ; CAR /* [ or (key_hash %Initialize) (pair %Withdraw (key %from) (mutez %withdraw_amount) (signature %sig)) : pair (or (key_hash %Initialize) (pair %Withdraw (key %from) (mutez %withdraw_amount) (signature %sig))) - (map :stored_balance key_hash mutez) ] */ ; + (map key_hash mutez) ] */ ; IF_LEFT { DUP /* [ key_hash : key_hash : pair (or (key_hash %Initialize) (pair %Withdraw (key %from) (mutez %withdraw_amount) (signature %sig))) - (map :stored_balance key_hash mutez) ] */ ; + (map key_hash mutez) ] */ ; DIIP { CDR %stored_balance - /* [ map :stored_balance key_hash mutez ] */ ; + /* [ map key_hash mutez ] */ ; DUP - /* [ map :stored_balance key_hash mutez : map :stored_balance key_hash mutez ] */ } - /* [ key_hash : key_hash : map :stored_balance key_hash mutez - : map :stored_balance key_hash mutez ] */ ; - DIP { SWAP - /* [ map :stored_balance key_hash mutez : key_hash - : map :stored_balance key_hash mutez ] */ } - /* [ key_hash : map :stored_balance key_hash mutez : key_hash - : map :stored_balance key_hash mutez ] */ ; + /* [ map key_hash mutez : map key_hash mutez ] */ } + /* [ key_hash : key_hash : map key_hash mutez : map key_hash mutez ] */ ; + DIP { SWAP /* [ map key_hash mutez : key_hash : map key_hash mutez ] */ } + /* [ key_hash : map key_hash mutez : key_hash : map key_hash mutez ] */ ; GET @opt_prev_balance - /* [ option mutez : key_hash : map :stored_balance key_hash mutez ] */ ; + /* [ option mutez : key_hash : map key_hash mutez ] */ ; IF_SOME { RENAME @previous_balance - /* [ mutez : key_hash : map :stored_balance key_hash mutez ] */ ; + /* [ mutez : key_hash : map key_hash mutez ] */ ; AMOUNT - /* [ mutez : mutez : key_hash : map :stored_balance key_hash mutez ] */ ; + /* [ mutez : mutez : key_hash : map key_hash mutez ] */ ; ADD - /* [ mutez : key_hash : map :stored_balance key_hash mutez ] */ ; + /* [ mutez : key_hash : map key_hash mutez ] */ ; SOME - /* [ option mutez : key_hash : map :stored_balance key_hash mutez ] */ ; + /* [ option mutez : key_hash : map key_hash mutez ] */ ; SWAP - /* [ key_hash : option mutez : map :stored_balance key_hash mutez ] */ ; + /* [ key_hash : option mutez : map key_hash mutez ] */ ; UPDATE - /* [ map :stored_balance key_hash mutez ] */ ; + /* [ map key_hash mutez ] */ ; NIL operation - /* [ list operation : map :stored_balance key_hash mutez ] */ ; + /* [ list operation : map key_hash mutez ] */ ; PAIR - /* [ pair (list operation) (map :stored_balance key_hash mutez) ] */ } + /* [ pair (list operation) (map key_hash mutez) ] */ } { DIP { AMOUNT - /* [ mutez : map :stored_balance key_hash mutez ] */ ; + /* [ mutez : map key_hash mutez ] */ ; SOME - /* [ option mutez : map :stored_balance key_hash mutez ] */ } - /* [ key_hash : option mutez : map :stored_balance key_hash mutez ] */ ; + /* [ option mutez : map key_hash mutez ] */ } + /* [ key_hash : option mutez : map key_hash mutez ] */ ; UPDATE - /* [ map :stored_balance key_hash mutez ] */ ; + /* [ map key_hash mutez ] */ ; NIL operation - /* [ list operation : map :stored_balance key_hash mutez ] */ ; + /* [ list operation : map key_hash mutez ] */ ; PAIR - /* [ pair (list operation) (map :stored_balance key_hash mutez) ] */ } } + /* [ pair (list operation) (map key_hash mutez) ] */ } } { DUP /* [ pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (or (key_hash %Initialize) (pair %Withdraw (key %from) (mutez %withdraw_amount) (signature %sig))) - (map :stored_balance key_hash mutez) ] */ ; + (map key_hash mutez) ] */ ; DUP /* [ pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (or (key_hash %Initialize) (pair %Withdraw (key %from) (mutez %withdraw_amount) (signature %sig))) - (map :stored_balance key_hash mutez) ] */ ; + (map key_hash mutez) ] */ ; DUP /* [ pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (key %from) (mutez %withdraw_amount) (signature %sig) @@ -86,7 +82,7 @@ Gas remaining: 1039925.145 units remaining : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (or (key_hash %Initialize) (pair %Withdraw (key %from) (mutez %withdraw_amount) (signature %sig))) - (map :stored_balance key_hash mutez) ] */ ; + (map key_hash mutez) ] */ ; DUP /* [ pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (key %from) (mutez %withdraw_amount) (signature %sig) @@ -95,7 +91,7 @@ Gas remaining: 1039925.145 units remaining : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (or (key_hash %Initialize) (pair %Withdraw (key %from) (mutez %withdraw_amount) (signature %sig))) - (map :stored_balance key_hash mutez) ] */ ; + (map key_hash mutez) ] */ ; CAR %from /* [ key : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (key %from) (mutez %withdraw_amount) (signature %sig) @@ -103,217 +99,217 @@ Gas remaining: 1039925.145 units remaining : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (or (key_hash %Initialize) (pair %Withdraw (key %from) (mutez %withdraw_amount) (signature %sig))) - (map :stored_balance key_hash mutez) ] */ ; + (map key_hash mutez) ] */ ; DIIP { CDAR %withdraw_amount ; PACK /* [ bytes : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (or (key_hash %Initialize) (pair %Withdraw (key %from) (mutez %withdraw_amount) (signature %sig))) - (map :stored_balance key_hash mutez) ] */ ; + (map key_hash mutez) ] */ ; BLAKE2B @signed_amount /* [ bytes : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (or (key_hash %Initialize) (pair %Withdraw (key %from) (mutez %withdraw_amount) (signature %sig))) - (map :stored_balance key_hash mutez) ] */ } + (map key_hash mutez) ] */ } /* [ key : pair (key %from) (mutez %withdraw_amount) (signature %sig) : bytes : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (or (key_hash %Initialize) (pair %Withdraw (key %from) (mutez %withdraw_amount) (signature %sig))) - (map :stored_balance key_hash mutez) ] */ ; + (map key_hash mutez) ] */ ; DIP { CDDR %sig } /* [ key : signature : bytes : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (or (key_hash %Initialize) (pair %Withdraw (key %from) (mutez %withdraw_amount) (signature %sig))) - (map :stored_balance key_hash mutez) ] */ ; + (map key_hash mutez) ] */ ; CHECK_SIGNATURE /* [ bool : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (or (key_hash %Initialize) (pair %Withdraw (key %from) (mutez %withdraw_amount) (signature %sig))) - (map :stored_balance key_hash mutez) ] */ ; + (map key_hash mutez) ] */ ; IF { /* [ pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (or (key_hash %Initialize) (pair %Withdraw (key %from) (mutez %withdraw_amount) (signature %sig))) - (map :stored_balance key_hash mutez) ] */ } + (map key_hash mutez) ] */ } { PUSH string "Bad signature" /* [ string : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (or (key_hash %Initialize) (pair %Withdraw (key %from) (mutez %withdraw_amount) (signature %sig))) - (map :stored_balance key_hash mutez) ] */ ; + (map key_hash mutez) ] */ ; FAILWITH /* [] */ } ; DIIP { CDR %stored_balance - /* [ map :stored_balance key_hash mutez ] */ ; + /* [ map key_hash mutez ] */ ; DUP - /* [ map :stored_balance key_hash mutez : map :stored_balance key_hash mutez ] */ } + /* [ map key_hash mutez : map key_hash mutez ] */ } /* [ pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez : map key_hash mutez ] */ ; CAR %from /* [ key : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez : map key_hash mutez ] */ ; HASH_KEY @from_hash /* [ key_hash : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez : map key_hash mutez ] */ ; DUP /* [ key_hash : key_hash : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez : map key_hash mutez ] */ ; DIP { DIP { SWAP - /* [ map :stored_balance key_hash mutez + /* [ map key_hash mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ } - /* [ key_hash : map :stored_balance key_hash mutez + : map key_hash mutez ] */ } + /* [ key_hash : map key_hash mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez ] */ ; SWAP - /* [ map :stored_balance key_hash mutez : key_hash + /* [ map key_hash mutez : key_hash : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ } - /* [ key_hash : map :stored_balance key_hash mutez : key_hash + : map key_hash mutez ] */ } + /* [ key_hash : map key_hash mutez : key_hash : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez ] */ ; GET /* [ option mutez : key_hash : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez ] */ ; IF_NONE { PUSH string "Account does not exist" /* [ string : key_hash : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez ] */ ; PAIR /* [ pair string key_hash : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez ] */ ; FAILWITH /* [] */ } { RENAME @previous_balance /* [ mutez : key_hash : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez ] */ ; DIP { DROP /* [ pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ } + : map key_hash mutez ] */ } /* [ mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez ] */ ; DUP /* [ mutez : mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez ] */ ; DIIP { DUP /* [ pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez ] */ ; CDAR %withdraw_amount ; DUP /* [ mutez : mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ } + : map key_hash mutez ] */ } /* [ mutez : mutez : mutez : mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez ] */ ; DIP { CMPLT @not_enough } /* [ mutez : bool : mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez ] */ ; SWAP /* [ bool : mutez : mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez ] */ ; IF { PUSH string "Not enough funds" /* [ string : mutez : mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez ] */ ; FAILWITH /* [] */ } { SUB_MUTEZ @new_balance /* [ option mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez ] */ ; ASSERT_SOME ; DIP { DUP /* [ pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez ] */ ; DIP { SWAP - /* [ map :stored_balance key_hash mutez + /* [ map key_hash mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) ] */ } /* [ pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez + : map key_hash mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) ] */ } /* [ mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez + : map key_hash mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) ] */ ; DUP /* [ mutez : mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez + : map key_hash mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) ] */ ; PUSH @zero mutez 0 /* [ mutez : mutez : mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez + : map key_hash mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) ] */ ; CMPEQ @null_balance ; IF { DROP /* [ pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez + : map key_hash mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) ] */ ; NONE @new_balance mutez /* [ option mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez + : map key_hash mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) ] */ } { SOME @new_balance /* [ option mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez + : map key_hash mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) ] */ } ; SWAP /* [ pair (key %from) (mutez %withdraw_amount) (signature %sig) : option mutez - : map :stored_balance key_hash mutez + : map key_hash mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) ] */ ; CAR %from - /* [ key : option mutez : map :stored_balance key_hash mutez + /* [ key : option mutez : map key_hash mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) ] */ ; HASH_KEY @from_hash - /* [ key_hash : option mutez : map :stored_balance key_hash mutez + /* [ key_hash : option mutez : map key_hash mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) ] */ ; UPDATE - /* [ map :stored_balance key_hash mutez + /* [ map key_hash mutez : pair (key %from) (mutez %withdraw_amount) (signature %sig) ] */ ; SWAP /* [ pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez ] */ ; DUP /* [ pair (key %from) (mutez %withdraw_amount) (signature %sig) : pair (key %from) (mutez %withdraw_amount) (signature %sig) - : map :stored_balance key_hash mutez ] */ ; + : map key_hash mutez ] */ ; CDAR %withdraw_amount ; DIP { CAR %from - /* [ key : map :stored_balance key_hash mutez ] */ ; + /* [ key : map key_hash mutez ] */ ; HASH_KEY @from_hash - /* [ key_hash : map :stored_balance key_hash mutez ] */ ; + /* [ key_hash : map key_hash mutez ] */ ; IMPLICIT_ACCOUNT @from_account - /* [ contract unit : map :stored_balance key_hash mutez ] */ } - /* [ mutez : contract unit : map :stored_balance key_hash mutez ] */ ; + /* [ contract unit : map key_hash mutez ] */ } + /* [ mutez : contract unit : map key_hash mutez ] */ ; UNIT - /* [ unit : mutez : contract unit : map :stored_balance key_hash mutez ] */ ; + /* [ unit : mutez : contract unit : map key_hash mutez ] */ ; TRANSFER_TOKENS @withdraw_transfer_op - /* [ operation : map :stored_balance key_hash mutez ] */ ; + /* [ operation : map key_hash mutez ] */ ; NIL operation - /* [ list operation : operation : map :stored_balance key_hash mutez ] */ ; + /* [ list operation : operation : map key_hash mutez ] */ ; SWAP - /* [ operation : list operation : map :stored_balance key_hash mutez ] */ ; + /* [ operation : list operation : map key_hash mutez ] */ ; CONS - /* [ list operation : map :stored_balance key_hash mutez ] */ ; + /* [ list operation : map key_hash mutez ] */ ; PAIR - /* [ pair (list operation) (map :stored_balance key_hash mutez) ] */ } } } } } + /* [ pair (list operation) (map key_hash mutez) ] */ } } } } } diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[macros--unpair_macro.tz].out b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[macros--unpair_macro.tz].out index 2daa0cca804a..1d2fe26c5b24 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[macros--unpair_macro.tz].out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[macros--unpair_macro.tz].out @@ -7,26 +7,26 @@ Gas remaining: 1039976.490 units remaining code { DROP /* [] */ ; UNIT :u4 @a4 - /* [ unit :u4 ] */ ; + /* [ unit ] */ ; UNIT :u3 @a3 - /* [ unit :u3 : unit :u4 ] */ ; + /* [ unit : unit ] */ ; UNIT :u2 @a2 - /* [ unit :u2 : unit :u3 : unit :u4 ] */ ; + /* [ unit : unit : unit ] */ ; UNIT :u1 @a1 - /* [ unit :u1 : unit :u2 : unit :u3 : unit :u4 ] */ ; + /* [ unit : unit : unit : unit ] */ ; PAIR - /* [ pair (unit :u1) (unit :u2) : unit :u3 : unit :u4 ] */ ; + /* [ pair unit unit : unit : unit ] */ ; UNPAIR @x1 @x2 - /* [ unit :u1 : unit :u2 : unit :u3 : unit :u4 ] */ ; + /* [ unit : unit : unit : unit ] */ ; PPAIPAIR @p1 %x1 %x2 %x3 %x4 ; UNPPAIPAIR %x1 % %x3 %x4 @uno @due @tre @quattro ; PAPAPAIR @p2 %x1 %x2 %x3 %x4 ; UNPAPAPAIR @un @deux @trois @quatre ; PAPPAIIR @p3 %x1 %x2 %x3 %x4 ; UNPAPPAIIR @one @two @three @four ; - DIP { DROP /* [ unit :u3 : unit :u4 ] */ ; DROP /* [ unit :u4 ] */ ; DROP /* [] */ } - /* [ unit :u1 ] */ ; + DIP { DROP /* [ unit : unit ] */ ; DROP /* [ unit ] */ ; DROP /* [] */ } + /* [ unit ] */ ; NIL operation - /* [ list operation : unit :u1 ] */ ; + /* [ list operation : unit ] */ ; PAIR - /* [ pair (list operation) (unit :u1) ] */ } } + /* [ pair (list operation) unit ] */ } } diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[mini_scenarios--generic_multisig.tz].out b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[mini_scenarios--generic_multisig.tz].out index d04a4b6064a4..ad864de134b2 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[mini_scenarios--generic_multisig.tz].out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[mini_scenarios--generic_multisig.tz].out @@ -15,11 +15,9 @@ Gas remaining: 1039928.421 units remaining code { UNPAIR /* [ or (unit %default) (pair %main - (pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)))) + (pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)))) (list %sigs (option signature))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; IF_LEFT @@ -33,374 +31,298 @@ Gas remaining: 1039928.421 units remaining { PUSH mutez 0 /* [ mutez - : pair (pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)))) + : pair (pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)))) (list %sigs (option signature)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; AMOUNT /* [ mutez : mutez - : pair (pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)))) + : pair (pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)))) (list %sigs (option signature)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; ASSERT_CMPEQ ; SWAP /* [ pair (nat %stored_counter) (nat %threshold) (list %keys key) - : pair (pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)))) + : pair (pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)))) (list %sigs (option signature)) ] */ ; DUP /* [ pair (nat %stored_counter) (nat %threshold) (list %keys key) : pair (nat %stored_counter) (nat %threshold) (list %keys key) - : pair (pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)))) + : pair (pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)))) (list %sigs (option signature)) ] */ ; DIP { SWAP - /* [ pair (pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)))) + /* [ pair (pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)))) (list %sigs (option signature)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ pair (nat %stored_counter) (nat %threshold) (list %keys key) - : pair (pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)))) + : pair (pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)))) (list %sigs (option signature)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DIP { UNPAIR - /* [ pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key))) + /* [ pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key))) : list (option signature) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DUP - /* [ pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key))) - : pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key))) + /* [ pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key))) + : pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key))) : list (option signature) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; SELF /* [ contract unit - : pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key))) - : pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key))) + : pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key))) + : pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key))) : list (option signature) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; ADDRESS /* [ address - : pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key))) - : pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key))) + : pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key))) + : pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key))) : list (option signature) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; CHAIN_ID /* [ chain_id : address - : pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key))) - : pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key))) + : pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key))) + : pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key))) : list (option signature) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; PAIR /* [ pair chain_id address - : pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key))) - : pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key))) + : pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key))) + : pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key))) : list (option signature) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; PAIR /* [ pair (pair chain_id address) - (pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)))) - : pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key))) + (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key))) + : pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key))) : list (option signature) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; PACK /* [ bytes - : pair :payload - (nat %counter) - (or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key))) + : pair (nat %counter) + (or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key))) : list (option signature) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DIP { UNPAIR @counter /* [ nat - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : list (option signature) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DIP { SWAP /* [ list (option signature) - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ nat : list (option signature) - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ bytes : nat : list (option signature) - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; SWAP /* [ nat : bytes : list (option signature) - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ pair (nat %stored_counter) (nat %threshold) (list %keys key) : nat : bytes : list (option signature) - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; UNPAIR @stored_counter /* [ nat : pair (nat %threshold) (list %keys key) : nat : bytes : list (option signature) - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DIP { SWAP /* [ nat : pair (nat %threshold) (list %keys key) : bytes : list (option signature) - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ nat : nat : pair (nat %threshold) (list %keys key) : bytes : list (option signature) - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; ASSERT_CMPEQ ; DIP { SWAP /* [ list (option signature) : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ pair (nat %threshold) (list %keys key) : list (option signature) : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; UNPAIR @threshold @keys /* [ nat : list key : list (option signature) : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DIP { PUSH @valid nat 0 /* [ nat : list key : list (option signature) : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; SWAP /* [ list key : nat : list (option signature) : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; ITER { DIP { SWAP /* [ list (option signature) : nat : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ key : list (option signature) : nat : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; SWAP /* [ list (option signature) : key : nat : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; IF_CONS { IF_SOME { SWAP /* [ list (option signature) : signature : key : nat : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DIP { SWAP /* [ key : signature : nat : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DIIP { DUUP /* [ bytes : nat : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ key : signature : bytes : nat : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; { DUUUP /* [ bytes : key : signature : bytes : nat : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DIP { CHECK_SIGNATURE /* [ bool : nat : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ bytes : bool : nat : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; SWAP /* [ bool : bytes : nat : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; IF { DROP /* [ nat : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } { FAILWITH /* [] */ } } ; PUSH nat 1 /* [ nat : nat : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; ADD @valid /* [ nat : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ list (option signature) : nat : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } { SWAP /* [ key : list (option signature) : nat : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DROP /* [ list (option signature) : nat : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } } { FAIL } ; SWAP /* [ nat : list (option signature) : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ nat : list (option signature) : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ nat : nat : list (option signature) : bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; ASSERT_CMPLE ; IF_CONS { FAIL } { /* [ bytes - : or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + : or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } ; DROP - /* [ or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + /* [ or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DIP { UNPAIR /* [ nat : pair (nat %threshold) (list %keys key) ] */ ; @@ -410,9 +332,8 @@ Gas remaining: 1039928.421 units remaining /* [ nat : pair (nat %threshold) (list %keys key) ] */ ; PAIR /* [ pair nat (nat %threshold) (list %keys key) ] */ } - /* [ or :action - (lambda %operation unit (list operation)) - (pair %change_keys (nat %threshold) (list %keys key)) + /* [ or (lambda %operation unit (list operation)) + (pair %change_keys (nat %threshold) (list %keys key)) : pair nat (nat %threshold) (list %keys key) ] */ ; IF_LEFT { UNIT diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[mini_scenarios--legacy_multisig.tz].out b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[mini_scenarios--legacy_multisig.tz].out index 45564ca3bf24..35be1213a384 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[mini_scenarios--legacy_multisig.tz].out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[mini_scenarios--legacy_multisig.tz].out @@ -12,425 +12,349 @@ Gas remaining: 1039931.026 units remaining (list %sigs (option signature))) ; storage (pair (nat %stored_counter) (pair (nat %threshold) (list %keys key))) ; code { UNPAIR - /* [ pair (pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))))) + /* [ pair (pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))))) (list %sigs (option signature)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; SWAP /* [ pair (nat %stored_counter) (nat %threshold) (list %keys key) - : pair (pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))))) + : pair (pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))))) (list %sigs (option signature)) ] */ ; DUP /* [ pair (nat %stored_counter) (nat %threshold) (list %keys key) : pair (nat %stored_counter) (nat %threshold) (list %keys key) - : pair (pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))))) + : pair (pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))))) (list %sigs (option signature)) ] */ ; DIP { SWAP - /* [ pair (pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))))) + /* [ pair (pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))))) (list %sigs (option signature)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ pair (nat %stored_counter) (nat %threshold) (list %keys key) - : pair (pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))))) + : pair (pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))))) (list %sigs (option signature)) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DIP { UNPAIR - /* [ pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key)))) + /* [ pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key)))) : list (option signature) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DUP - /* [ pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key)))) - : pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key)))) + /* [ pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key)))) + : pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key)))) : list (option signature) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; SELF /* [ contract - (pair (pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))))) + (pair (pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))))) (list %sigs (option signature))) - : pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key)))) - : pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key)))) + : pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key)))) + : pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key)))) : list (option signature) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; ADDRESS /* [ address - : pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key)))) - : pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key)))) + : pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key)))) + : pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key)))) : list (option signature) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; CHAIN_ID /* [ chain_id : address - : pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key)))) - : pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key)))) + : pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key)))) + : pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key)))) : list (option signature) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; PAIR /* [ pair chain_id address - : pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key)))) - : pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key)))) + : pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key)))) + : pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key)))) : list (option signature) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; PAIR /* [ pair (pair chain_id address) - (pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))))) - : pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key)))) + (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key)))) + : pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key)))) : list (option signature) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; PACK /* [ bytes - : pair :payload - (nat %counter) - (or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key)))) + : pair (nat %counter) + (or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key)))) : list (option signature) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DIP { UNPAIR @counter /* [ nat - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : list (option signature) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DIP { SWAP /* [ list (option signature) - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ nat : list (option signature) - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ bytes : nat : list (option signature) - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; SWAP /* [ nat : bytes : list (option signature) - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ pair (nat %stored_counter) (nat %threshold) (list %keys key) : nat : bytes : list (option signature) - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; UNPAIR @stored_counter /* [ nat : pair (nat %threshold) (list %keys key) : nat : bytes : list (option signature) - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DIP { SWAP /* [ nat : pair (nat %threshold) (list %keys key) : bytes : list (option signature) - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ nat : nat : pair (nat %threshold) (list %keys key) : bytes : list (option signature) - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; ASSERT_CMPEQ ; DIP { SWAP /* [ list (option signature) : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ pair (nat %threshold) (list %keys key) : list (option signature) : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; UNPAIR @threshold @keys /* [ nat : list key : list (option signature) : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DIP { PUSH @valid nat 0 /* [ nat : list key : list (option signature) : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; SWAP /* [ list key : nat : list (option signature) : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; ITER { DIP { SWAP /* [ list (option signature) : nat : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ key : list (option signature) : nat : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; SWAP /* [ list (option signature) : key : nat : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; IF_CONS { IF_SOME { SWAP /* [ list (option signature) : signature : key : nat : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DIP { SWAP /* [ key : signature : nat : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DIIP { DUUP /* [ bytes : nat : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ key : signature : bytes : nat : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; { DUUUP /* [ bytes : key : signature : bytes : nat : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DIP { CHECK_SIGNATURE /* [ bool : nat : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ bytes : bool : nat : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; SWAP /* [ bool : bytes : nat : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; IF { DROP /* [ nat : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } { FAILWITH /* [] */ } } ; PUSH nat 1 /* [ nat : nat : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; ADD @valid /* [ nat : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ list (option signature) : nat : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } { SWAP /* [ key : list (option signature) : nat : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DROP /* [ list (option signature) : nat : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } } { FAIL } ; SWAP /* [ nat : list (option signature) : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ nat : list (option signature) : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ } /* [ nat : nat : list (option signature) : bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; ASSERT_CMPLE ; DROP /* [ bytes - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DROP - /* [ or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + /* [ or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair (nat %stored_counter) (nat %threshold) (list %keys key) ] */ ; DIP { UNPAIR /* [ nat : pair (nat %threshold) (list %keys key) ] */ ; @@ -440,24 +364,21 @@ Gas remaining: 1039931.026 units remaining /* [ nat : pair (nat %threshold) (list %keys key) ] */ ; PAIR /* [ pair nat (nat %threshold) (list %keys key) ] */ } - /* [ or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + /* [ or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair nat (nat %threshold) (list %keys key) ] */ ; NIL operation /* [ list operation - : or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) + : or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) : pair nat (nat %threshold) (list %keys key) ] */ ; SWAP - /* [ or :action - (pair :transfer (mutez %amount) (contract %dest unit)) - (or (option %delegate key_hash) - (pair %change_keys (nat %threshold) (list %keys key))) : list operation - : pair nat (nat %threshold) (list %keys key) ] */ ; + /* [ or (pair (mutez %amount) (contract %dest unit)) + (or (option %delegate key_hash) + (pair %change_keys (nat %threshold) (list %keys key))) + : list operation : pair nat (nat %threshold) (list %keys key) ] */ ; IF_LEFT { UNPAIR /* [ mutez : contract unit : list operation diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[mini_scenarios--weather_insurance.tz].out b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[mini_scenarios--weather_insurance.tz].out index 4fc3d59179ba..8532e62834e8 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[mini_scenarios--weather_insurance.tz].out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[mini_scenarios--weather_insurance.tz].out @@ -7,218 +7,218 @@ Gas remaining: 1039960.200 units remaining (pair (pair (address %under_key) (address %over_key)) (pair (nat :rain %rain_level) (key %weather_service_key))) ; code { DUP - /* [ pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + /* [ pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; DUP - /* [ pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + /* [ pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; CAR - /* [ pair (signature %signed_weather_data) (nat :rain %actual_level) - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + /* [ pair (signature %signed_weather_data) (nat %actual_level) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; MAP_CDR { PACK - /* [ bytes : pair (signature %signed_weather_data) (nat :rain %actual_level) - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + /* [ bytes : pair (signature %signed_weather_data) (nat %actual_level) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; BLAKE2B - /* [ bytes : pair (signature %signed_weather_data) (nat :rain %actual_level) - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + /* [ bytes : pair (signature %signed_weather_data) (nat %actual_level) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ } ; SWAP - /* [ pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + /* [ pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) : pair signature bytes - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; CDDDR %weather_service_key ; DIP { UNPAIR /* [ signature : bytes - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ } /* [ key : signature : bytes - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; CHECK_SIGNATURE @sigok /* [ bool - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; ASSERT ; DUP - /* [ pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + /* [ pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; DUP - /* [ pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + /* [ pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; DUP - /* [ pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + /* [ pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; DIIIP { CDR %storage /* [ pair (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ } - /* [ pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + /* [ pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) : pair (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; DIIP { CDAR } - /* [ pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + /* [ pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) - : pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + : pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) : pair (address %under_key) (address %over_key) : pair (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; DIP { CADR %actual_level } - /* [ pair (pair (signature %signed_weather_data) (nat :rain %actual_level)) + /* [ pair (pair (signature %signed_weather_data) (nat %actual_level)) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) - (key %weather_service_key) : nat :rain + (nat %rain_level) + (key %weather_service_key) : nat : pair (address %under_key) (address %over_key) : pair (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; CDDAR %rain_level ; CMPLT ; IF { CAR %under_key /* [ address : pair (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ } { CDR %over_key /* [ address : pair (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ } ; CONTRACT unit /* [ option (contract unit) : pair (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; ASSERT_SOME ; BALANCE /* [ mutez : contract unit : pair (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; UNIT /* [ unit : mutez : contract unit : pair (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; TRANSFER_TOKENS @trans.op /* [ operation : pair (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; NIL operation /* [ list operation : operation : pair (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; SWAP /* [ operation : list operation : pair (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; CONS /* [ list operation : pair (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ ; PAIR /* [ pair (list operation) (pair (address %under_key) (address %over_key)) - (nat :rain %rain_level) + (nat %rain_level) (key %weather_service_key) ] */ } } diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[opcodes--and.tz].out b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[opcodes--and.tz].out index c248d20f7b28..068b109a080c 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[opcodes--and.tz].out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[opcodes--and.tz].out @@ -5,7 +5,7 @@ Gas remaining: 1039994.393 units remaining { parameter (pair :param (bool %first) (bool %second)) ; storage (option bool) ; code { CAR - /* [ pair :param (bool %first) (bool %second) ] */ ; + /* [ pair (bool %first) (bool %second) ] */ ; UNPAIR /* [ bool : bool ] */ ; AND @and diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[opcodes--car.tz].out b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[opcodes--car.tz].out index 1ff040e52276..320069d54a27 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[opcodes--car.tz].out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[opcodes--car.tz].out @@ -5,10 +5,10 @@ Gas remaining: 1039996.637 units remaining { parameter (pair (nat :l) (nat :r)) ; storage nat ; code { CAR - /* [ pair (nat :l) (nat :r) ] */ ; + /* [ pair nat nat ] */ ; CAR - /* [ nat :l ] */ ; + /* [ nat ] */ ; NIL operation - /* [ list operation : nat :l ] */ ; + /* [ list operation : nat ] */ ; PAIR - /* [ pair (list operation) (nat :l) ] */ } } + /* [ pair (list operation) nat ] */ } } diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[opcodes--cdr.tz].out b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[opcodes--cdr.tz].out index fed4de220bc2..410cd3fc8699 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[opcodes--cdr.tz].out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[opcodes--cdr.tz].out @@ -5,10 +5,10 @@ Gas remaining: 1039996.637 units remaining { parameter (pair (nat :l) (nat :r)) ; storage nat ; code { CAR - /* [ pair (nat :l) (nat :r) ] */ ; + /* [ pair nat nat ] */ ; CDR - /* [ nat :r ] */ ; + /* [ nat ] */ ; NIL operation - /* [ list operation : nat :r ] */ ; + /* [ list operation : nat ] */ ; PAIR - /* [ pair (list operation) (nat :r) ] */ } } + /* [ pair (list operation) nat ] */ } } diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[opcodes--map_iter.tz].out b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[opcodes--map_iter.tz].out index 4aae424dee4f..f7f86bc73581 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[opcodes--map_iter.tz].out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestTypecheck::test_typecheck[opcodes--map_iter.tz].out @@ -5,34 +5,34 @@ Gas remaining: 1039985.509 units remaining { parameter (map (int :k) (int :e)) ; storage (pair (int :k) (int :e)) ; code { CAR - /* [ map (int :k) (int :e) ] */ ; + /* [ map int int ] */ ; PUSH @acc_e (int :e) 0 - /* [ int :e : map (int :k) (int :e) ] */ ; + /* [ int : map int int ] */ ; PUSH @acc_k (int :k) 0 - /* [ int :k : int :e : map (int :k) (int :e) ] */ ; + /* [ int : int : map int int ] */ ; PAIR % %r - /* [ pair (int :k) (int :e %r) : map (int :k) (int :e) ] */ ; + /* [ pair int (int %r) : map int int ] */ ; SWAP - /* [ map (int :k) (int :e) : pair (int :k) (int :e %r) ] */ ; + /* [ map int int : pair int (int %r) ] */ ; ITER { DIP { DUP - /* [ pair (int :k) (int :e %r) : pair (int :k) (int :e %r) ] */ ; + /* [ pair int (int %r) : pair int (int %r) ] */ ; CAR - /* [ int :k : pair (int :k) (int :e %r) ] */ ; - DIP { CDR /* [ int :e ] */ } - /* [ int :k : int :e ] */ } - /* [ pair (int :k) (int :e) : int :k : int :e ] */ ; + /* [ int : pair int (int %r) ] */ ; + DIP { CDR /* [ int ] */ } + /* [ int : int ] */ } + /* [ pair int int : int : int ] */ ; DUP - /* [ pair (int :k) (int :e) : pair (int :k) (int :e) : int :k : int :e ] */ ; - DIP { CAR /* [ int :k : int :k : int :e ] */ ; ADD /* [ int :k : int :e ] */ } - /* [ pair (int :k) (int :e) : int :k : int :e ] */ ; + /* [ pair int int : pair int int : int : int ] */ ; + DIP { CAR /* [ int : int : int ] */ ; ADD /* [ int : int ] */ } + /* [ pair int int : int : int ] */ ; SWAP - /* [ int :k : pair (int :k) (int :e) : int :e ] */ ; - DIP { CDR /* [ int :e : int :e ] */ ; ADD /* [ int :e ] */ } - /* [ int :k : int :e ] */ ; + /* [ int : pair int int : int ] */ ; + DIP { CDR /* [ int : int ] */ ; ADD /* [ int ] */ } + /* [ int : int ] */ ; PAIR % %r - /* [ pair (int :k) (int :e %r) ] */ } - /* [ pair (int :k) (int :e %r) ] */ ; + /* [ pair int (int %r) ] */ } + /* [ pair int (int %r) ] */ ; NIL operation - /* [ list operation : pair (int :k) (int :e %r) ] */ ; + /* [ list operation : pair int (int %r) ] */ ; PAIR - /* [ pair (list operation) (int :k) (int :e %r) ] */ } } + /* [ pair (list operation) int (int %r) ] */ } } -- GitLab From 20defc3c1fb59cc0a0beccacc352e0c32114ae43 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 12 Jan 2022 19:13:55 +0100 Subject: [PATCH 21/23] Proto/Tests: adapt script cache hard-coded values --- .../test/integration/michelson/test_script_cache.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_cache.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_cache.ml index 1ab7e06a7c2c..d080cb9daac8 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_cache.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_cache.ml @@ -46,7 +46,7 @@ let err x = Exn (Script_cache_test_error x) model. It has been computed by a manual run of the test. *) -let liquidity_baking_contract_size = 289783 +let liquidity_baking_contract_size = 275006 let liquidity_baking_contract = Contract.of_b58check "KT1TxqZ8QtKvLu3V3JH7Gx58n7Co8pgtpQU5" |> function @@ -120,7 +120,7 @@ let add_some_contracts k src block baker = model. It has been computed by a manual run of the test. *) -let int_store_contract_size = 1406 +let int_store_contract_size = 1042 (* -- GitLab From ae85e5b55110411133b9ec919da153b253d8c438 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 13 Jan 2022 11:03:33 +0100 Subject: [PATCH 22/23] Proto/Doc: add entry in changelog --- docs/protocols/alpha.rst | 3 +++ 1 file changed, 3 insertions(+) diff --git a/docs/protocols/alpha.rst b/docs/protocols/alpha.rst index d1110e8e078e..40d4f92cd94b 100644 --- a/docs/protocols/alpha.rst +++ b/docs/protocols/alpha.rst @@ -53,6 +53,9 @@ Michelson - Variable annotations in pairs are ignored and not propagated. (MR :gl:`!4140`) +- Type annotations are ignored and not propagated. + (MR :gl:`!4141`) + Internal -------- -- GitLab From a18070109b695e78ba66cb7d8226d2ecc2298ca7 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 11 Jan 2021 16:49:21 +0100 Subject: [PATCH 23/23] Proto/Michelson: remove dead values --- src/proto_alpha/lib_protocol/script_ir_annot.ml | 3 --- src/proto_alpha/lib_protocol/script_ir_annot.mli | 4 ---- .../test/integration/michelson/test_typechecking.ml | 2 -- 3 files changed, 9 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index f617efc9b626..cae86bb3bd38 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -35,9 +35,6 @@ type type_annot = Type_annot of Non_empty_string.t [@@ocaml.unboxed] type field_annot = Field_annot of Non_empty_string.t [@@ocaml.unboxed] module FOR_TESTS = struct - let unsafe_type_annot_of_string s = - Type_annot (Non_empty_string.of_string_exn s) - let unsafe_field_annot_of_string s = Field_annot (Non_empty_string.of_string_exn s) end diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index 4860789c8076..7d6035356aa0 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -26,13 +26,9 @@ open Alpha_context -type type_annot = private Type_annot of Non_empty_string.t [@@ocaml.unboxed] - type field_annot = private Field_annot of Non_empty_string.t [@@ocaml.unboxed] module FOR_TESTS : sig - val unsafe_type_annot_of_string : string -> type_annot - val unsafe_field_annot_of_string : string -> field_annot end 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 4ab80c5a7e8f..a06e3c575691 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 @@ -179,8 +179,6 @@ let test_parse_ty ctxt node expected = Script_ir_translator.ty_eq ctxt (location node) actual expected >|? fun (_, ctxt) -> ctxt ) -let type_annot = Script_ir_annot.FOR_TESTS.unsafe_type_annot_of_string - let field_annot = Script_ir_annot.FOR_TESTS.unsafe_field_annot_of_string let test_parse_comb_type () = -- GitLab