balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Michelson: propagate variable annotations inside pairs in stack type

Browse Source 
Also check that tyoe annotated constants are correct, but don't produce
annotated constants when unparsing.
This commit is contained in:
Alain Mebsout 2018-06-08 19:08:46 +02:00 committed by Benjamin Canou
parent fcd9b61084
commit eb5837943f
5 changed files with 130 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/bin_client/test/test_contracts.sh
View File

@ -297,6 +297,7 @@ assert_storage $contract_dir/if_some.tz '"?"' 'None' '""'
assert_storage $contract_dir/set_car.tz '(Pair "hello" 0)' '"world"' '(Pair "world" 0)'
assert_storage $contract_dir/set_car.tz '(Pair "hello" 0)' '"abc"' '(Pair "abc" 0)'
assert_storage $contract_dir/set_car.tz '(Pair "hello" 0)' '""' '(Pair "" 0)'
assert_fails $client run program $contract_dir/set_car.tz on storage '(Pair %wrong %field "hello" 0)' Unit and input '""'
assert_storage $contract_dir/set_cdr.tz '(Pair "hello" 0)' '1' '(Pair "hello" 1)'
assert_storage $contract_dir/set_cdr.tz '(Pair "hello" 500)' '3' '(Pair "hello" 3)'

38
src/proto_alpha/lib_protocol/src/script_ir_annot.ml
View File

@ -19,9 +19,9 @@ let default_steps_annot = Some (`Var_annot "steps")
let default_source_annot = Some (`Var_annot "source")
let default_self_annot = Some (`Var_annot "self")
let default_arg_annot = Some (`Var_annot "arg")
let default_param_annot = Some (`Var_annot "parameter")
let default_storage_annot = Some (`Var_annot "storage")
let default_param_annot = Some (`Field_annot "parameter")
let default_storage_annot = Some (`Field_annot "storage")
let default_car_annot = Some (`Field_annot "car")
let default_cdr_annot = Some (`Field_annot "cdr")
let default_contract_annot = Some (`Field_annot "contract")
@ -54,10 +54,10 @@ let field_to_var_annot : field_annot option -> var_annot option =
| None -> None
| Some (`Field_annot s) -> Some (`Var_annot s)
let type_to_field_annot : type_annot option -> field_annot option =
let type_to_var_annot : type_annot option -> var_annot option =
function
| None -> None
| Some (`Type_annot s) -> Some (`Field_annot s)
| Some (`Type_annot s) -> Some (`Var_annot s)
let var_to_field_annot : var_annot option -> field_annot option =
function
@ -206,6 +206,16 @@ let parse_type_annot
error_unexpected_annot loc fields >>? fun () ->
get_one_annot loc types
let parse_type_field_annot
: int -> string list -> (type_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_one_annot loc fields >|? fun f ->
(t, f)
let parse_composed_type_annot
: int -> string list -> (type_annot option * field_annot option * field_annot option) tzresult
= fun loc annot ->
@ -217,10 +227,24 @@ let parse_composed_type_annot
(t, f1, f2)
let check_const_type_annot
: int -> string list -> type_annot option -> unit tzresult Lwt.t
= fun loc annot expected_annot ->
: int -> string list -> type_annot option -> field_annot option list -> unit tzresult Lwt.t
= fun loc annot expected_name expected_fields ->
Lwt.return
(parse_type_annot loc annot >>? merge_type_annot expected_annot >|? fun _ -> ())
(parse_composed_type_annot loc annot >>? fun (ty_name, field1, field2) ->
merge_type_annot expected_name ty_name >>? fun _ ->
match expected_fields, field1, field2 with
| [], Some _, _ | [], _, Some _ | [_], Some _, Some _ ->
(* Too many annotations *)
error (Unexpected_annotation loc)
| _ :: _ :: _ :: _, _, _ | [_], None, Some _ ->
error (Unexpected_annotation loc)
| [], None, None -> ok ()
| [ f1; f2 ], _, _ ->
merge_field_annot f1 field1 >>? fun _ ->
merge_field_annot f2 field2 >|? fun _ -> ()
| [ f1 ], _, None ->
merge_field_annot f1 field1 >|? fun _ -> ()
)
let parse_field_annot
: int -> string list -> field_annot option tzresult

17
src/proto_alpha/lib_protocol/src/script_ir_annot.mli
View File

@ -19,9 +19,9 @@ val default_steps_annot : var_annot option
val default_source_annot : var_annot option
val default_self_annot : var_annot option
val default_arg_annot : var_annot option
val default_param_annot : var_annot option
val default_storage_annot : var_annot option
val default_param_annot : field_annot option
val default_storage_annot : field_annot option
val default_car_annot : field_annot option
val default_cdr_annot : field_annot option
val default_contract_annot : field_annot option
@ -46,7 +46,7 @@ val unparse_field_annot : field_annot option -> string list
(** Convertions functions between different annotation kinds *)
val field_to_var_annot : field_annot option -> var_annot option
val type_to_field_annot : type_annot option -> field_annot option
val type_to_var_annot : type_annot option -> var_annot option
val var_to_field_annot : var_annot option -> field_annot option
(** Replace an annotation by its default value if it is [None] *)
@ -82,18 +82,25 @@ val fail_unexpected_annot : int -> 'a list -> unit tzresult Lwt.t
(** Parse a type annotation only. *)
val parse_type_annot : int -> string list -> type_annot option tzresult
(** Parse a field annotation only. *)
val parse_field_annot :
int -> string list -> field_annot option tzresult
(** Parse an annotation for composed types, of the form
[:ty_name %field] in any order. *)
val parse_type_field_annot :
int -> string list -> (type_annot option * field_annot option) tzresult
(** Parse an annotation for composed types, of the form
[:ty_name %field1 %field2] in any order. *)
val parse_composed_type_annot :
int -> string list ->
(type_annot option * field_annot option * field_annot option) tzresult
(** Check that type annotations are consistent *)
(** Check that type annotations on constants are consistent *)
val check_const_type_annot :
int -> string list -> type_annot option -> unit tzresult Lwt.t
int -> string list -> type_annot option -> field_annot option list ->
unit tzresult Lwt.t
(** Extract and remove a field annotation from a node *)
val extract_field_annot :

146
src/proto_alpha/lib_protocol/src/script_ir_translator.ml
View File

@ -63,7 +63,7 @@ let rec type_size : type t. t ty -> int =
| Address_t _ -> 1
| Bool_t _ -> 1
| Operation_t _ -> 1
| Pair_t ((l, _), (r, _), _) ->
| Pair_t ((l, _, _), (r, _, _), _) ->
1 + type_size l + type_size r
| Union_t ((l, _), (r, _), _) ->
1 + type_size l + type_size r
@ -517,9 +517,9 @@ let unparse_comparable_ty
| Timestamp_key tname -> Prim (-1, T_timestamp, [], unparse_type_annot tname)
| Address_key tname -> Prim (-1, T_address, [], unparse_type_annot tname)
let add_field_annot a = function
let add_field_annot a var = function
| Prim (loc, prim, args, annots) ->
Prim (loc, prim, args, annots @ (unparse_field_annot a) )
Prim (loc, prim, args, annots @ unparse_field_annot a @ unparse_var_annot var )
| expr -> expr
let rec unparse_ty
@ -540,15 +540,15 @@ let rec unparse_ty
| Contract_t (ut, tname) ->
let t = unparse_ty ut in
Prim (-1, T_contract, [ t ], unparse_type_annot tname)
| Pair_t ((utl, l_field), (utr, r_field ), tname) ->
| Pair_t ((utl, l_field, l_var), (utr, r_field, r_var), tname) ->
let annot = unparse_type_annot tname in
let tl = unparse_ty utl |> add_field_annot l_field in
let tr = unparse_ty utr |> add_field_annot r_field in
let tl = unparse_ty utl |> add_field_annot l_field l_var in
let tr = unparse_ty utr |> add_field_annot r_field r_var in
Prim (-1, T_pair, [ tl; tr ], annot)
| Union_t ((utl, l_field), (utr, r_field), tname) ->
let annot = unparse_type_annot tname in
let tl = unparse_ty utl |> add_field_annot l_field in
let tr = unparse_ty utr |> add_field_annot r_field in
let tl = unparse_ty utl |> add_field_annot l_field None in
let tr = unparse_ty utr |> add_field_annot r_field None in
Prim (-1, T_or, [ tl; tr ], annot)
| Lambda_t (uta, utr, tname) ->
let ta = unparse_ty uta in
@ -556,7 +556,7 @@ let rec unparse_ty
Prim (-1, T_lambda, [ ta; tr ], unparse_type_annot tname)
| Option_t ((ut, some_field), _none_field, tname) ->
let annot = unparse_type_annot tname in
let t = unparse_ty ut |> add_field_annot some_field in
let t = unparse_ty ut |> add_field_annot some_field None in
Prim (-1, T_option, [ t ], annot)
| List_t (ut, tname) ->
let t = unparse_ty ut in
@ -647,8 +647,8 @@ let rec ty_eq
(comparable_ty_eq ea eb >>? fun Eq ->
(Ok Eq : (ta ty, tb ty) eq tzresult)) |>
record_trace (Inconsistent_types (ta, tb))
| Pair_t ((tal, _), (tar, _), _),
Pair_t ((tbl, _), (tbr, _), _) ->
| Pair_t ((tal, _, _), (tar, _, _), _),
Pair_t ((tbl, _, _), (tbr, _, _), _) ->
(ty_eq tal tbl >>? fun Eq ->
ty_eq tar tbr >>? fun Eq ->
(Ok Eq : (ta ty, tb ty) eq tzresult)) |>
@ -782,14 +782,16 @@ let merge_types :
merge_type_annot tn1 tn2 >>? fun tname ->
merge_comparable_types ea eb >|? fun e ->
Set_t (e, tname)
| Pair_t ((tal, l_field1), (tar, r_field1), tn1),
Pair_t ((tbl, l_field2), (tbr, r_field2), tn2) ->
| Pair_t ((tal, l_field1, l_var1), (tar, r_field1, r_var1), tn1),
Pair_t ((tbl, l_field2, l_var2), (tbr, r_field2, r_var2), tn2) ->
merge_type_annot tn1 tn2 >>? fun tname ->
merge_field_annot l_field1 l_field2 >>? fun l_field ->
merge_field_annot r_field1 r_field2 >>? fun r_field ->
let l_var = merge_var_annot l_var1 l_var2 in
let r_var = merge_var_annot r_var1 r_var2 in
help tal tbl >>? fun left_ty ->
help tar tbr >|? fun right_ty ->
Pair_t ((left_ty, l_field), (right_ty, r_field), tname)
Pair_t ((left_ty, l_field, l_var), (right_ty, r_field, r_var), tname)
| Union_t ((tal, tal_annot), (tar, tar_annot), tn1),
Union_t ((tbl, tbl_annot), (tbr, tbr_annot), tn2) ->
merge_type_annot tn1 tn2 >>? fun tname ->
@ -938,8 +940,8 @@ and parse_ty :
parse_composed_type_annot loc storage_annot
>|? fun (ty_name, map_field, storage_field) ->
let big_map_ty = Big_map_t (key_ty, value_ty, map_name) in
Ex_ty (Pair_t ((big_map_ty, map_field),
(remaining_storage, storage_field),
Ex_ty (Pair_t ((big_map_ty, map_field, None),
(remaining_storage, storage_field, None),
ty_name))
| args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args)
end
@ -992,7 +994,7 @@ and parse_ty :
parse_ty ~allow_big_map:false ~allow_operation utl >>? fun (Ex_ty tl) ->
parse_ty ~allow_big_map:false ~allow_operation utr >>? fun (Ex_ty tr) ->
parse_type_annot loc annot >|? fun ty_name ->
Ex_ty (Pair_t ((tl, left_field), (tr, right_field), ty_name))
Ex_ty (Pair_t ((tl, left_field, None), (tr, right_field, None), ty_name))
| Prim (loc, T_or, [ utl; utr ], annot) ->
extract_field_annot utl >>? fun (utl, left_constr) ->
extract_field_annot utr >>? fun (utr, right_constr) ->
@ -1008,8 +1010,8 @@ and parse_ty :
| Prim (loc, T_option, [ ut ], annot) ->
extract_field_annot ut >>? fun (ut, some_constr) ->
parse_ty ~allow_big_map:false ~allow_operation ut >>? fun (Ex_ty t) ->
parse_type_annot loc annot >|? fun ty_name ->
Ex_ty (Option_t ((t, some_constr), None, ty_name))
parse_composed_type_annot loc annot >|? fun (ty_name, none_constr, _) ->
Ex_ty (Option_t ((t, some_constr), none_constr, ty_name))
| Prim (loc, T_list, [ ut ], annot) ->
parse_ty ~allow_big_map:false ~allow_operation ut >>? fun (Ex_ty t) ->
parse_type_annot loc annot >|? fun ty_name ->
@ -1128,7 +1130,7 @@ let rec parse_data
match ty, script_data with
(* Unit *)
| Unit_t ty_name, Prim (loc, D_Unit, [], annot) ->
check_const_type_annot loc annot ty_name >>=? fun () ->
check_const_type_annot loc annot ty_name [] >>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.unit) >>|? fun ctxt ->
((() : a), ctxt)
| Unit_t _, Prim (loc, D_Unit, l, _) ->
@ -1137,11 +1139,11 @@ let rec parse_data
traced (fail (unexpected expr [] Constant_namespace [ D_Unit ]))
(* Booleans *)
| Bool_t ty_name, Prim (loc, D_True, [], annot) ->
check_const_type_annot loc annot ty_name >>=? fun () ->
check_const_type_annot loc annot ty_name [] >>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.bool) >>|? fun ctxt ->
(true, ctxt)
| Bool_t ty_name, Prim (loc, D_False, [], annot) ->
check_const_type_annot loc annot ty_name >>=? fun () ->
check_const_type_annot loc annot ty_name [] >>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.bool) >>|? fun ctxt ->
(false, ctxt)
| Bool_t _, Prim (loc, (D_True | D_False as c), l, _) ->
@ -1299,8 +1301,8 @@ let rec parse_data
| Contract_t _, expr ->
traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr)))
(* Pairs *)
| Pair_t ((ta, _), (tb, _), ty_name), Prim (loc, D_Pair, [ va; vb ], annot) ->
check_const_type_annot loc annot ty_name >>=? fun () ->
| Pair_t ((ta, af, _), (tb, bf, _), ty_name), Prim (loc, D_Pair, [ va; vb ], annot) ->
check_const_type_annot loc annot ty_name [af; bf] >>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.pair) >>=? fun ctxt ->
traced @@
parse_data ?type_logger ctxt ta va >>=? fun (va, ctxt) ->
@ -1311,16 +1313,16 @@ let rec parse_data
| Pair_t _, expr ->
traced (fail (unexpected expr [] Constant_namespace [ D_Pair ]))
(* Unions *)
| Union_t ((tl, _), _, ty_name), Prim (loc, D_Left, [ v ], annot) ->
check_const_type_annot loc annot ty_name >>=? fun () ->
| Union_t ((tl, lconstr), _, ty_name), Prim (loc, D_Left, [ v ], annot) ->
check_const_type_annot loc annot ty_name [lconstr]>>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.union) >>=? fun ctxt ->
traced @@
parse_data ?type_logger ctxt tl v >>=? fun (v, ctxt) ->
return (L v, ctxt)
| Union_t _, Prim (loc, D_Left, l, _) ->
fail @@ Invalid_arity (loc, D_Left, 1, List.length l)
| Union_t (_, (tr, _), ty_name), Prim (loc, D_Right, [ v ], annot) ->
check_const_type_annot loc annot ty_name >>=? fun () ->
| Union_t (_, (tr, rconstr), ty_name), Prim (loc, D_Right, [ v ], annot) ->
check_const_type_annot loc annot ty_name [rconstr] >>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.union) >>=? fun ctxt ->
traced @@
parse_data ?type_logger ctxt tr v >>=? fun (v, ctxt) ->
@ -1337,16 +1339,16 @@ let rec parse_data
| Lambda_t _, expr ->
traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr)))
(* Options *)
| Option_t ((t, _), _, ty_name), Prim (loc, D_Some, [ v ], annot) ->
check_const_type_annot loc annot ty_name >>=? fun () ->
| Option_t ((t, some_constr), _, ty_name), Prim (loc, D_Some, [ v ], annot) ->
check_const_type_annot loc annot ty_name [some_constr] >>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.some) >>=? fun ctxt ->
traced @@
parse_data ?type_logger ctxt t v >>=? fun (v, ctxt) ->
return (Some v, ctxt)
| Option_t _, Prim (loc, D_Some, l, _) ->
fail @@ Invalid_arity (loc, D_Some, 1, List.length l)
| Option_t (_, _, ty_name), Prim (loc, D_None, [], annot) ->
check_const_type_annot loc annot ty_name >>=? fun () ->
| Option_t (_, none_constr, ty_name), Prim (loc, D_None, [], annot) ->
check_const_type_annot loc annot ty_name [none_constr] >>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.none) >>=? fun ctxt ->
return (None, ctxt)
| Option_t _, Prim (loc, D_None, l, _) ->
@ -1513,20 +1515,22 @@ and parse_instr
return ctxt judgement
(* pairs *)
| Prim (loc, I_PAIR, [], annot),
Item_t (a, Item_t (b, rest, _snd_annot), _fst_annot) ->
Item_t (a, Item_t (b, rest, snd_annot), fst_annot) ->
parse_constr_annot loc annot >>=? fun (annot, ty_name, l_field, r_field) ->
typed ctxt loc Cons_pair
(Item_t (Pair_t((a, l_field), (b, r_field), ty_name), rest, annot))
(Item_t (Pair_t((a, l_field, fst_annot), (b, r_field, snd_annot), ty_name), rest, annot))
| Prim (loc, I_CAR, [], annot),
Item_t (Pair_t ((a, expected_field_annot), _, _), rest, pair_annot) ->
Item_t (Pair_t ((a, expected_field_annot, a_annot), _, _), rest, pair_annot) ->
parse_var_field_annot loc annot >>=? fun (annot, field_annot) ->
let annot = default_annot annot ~default:a_annot in
let annot = default_annot annot
~default:(gen_access_annot pair_annot expected_field_annot ~default:default_car_annot) in
Lwt.return @@ check_correct_field field_annot expected_field_annot >>=? fun () ->
typed ctxt loc Car (Item_t (a, rest, annot))
| Prim (loc, I_CDR, [], annot),
Item_t (Pair_t (_, (b, expected_field_annot), _), rest, pair_annot) ->
Item_t (Pair_t (_, (b, expected_field_annot, b_annot), _), rest, pair_annot) ->
parse_var_field_annot loc annot >>=? fun (annot, field_annot) ->
let annot = default_annot annot ~default:b_annot in
let annot = default_annot annot
~default:(gen_access_annot pair_annot expected_field_annot ~default:default_cdr_annot) in
Lwt.return @@ check_correct_field field_annot expected_field_annot >>=? fun () ->
@ -1670,14 +1674,15 @@ and parse_instr
parse_var_type_annot loc annot >>=? fun (annot, ty_name) ->
typed ctxt loc (Empty_map (tk, tv)) (Item_t (Map_t (tk, tv, ty_name), stack, annot))
| Prim (loc, I_MAP, [ body ], annot),
Item_t (Map_t (ck, elt, _), starting_rest, map_annot) ->
Item_t (Map_t (ck, elt, _), starting_rest, _map_annot) ->
let k = ty_of_comparable_ty ck in
check_kind [ Seq_kind ] body >>=? fun () ->
parse_var_type_annot loc annot >>=? fun (ret_annot, ty_name) ->
let binding_annot = gen_access_annot map_annot default_binding_annot in
let k_name = field_to_var_annot default_key_annot in
let e_name = field_to_var_annot default_elt_annot in
parse_instr ?type_logger tc_context ctxt
body (Item_t (Pair_t ((k, default_key_annot), (elt, default_elt_annot), None),
starting_rest, binding_annot)) >>=? begin fun (judgement, ctxt) ->
body (Item_t (Pair_t ((k, None, k_name), (elt, None, e_name), None),
starting_rest, None)) >>=? begin fun (judgement, ctxt) ->
match judgement with
| Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) ->
let invalid_map_body = Invalid_map_body (loc, ibody.aft) in
@ -1690,14 +1695,15 @@ and parse_instr
| Failed _ -> fail (Invalid_map_block_fail loc)
end
| Prim (loc, I_ITER, [ body ], annot),
Item_t (Map_t (comp_elt, element_ty, _), rest, map_annot) ->
Item_t (Map_t (comp_elt, element_ty, _), rest, _map_annot) ->
check_kind [ Seq_kind ] body >>=? fun () ->
fail_unexpected_annot loc annot >>=? fun () ->
let binding_annot = gen_access_annot map_annot default_binding_annot in
let k_name = field_to_var_annot default_key_annot in
let e_name = field_to_var_annot default_elt_annot in
let key = ty_of_comparable_ty comp_elt in
parse_instr ?type_logger tc_context ctxt body
(Item_t (Pair_t ((key, default_key_annot), (element_ty, default_elt_annot), None),
rest, binding_annot))
(Item_t (Pair_t ((key, None, k_name), (element_ty, None, e_name), None),
rest, None))
>>=? begin fun (judgement, ctxt) -> match judgement with
| Typed ({ aft ; _ } as ibody) ->
let invalid_iter_body = Invalid_iter_body (loc, rest, ibody.aft) in
@ -2045,14 +2051,16 @@ and parse_instr
parse_var_annot loc annot >>=? fun annot ->
typed ctxt loc Ediv_teznat
(Item_t (Option_t
((Pair_t ((Mutez_t tname, None), (Mutez_t tname, None), None), None),
((Pair_t ((Mutez_t tname, None, None),
(Mutez_t tname, None, None), None), None),
None, None), rest, annot))
| Prim (loc, I_EDIV, [], annot),
Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ->
parse_var_annot loc annot >>=? fun annot ->
Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname ->
typed ctxt loc Ediv_tez
(Item_t (Option_t ((Pair_t ((Nat_t None, None), (Mutez_t tname, None), None), None),
(Item_t (Option_t ((Pair_t ((Nat_t None, None, None),
(Mutez_t tname, None, None), None), None),
None, None), rest, annot))
| Prim (loc, I_EDIV, [], annot),
Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ->
@ -2060,27 +2068,31 @@ and parse_instr
Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname ->
typed ctxt loc Ediv_intint
(Item_t (Option_t
((Pair_t ((Int_t tname, None), (Nat_t None, None), None), None),
((Pair_t ((Int_t tname, None, None),
(Nat_t None, None, None), None), None),
None, None), rest, annot))
| Prim (loc, I_EDIV, [], annot),
Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ->
parse_var_annot loc annot >>=? fun annot ->
typed ctxt loc Ediv_intnat
(Item_t (Option_t
((Pair_t ((Int_t tname, None), (Nat_t None, None), None), None),
((Pair_t ((Int_t tname, None, None),
(Nat_t None, None, None), None), None),
None, None), rest, annot))
| Prim (loc, I_EDIV, [], annot),
Item_t (Nat_t tname, Item_t (Int_t _, rest, _), _) ->
parse_var_annot loc annot >>=? fun annot ->
typed ctxt loc Ediv_natint
(Item_t (Option_t ((Pair_t ((Int_t None, None), (Nat_t tname, None), None), None),
(Item_t (Option_t ((Pair_t ((Int_t None, None, None),
(Nat_t tname, None, None), None), None),
None, None), rest, annot))
| Prim (loc, I_EDIV, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ->
parse_var_annot loc annot >>=? fun annot ->
Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname ->
typed ctxt loc Ediv_natnat
(Item_t (Option_t ((Pair_t ((Nat_t tname, None), (Nat_t tname, None), None), None),
(Item_t (Option_t ((Pair_t ((Nat_t tname, None, None),
(Nat_t tname, None, None), None), None),
None, None), rest, annot))
| Prim (loc, I_LSL, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ->
@ -2290,13 +2302,15 @@ and parse_instr
(Ill_formed_type (Some "storage", cannonical_code, location storage_type))
(Lwt.return @@ parse_ty ~allow_big_map:true ~allow_operation:false storage_type)
>>=? fun (Ex_ty storage_type) ->
let arg_field = default_annot (type_to_field_annot (name_of_ty arg_type))
let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type))
~default:default_param_annot in
let storage_field = default_annot (type_to_field_annot (name_of_ty storage_type))
let storage_annot = default_annot (type_to_var_annot (name_of_ty storage_type))
~default:default_storage_annot in
let arg_type_full = Pair_t ((arg_type, arg_field), (storage_type, storage_field), None) in
let arg_type_full = Pair_t ((arg_type, None, arg_annot),
(storage_type, None, storage_annot), None) in
let ret_type_full =
Pair_t ((List_t (Operation_t None, None), None), (storage_type, None), None) in
Pair_t ((List_t (Operation_t None, None), None, None),
(storage_type, None, None), None) in
trace
(Ill_typed_contract (cannonical_code, []))
(parse_returning (Toplevel { storage_type ; param_type = arg_type })
@ -2534,13 +2548,15 @@ let parse_script
(Ill_formed_type (Some "storage", code, location storage_type))
(Lwt.return (parse_ty ~allow_big_map:true ~allow_operation:false storage_type))
>>=? fun (Ex_ty storage_type) ->
let arg_field = default_annot (type_to_field_annot (name_of_ty arg_type))
let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type))
~default:default_param_annot in
let storage_field = default_annot (type_to_field_annot (name_of_ty storage_type))
let storage_annot = default_annot (type_to_var_annot (name_of_ty storage_type))
~default:default_storage_annot in
let arg_type_full = Pair_t ((arg_type, arg_field), (storage_type, storage_field), None) in
let arg_type_full = Pair_t ((arg_type, None, arg_annot),
(storage_type, None, storage_annot), None) in
let ret_type_full =
Pair_t ((List_t (Operation_t None, None), None), (storage_type, None), None) in
Pair_t ((List_t (Operation_t None, None), None, None),
(storage_type, None, None), None) in
trace
(Ill_typed_data (None, storage, storage_type))
(parse_data ?type_logger ctxt storage_type (root storage)) >>=? fun (storage, ctxt) ->
@ -2564,13 +2580,15 @@ let typecheck_code
(Ill_formed_type (Some "storage", code, location storage_type))
(Lwt.return (parse_ty ~allow_big_map:true ~allow_operation:false storage_type))
>>=? fun (Ex_ty storage_type) ->
let arg_field = default_annot (type_to_field_annot (name_of_ty arg_type))
let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type))
~default:default_param_annot in
let storage_field = default_annot (type_to_field_annot (name_of_ty storage_type))
let storage_annot = default_annot (type_to_var_annot (name_of_ty storage_type))
~default:default_storage_annot in
let arg_type_full = Pair_t ((arg_type, arg_field), (storage_type, storage_field), None) in
let arg_type_full = Pair_t ((arg_type, None, arg_annot),
(storage_type, None, storage_annot), None) in
let ret_type_full =
Pair_t ((List_t (Operation_t None, None), None), (storage_type, None), None) in
Pair_t ((List_t (Operation_t None, None), None, None),
(storage_type, None, None), None) in
let result =
parse_returning
(Toplevel { storage_type ; param_type = arg_type })
@ -2691,7 +2709,7 @@ let rec unparse_data
let `Hex text = MBytes.to_hex bytes in
Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt ->
return (String (-1, text), ctxt)
| Pair_t ((tl, _), (tr, _), _), (l, r) ->
| Pair_t ((tl, _, _), (tr, _, _), _), (l, r) ->
Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt ->
unparse_data ctxt mode tl l >>=? fun (l, ctxt) ->
unparse_data ctxt mode tr r >>=? fun (r, ctxt) ->
@ -2837,7 +2855,7 @@ let diff_of_big_map ctxt mode (Ex_bm { key_type ; value_type ; diff }) =
(* Get the big map from a contract's storage if one exists *)
let extract_big_map : type a. a ty -> a -> ex_big_map option = fun ty x ->
match (ty, x) with
| Pair_t ((Big_map_t (_, _, _), _), _, _), (map, _) -> Some (Ex_bm map)
| Pair_t ((Big_map_t (_, _, _), _, _), _, _), (map, _) -> Some (Ex_bm map)
| _, _ -> None
let erase_big_map_initialization ctxt mode ({ code ; storage } : Script.t) =

5
src/proto_alpha/lib_protocol/src/script_typed_ir.ml
View File

@ -78,7 +78,10 @@ and 'ty ty =
| Timestamp_t : type_annot option -> Script_timestamp.t ty
| Address_t : type_annot option -> Contract.t ty
| Bool_t : type_annot option -> bool ty
| Pair_t : ('a ty * field_annot option) * ('b ty * field_annot option) * type_annot option -> ('a, 'b) pair ty
| Pair_t :
('a ty * field_annot option * var_annot option) *
('b ty * field_annot option * var_annot option) *
type_annot option -> ('a, 'b) pair ty
| Union_t : ('a ty * field_annot option) * ('b ty * field_annot option) * type_annot option -> ('a, 'b) union ty
| Lambda_t : 'arg ty * 'ret ty * type_annot option -> ('arg, 'ret) lambda ty
| Option_t : ('v ty * field_annot option) * field_annot option * type_annot option -> 'v option ty