diff --git a/src/client/embedded/alpha/client_proto_programs.ml b/src/client/embedded/alpha/client_proto_programs.ml index a9fc2ed4f..7b18b146a 100644 --- a/src/client/embedded/alpha/client_proto_programs.ml +++ b/src/client/embedded/alpha/client_proto_programs.ml @@ -9,6 +9,7 @@ module Ed25519 = Environment.Ed25519 open Client_proto_args + open Michelson_v1_printer module Program = Client_aliases.Alias (struct diff --git a/src/proto/alpha/michelson_v1_primitives.ml b/src/proto/alpha/michelson_v1_primitives.ml index 67b999fcc..2c005460e 100644 --- a/src/proto/alpha/michelson_v1_primitives.ml +++ b/src/proto/alpha/michelson_v1_primitives.ml @@ -94,6 +94,8 @@ type prim = | I_UNIT | I_UPDATE | I_XOR + | I_ITER + | I_LOOP_LEFT | T_bool | T_contract | T_int @@ -214,6 +216,8 @@ let string_of_prim = function | I_UNIT -> "UNIT" | I_UPDATE -> "UPDATE" | I_XOR -> "XOR" + | I_ITER -> "ITER" + | I_LOOP_LEFT -> "LOOP_LEFT" | T_bool -> "bool" | T_contract -> "contract" | T_int -> "int" @@ -315,6 +319,8 @@ let prim_of_string = function | "UNIT" -> ok I_UNIT | "UPDATE" -> ok I_UPDATE | "XOR" -> ok I_XOR + | "ITER" -> ok I_ITER + | "LOOP_LEFT" -> ok I_LOOP_LEFT | "bool" -> ok T_bool | "contract" -> ok T_contract | "int" -> ok T_int @@ -457,24 +463,26 @@ let prim_encoding = | I_UNIT -> 78 | I_UPDATE -> 79 | I_XOR -> 80 - | T_bool -> 81 - | T_contract -> 82 - | T_int -> 83 - | T_key -> 84 - | T_key_hash -> 85 - | T_lambda -> 86 - | T_list -> 87 - | T_map -> 88 - | T_nat -> 89 - | T_option -> 90 - | T_or -> 91 - | T_pair -> 92 - | T_set -> 93 - | T_signature -> 94 - | T_string -> 95 - | T_tez -> 96 - | T_timestamp -> 97 - | T_unit -> 99 in + | I_ITER -> 81 + | I_LOOP_LEFT -> 82 + | T_bool -> 83 + | T_contract -> 84 + | T_int -> 85 + | T_key -> 86 + | T_key_hash -> 87 + | T_lambda -> 88 + | T_list -> 89 + | T_map -> 90 + | T_nat -> 91 + | T_option -> 92 + | T_or -> 93 + | T_pair -> 94 + | T_set -> 95 + | T_signature -> 96 + | T_string -> 97 + | T_tez -> 98 + | T_timestamp -> 99 + | T_unit -> 100 in let of_int_map = [| K_parameter ; K_return ; @@ -557,6 +565,8 @@ let prim_encoding = I_UNIT ; I_UPDATE ; I_XOR ; + I_ITER ; + I_LOOP_LEFT ; T_bool ; T_contract ; T_int ; @@ -576,7 +586,7 @@ let prim_encoding = T_timestamp ; T_unit |] in let of_int i = - if Compare.Int.(i >= 0 || i <= 99) then + if Compare.Int.(i >= 0 || i <= 100) then of_int_map.(i) else raise Data_encoding.No_case_matched in diff --git a/src/proto/alpha/michelson_v1_primitives.mli b/src/proto/alpha/michelson_v1_primitives.mli index dbdd50a59..299d76a43 100644 --- a/src/proto/alpha/michelson_v1_primitives.mli +++ b/src/proto/alpha/michelson_v1_primitives.mli @@ -92,6 +92,8 @@ type prim = | I_UNIT | I_UPDATE | I_XOR + | I_ITER + | I_LOOP_LEFT | T_bool | T_contract | T_int diff --git a/src/proto/alpha/script_interpreter.ml b/src/proto/alpha/script_interpreter.ml index de8a3e6db..51f22ff85 100644 --- a/src/proto/alpha/script_interpreter.ml +++ b/src/proto/alpha/script_interpreter.ml @@ -142,6 +142,17 @@ let rec interp return (ret :: tail, qta, ctxt, origination)) l ([], qta, ctxt, origination) >>=? fun (res, qta, ctxt, origination) -> logged_return ~origination (Item (res, rest), qta, ctxt) + | List_map_body body, Item (l, rest) -> + let rec help rest qta = function + | [] -> logged_return ~origination (Item ([], rest), qta, ctxt) + | hd :: tl -> + step origination qta ctxt body (Item (hd, rest)) + >>=? fun (Item (hd, rest), qta, _, _) -> + help rest qta tl + >>=? fun (Item (tl, rest), qta, ctxt, origination) -> + logged_return ~origination (Item (hd :: tl, rest), qta, ctxt) + in help rest qta l >>=? fun (res, qta, ctxt, origination) -> + logged_return ~origination (res, qta - 1, ctxt) | List_reduce, Item (lam, Item (l, Item (init, rest))) -> fold_left_s (fun (partial, qta, ctxt, origination) arg -> @@ -154,6 +165,14 @@ let rec interp let len = List.length list in let len = Script_int.(abs (of_int len)) in logged_return (Item (len, rest), qta - 1, ctxt) + | List_iter body, Item (l, init_stack) -> + fold_left_s + (fun (stack, qta, ctxt, origination) arg -> + step origination qta ctxt body (Item (arg, stack)) + >>=? fun (stack, qta, ctxt, origination) -> + return (stack, qta, ctxt, origination)) + (init_stack, qta, ctxt, origination) l >>=? fun (stack, qta, ctxt, origination) -> + logged_return ~origination (stack, qta, ctxt) (* sets *) | Empty_set t, rest -> logged_return (Item (empty_set t, rest), qta - 1, ctxt) @@ -177,6 +196,15 @@ let rec interp return (partial, qta, ctxt, origination)) (init, qta, ctxt, origination) items >>=? fun (res, qta, ctxt, origination) -> logged_return ~origination (Item (res, rest), qta, ctxt) + | Set_iter body, Item (set, init_stack) -> + fold_left_s + (fun (stack, qta, ctxt, origination) arg -> + step origination qta ctxt body (Item (arg, stack)) + >>=? fun (stack, qta, ctxt, origination) -> + return (stack, qta, ctxt, origination)) + (init_stack, qta, ctxt, origination) + (set_fold (fun e acc -> e :: acc) set []) >>=? fun (stack, qta, ctxt, origination) -> + logged_return ~origination (stack, qta, ctxt) | Set_mem, Item (v, Item (set, rest)) -> logged_return (Item (set_mem v set, rest), qta - 1, ctxt) | Set_update, Item (v, Item (presence, Item (set, rest))) -> @@ -206,6 +234,16 @@ let rec interp return (partial, qta, ctxt, origination)) (init, qta, ctxt, origination) items >>=? fun (res, qta, ctxt, origination) -> logged_return ~origination (Item (res, rest), qta, ctxt) + | Map_iter body, Item (map, init_stack) -> + let items = + List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + fold_left_s + (fun (stack, qta, ctxt, origination) arg -> + step origination qta ctxt body (Item (arg, stack)) + >>=? fun (stack, qta, ctxt, origination) -> + return (stack, qta, ctxt, origination)) + (init_stack, qta, ctxt, origination) items >>=? fun (stack, qta, ctxt, origination) -> + logged_return ~origination (stack, qta, ctxt) | Map_mem, Item (v, Item (map, rest)) -> logged_return (Item (map_mem v map, rest), qta - 1, ctxt) | Map_get, Item (v, Item (map, rest)) -> @@ -364,6 +402,11 @@ let rec interp step origination (qta - 1) ctxt descr trans | Loop _, Item (false, rest) -> logged_return (rest, qta, ctxt) + | Loop_left body, Item (L v, rest) -> + step origination qta ctxt body (Item (v, rest)) >>=? fun (trans, qta, ctxt, origination) -> + step origination (qta - 1) ctxt descr trans + | Loop_left _, Item (R v, rest) -> + logged_return (Item (v, rest), qta, ctxt) | Dip b, Item (ign, rest) -> step origination qta ctxt b rest >>=? fun (res, qta, ctxt, origination) -> logged_return ~origination (Item (ign, res), qta, ctxt) diff --git a/src/proto/alpha/script_ir_translator.ml b/src/proto/alpha/script_ir_translator.ml index 4737e52f2..3f884e7ba 100644 --- a/src/proto/alpha/script_ir_translator.ml +++ b/src/proto/alpha/script_ir_translator.ml @@ -41,6 +41,9 @@ type error += Bad_stack_item of int type error += Inconsistent_annotations of string * string type error += Inconsistent_type_annotations : Script.location * _ ty * _ ty -> error type error += Unexpected_annotation of Script.location +type error += Invalid_map_body : Script.location * _ stack_ty -> error +type error += Invalid_map_block_fail of Script.location +type error += Invalid_iter_body : Script.location * _ stack_ty * _ stack_ty -> error (* Value typing errors *) type error += Invalid_constant : Script.location * Script.expr * _ ty -> error @@ -173,7 +176,9 @@ let namespace = function | I_TRANSFER_TOKENS | I_UNIT | I_UPDATE - | I_XOR -> Instr_namespace + | I_XOR + | I_ITER + | I_LOOP_LEFT -> Instr_namespace | T_bool | T_contract | T_int @@ -1134,10 +1139,25 @@ and parse_instr let branch ibt ibf = { loc ; instr = If_cons (ibt, ibf) ; bef ; aft = ibt.aft } in merge_branches loc btr bfr { branch } + | Prim (loc, I_SIZE, [], instr_annot), + Item_t (List_t _, rest, _) -> + return (typed loc (List_size, Item_t (Nat_t, rest, instr_annot))) | Prim (loc, I_MAP, [], instr_annot), Item_t (Lambda_t (param, ret), Item_t (List_t elt, rest, _), _) -> check_item_ty elt param loc I_MAP 2 2 >>=? fun (Eq _) -> return (typed loc (List_map, Item_t (List_t ret, rest, instr_annot))) + | Prim (loc, I_MAP, [ body ], instr_annot), + (Item_t (List_t elt, starting_rest, _)) -> + check_kind [ Seq_kind ] body >>=? fun () -> + parse_instr ?type_logger tc_context ctxt body (Item_t (elt, starting_rest, None)) >>=? begin function + | Typed ({ aft = Item_t (ret, rest, _) } as ibody) -> + trace + (Invalid_map_body (loc, ibody.aft)) + (Lwt.return (stack_ty_eq 1 rest starting_rest)) >>=? fun (Eq _) -> + return (typed loc (List_map_body ibody, Item_t (List_t ret, rest, instr_annot))) + | Typed { aft } -> fail (Invalid_map_body (loc, aft)) + | Failed _ -> fail (Invalid_map_block_fail loc) + end | Prim (loc, I_REDUCE, [], instr_annot), Item_t (Lambda_t (Pair_t ((pelt, _), (pr, _)), r), Item_t (List_t elt, Item_t (init, rest, _), _), _) -> @@ -1148,6 +1168,20 @@ and parse_instr | Prim (loc, I_SIZE, [], instr_annot), Item_t (List_t _, rest, _) -> return (typed loc (List_size, Item_t (Nat_t, rest, instr_annot))) + | Prim (loc, I_ITER, [ body ], instr_annot), + Item_t (List_t elt, rest, _) -> + check_kind [ Seq_kind ] body >>=? fun () -> + fail_unexpected_annot loc instr_annot >>=? fun () -> + parse_instr ?type_logger tc_context ctxt body (Item_t (elt, rest, None)) >>=? begin function + | Typed ({ aft } as ibody) -> + trace + (Invalid_iter_body (loc, rest, ibody.aft)) + (Lwt.return (stack_ty_eq 1 aft rest)) >>=? fun (Eq _) -> + return (typed loc (List_iter ibody, rest)) + | Failed { descr } -> + let ibody = descr rest in + return (typed loc (List_iter ibody, rest)) + end (* sets *) | Prim (loc, I_EMPTY_SET, [ t ], instr_annot), rest -> @@ -1167,6 +1201,21 @@ and parse_instr check_item_ty elt pelt loc I_REDUCE 2 3 >>=? fun (Eq _) -> check_item_ty init r loc I_REDUCE 3 3 >>=? fun (Eq _) -> return (typed loc (Set_reduce, Item_t (r, rest, instr_annot))) + | Prim (loc, I_ITER, [ body ], annot), + Item_t (Set_t comp_elt, rest, _) -> + check_kind [ Seq_kind ] body >>=? fun () -> + fail_unexpected_annot loc annot >>=? fun () -> + let elt = ty_of_comparable_ty comp_elt in + parse_instr ?type_logger tc_context ctxt body (Item_t (elt, rest, None)) >>=? begin function + | Typed ({ aft } as ibody) -> + trace + (Invalid_iter_body (loc, rest, ibody.aft)) + (Lwt.return (stack_ty_eq 1 aft rest)) >>=? fun (Eq _) -> + return (typed loc (Set_iter ibody, rest)) + | Failed { descr } -> + let ibody = descr rest in + return (typed loc (Set_iter ibody, rest)) + end | Prim (loc, I_MEM, [], instr_annot), Item_t (v, Item_t (Set_t elt, rest, _), _) -> let elt = ty_of_comparable_ty elt in @@ -1203,6 +1252,23 @@ and parse_instr check_item_ty r pr loc I_REDUCE 1 3 >>=? fun (Eq _) -> check_item_ty init r loc I_REDUCE 3 3 >>=? fun (Eq _) -> return (typed loc (Map_reduce, Item_t (r, rest, instr_annot))) + | Prim (loc, I_ITER, [ body ], instr_annot), + Item_t (Map_t (comp_elt, element_ty), rest, _) -> + check_kind [ Seq_kind ] body >>=? fun () -> + fail_unexpected_annot loc instr_annot >>=? fun () -> + let key = ty_of_comparable_ty comp_elt in + parse_instr ?type_logger tc_context ctxt body + (Item_t (Pair_t ((key, None), (element_ty, None)), rest, None)) + >>=? begin function + | Typed ({ aft } as ibody) -> + trace + (Invalid_iter_body (loc, rest, ibody.aft)) + (Lwt.return (stack_ty_eq 1 aft rest)) >>=? fun (Eq _) -> + return (typed loc (Map_iter ibody, rest)) + | Failed { descr } -> + let ibody = descr rest in + return (typed loc (Map_iter ibody, rest)) + end | Prim (loc, I_MEM, [], instr_annot), Item_t (vk, Item_t (Map_t (ck, _), rest, _), _) -> let k = ty_of_comparable_ty ck in @@ -1279,6 +1345,20 @@ and parse_instr let ibody = descr (Item_t (Bool_t, rest, stack_annot)) in return (typed loc (Loop ibody, rest)) end + | Prim (loc, I_LOOP_LEFT, [ body ], instr_annot), + (Item_t (Union_t ((tl, tl_annot), (tr, tr_annot)), rest, _) as stack) -> + check_kind [ Seq_kind ] body >>=? fun () -> + fail_unexpected_annot loc instr_annot >>=? fun () -> + parse_instr ?type_logger tc_context ctxt body (Item_t (tl, rest, tl_annot)) >>=? begin function + | Typed ibody -> + trace + (Unmatched_branches (loc, ibody.aft, stack)) + (Lwt.return (stack_ty_eq 1 ibody.aft stack)) >>=? fun (Eq _) -> + return (typed loc (Loop_left ibody, (Item_t (tr, rest, tr_annot)))) + | Failed { descr } -> + let ibody = descr (Item_t (Union_t ((tl, tl_annot), (tr, tr_annot)), rest, None)) in + return (typed loc (Loop_left ibody, Item_t (tr, rest, tr_annot))) + end | Prim (loc, I_LAMBDA, [ arg ; ret ; code ], instr_annot), stack -> (Lwt.return (parse_ty arg)) >>=? fun (Ex_ty arg, arg_annot) -> @@ -1584,8 +1664,8 @@ and parse_instr | I_H | I_STEPS_TO_QUOTA as name), (_ :: _ as l), _), _ -> fail (Invalid_arity (loc, name, 0, List.length l)) - | Prim (loc, (I_NONE | I_LEFT | I_RIGHT | I_NIL - | I_EMPTY_SET | I_DIP | I_LOOP + | Prim (loc, (I_NONE | I_LEFT | I_RIGHT | I_NIL | I_MAP | I_ITER + | I_EMPTY_SET | I_DIP | I_LOOP | I_LOOP_LEFT as name), ([] | _ :: _ :: _ as l), _), _ -> fail (Invalid_arity (loc, name, 1, List.length l)) @@ -1628,7 +1708,7 @@ and parse_instr stack -> fail (Bad_stack (loc, name, 1, stack)) | Prim (loc, (I_SWAP | I_PAIR | I_CONS - | I_MAP | I_GET | I_MEM | I_EXEC + | I_GET | I_MEM | I_EXEC | I_CHECK_SIGNATURE | I_ADD | I_SUB | I_MUL | I_EDIV | I_AND | I_OR | I_XOR | I_LSL | I_LSR | I_CONCAT as name), _, _), @@ -1639,7 +1719,7 @@ and parse_instr fail @@ unexpected expr [ Seq_kind ] Instr_namespace [ I_DROP ; I_DUP ; I_SWAP ; I_SOME ; I_UNIT ; I_PAIR ; I_CAR ; I_CDR ; I_CONS ; - I_MEM ; I_UPDATE ; I_MAP ; I_REDUCE ; + I_MEM ; I_UPDATE ; I_MAP ; I_REDUCE ; I_ITER ; I_GET ; I_EXEC ; I_FAIL ; I_SIZE ; I_CONCAT ; I_ADD ; I_SUB ; I_MUL ; I_EDIV ; I_OR ; I_AND ; I_XOR ; @@ -2203,7 +2283,47 @@ let () = | _ -> None) (fun (Ex_ty tya, Ex_ty tyb) -> Inconsistent_types (tya, tyb)) ; - + register_error_kind + `Permanent + ~id:"invalidMapBody" + ~title: "Invalid map body" + ~description: + "The body of a map block did not match the expected type" + (obj2 + (req "loc" Script.location_encoding) + (req "bodyType" ex_stack_ty_enc)) + (function + | Invalid_map_body (loc, stack) -> + Some (loc, Ex_stack_ty stack) + | _ -> None) + (fun (loc, Ex_stack_ty stack) -> + Invalid_map_body (loc, stack)) ; + register_error_kind + `Permanent + ~id:"invalidMapBlockFail" + ~title:"FAIL instruction occurred as body of map block" + ~description:"FAIL cannot be the only instruction in the body.\ + The propper type of the return list cannot be inferred." + (obj1 (req "loc" Script.location_encoding)) + (function + | Invalid_map_block_fail loc -> Some loc + | _ -> None) + (fun loc -> Invalid_map_block_fail loc) ; + register_error_kind + `Permanent + ~id:"invalidIterBody" + ~title:"ITER body returned wrong stack type" + ~description:"The body of an ITER instruction\ + must result in the same stack type as before\ + the ITER." + (obj3 + (req "loc" Script.location_encoding) + (req "befStack" ex_stack_ty_enc) + (req "aftStack" ex_stack_ty_enc)) + (function + | Invalid_iter_body (loc, bef, aft) -> Some (loc, Ex_stack_ty bef, Ex_stack_ty aft) + | _ -> None) + (fun (loc, Ex_stack_ty bef, Ex_stack_ty aft) -> Invalid_iter_body (loc, bef, aft)) ; (* Toplevel errors *) register_error_kind `Permanent diff --git a/src/proto/alpha/script_ir_translator.mli b/src/proto/alpha/script_ir_translator.mli index 4b1e6c37f..d5ef98b6f 100644 --- a/src/proto/alpha/script_ir_translator.mli +++ b/src/proto/alpha/script_ir_translator.mli @@ -47,6 +47,9 @@ type error += Transfer_in_lambda of Script.location type error += Transfer_in_dip of Script.location type error += Bad_stack_length type error += Bad_stack_item of int +type error += Invalid_map_body : Script.location * _ Script_typed_ir.stack_ty -> error +type error += Invalid_map_block_fail of Script.location +type error += Invalid_iter_body : Script.location * _ Script_typed_ir.stack_ty * _ Script_typed_ir.stack_ty -> error (* Value typing errors *) type error += Invalid_constant : Script.location * Script.expr * _ Script_typed_ir.ty -> error diff --git a/src/proto/alpha/script_typed_ir.ml b/src/proto/alpha/script_typed_ir.ml index 35aa46cf9..dfe1e7f59 100644 --- a/src/proto/alpha/script_typed_ir.ml +++ b/src/proto/alpha/script_typed_ir.ml @@ -134,10 +134,15 @@ and ('bef, 'aft) instr = ('a list * 'bef, 'aft) instr | List_map : (('param, 'ret) lambda * ('param list * 'rest), 'ret list * 'rest) instr + | List_map_body : ('a * 'rest, 'b * 'rest) descr -> + ('a list * 'rest, 'b list * 'rest) instr | List_reduce : (('param * 'res, 'res) lambda * ('param list * ('res * 'rest)), 'res * 'rest) instr | List_size : ('a list * 'rest, n num * 'rest) instr + | List_iter : + ('a * 'rest, 'rest) descr -> + ('a list * 'rest, 'rest) instr (* sets *) | Empty_set : 'a comparable_ty -> ('rest, 'a set * 'rest) instr @@ -146,6 +151,9 @@ and ('bef, 'aft) instr = | Set_reduce : (('param * 'res, 'res) lambda * ('param set * ('res * 'rest)), 'res * 'rest) instr + | Set_iter : + ('a * 'rest, 'rest) descr -> + ('a set * 'rest, 'rest) instr | Set_mem : ('elt * ('elt set * 'rest), bool * 'rest) instr | Set_update : @@ -159,6 +167,9 @@ and ('bef, 'aft) instr = | Map_reduce : ((('a * 'v) * 'res, 'res) lambda * (('a, 'v) map * ('res * 'rest)), 'res * 'rest) instr + | Map_iter : + (('a * 'v) * 'rest, 'rest) descr -> + (('a, 'v) map * 'rest, 'rest) instr | Map_mem : ('a * (('a, 'v) map * 'rest), bool * 'rest) instr | Map_get : @@ -263,6 +274,8 @@ and ('bef, 'aft) instr = (bool * 'bef, 'aft) instr | Loop : ('rest, bool * 'rest) descr -> (bool * 'rest, 'rest) instr + | Loop_left : ('a * 'rest, ('a, 'b) union * 'rest) descr -> + (('a, 'b) union * 'rest, 'b * 'rest) instr | Dip : ('bef, 'aft) descr -> ('top * 'bef, 'top * 'aft) instr | Exec : diff --git a/src/proto/alpha/tezos_context.mli b/src/proto/alpha/tezos_context.mli index 28f575da2..dca62c209 100644 --- a/src/proto/alpha/tezos_context.mli +++ b/src/proto/alpha/tezos_context.mli @@ -207,6 +207,8 @@ module Script : sig | I_UNIT | I_UPDATE | I_XOR + | I_ITER + | I_LOOP_LEFT | T_bool | T_contract | T_int diff --git a/test/contracts/fail.tz b/test/contracts/fail.tz index 4b130f764..92ac980c5 100644 --- a/test/contracts/fail.tz +++ b/test/contracts/fail.tz @@ -1,6 +1,6 @@ -parameter unit +parameter unit; code { # This contract will never accept a incoming transaction - FAIL} -return unit -storage unit + FAIL}; +return unit; +storage unit; diff --git a/test/contracts/list_iter.tz b/test/contracts/list_iter.tz new file mode 100644 index 000000000..d09b75a24 --- /dev/null +++ b/test/contracts/list_iter.tz @@ -0,0 +1,6 @@ +parameter (list int); +storage unit; +return int; +code { CAR; PUSH int 1; SWAP; + ITER { MUL }; + UNIT; SWAP; PAIR} diff --git a/test/contracts/list_iter2.tz b/test/contracts/list_iter2.tz new file mode 100644 index 000000000..39fd7706c --- /dev/null +++ b/test/contracts/list_iter2.tz @@ -0,0 +1,6 @@ +parameter (list string); +return string; +storage unit; +code { CAR; PUSH string ""; SWAP; + ITER { CONCAT }; + UNIT; SWAP; PAIR} diff --git a/test/contracts/list_map_block.tz b/test/contracts/list_map_block.tz new file mode 100644 index 000000000..a404af562 --- /dev/null +++ b/test/contracts/list_map_block.tz @@ -0,0 +1,6 @@ +parameter (list int); +return (list int); +storage unit; +code { CAR; PUSH int 0; SWAP; + MAP { DIP{DUP}; ADD; DIP{PUSH int 1; ADD}}; + UNIT; SWAP; PAIR; DIP{DROP}} diff --git a/test/contracts/loop_left.tz b/test/contracts/loop_left.tz new file mode 100644 index 000000000..80bad5de5 --- /dev/null +++ b/test/contracts/loop_left.tz @@ -0,0 +1,8 @@ +parameter (list string); +return (list string); +storage unit; +code { CAR; NIL string; SWAP; PAIR; LEFT (list string); + LOOP_LEFT { DUP; CAR; DIP{CDR}; + IF_CONS { SWAP; DIP{CONS}; PAIR; LEFT (list string) } + { RIGHT (pair (list string) (list string)) }; }; + UNIT; SWAP; PAIR } diff --git a/test/contracts/map_iter.tz b/test/contracts/map_iter.tz new file mode 100644 index 000000000..2e1716330 --- /dev/null +++ b/test/contracts/map_iter.tz @@ -0,0 +1,7 @@ +parameter (map int int); +return (pair int int); +storage unit; +code { CAR; PUSH int 0; DUP; PAIR; SWAP; + ITER { DIP {DUP; CAR; DIP{CDR}}; DUP; # Last instr + DIP{CAR; ADD}; SWAP; DIP{CDR; ADD}; PAIR }; + UNIT; SWAP; PAIR} diff --git a/test/contracts/set_iter.tz b/test/contracts/set_iter.tz new file mode 100644 index 000000000..27985ca20 --- /dev/null +++ b/test/contracts/set_iter.tz @@ -0,0 +1,4 @@ +parameter (set int); +return int; +storage unit; +code { CAR; PUSH int 0; SWAP; ITER { ADD }; UNIT; SWAP; PAIR } diff --git a/test/contracts/weather_insurance.tz b/test/contracts/weather_insurance.tz index f34b07ff6..d437f87fa 100644 --- a/test/contracts/weather_insurance.tz +++ b/test/contracts/weather_insurance.tz @@ -13,6 +13,6 @@ code { DUP; DUP; DIIP{CDAR}; # Place contracts below numbers DIP{CADR}; # Get actual rain CDDAR; # Get rain threshold - CMPLT; IF {CAR @lt; ANNOT @winner} {CDR @geq; ANNOT @winner}; # Select contract to receive tokens + CMPLT; IF {CAR @winner} {CDR @winner}; # Select contract to receive tokens BALANCE; UNIT; TRANSFER_TOKENS; # Setup and execute transfer PAIR }; # Save storage diff --git a/test/test_contracts.sh b/test/test_contracts.sh index caa103543..9e89bce3d 100755 --- a/test/test_contracts.sh +++ b/test/test_contracts.sh @@ -15,9 +15,16 @@ key2=bar $client gen keys $key1 $client gen keys $key2 +CONTRACT_PATH=contracts + printf "\n\n" -CONTRACT_PATH=contracts +# Assert well typed +echo "Typechecking contracts in '${CONTRACT_PATH}'" +ls $CONTRACT_PATH \ + | xargs -I{} $client typecheck program $CONTRACT_PATH/{} > /dev/null + +printf "All contracts are well typed\n\n" # FORMAT: assert_output contract_file storage input expected_result @@ -94,6 +101,19 @@ assert_output $CONTRACT_PATH/map_id.tz Unit '(Map (Item 0 1))' '(Map (Item 0 1)) assert_output $CONTRACT_PATH/map_id.tz Unit '(Map (Item 0 0))' '(Map (Item 0 0))' assert_output $CONTRACT_PATH/map_id.tz Unit '(Map (Item 0 0) (Item 3 4))' '(Map (Item 0 0) (Item 3 4))' +# Map block on lists +assert_output $CONTRACT_PATH/list_map_block.tz Unit '(List)' 'List' +assert_output $CONTRACT_PATH/list_map_block.tz Unit '(List 1 1 1 1)' '(List 1 2 3 4)' +assert_output $CONTRACT_PATH/list_map_block.tz Unit '(List 1 2 3 0)' '(List 1 3 5 3)' + +# List iter +assert_output $CONTRACT_PATH/list_iter.tz Unit '(List 10 2 1)' 20 +assert_output $CONTRACT_PATH/list_iter.tz Unit '(List 3 6 9)' 162 + +assert_output $CONTRACT_PATH/list_iter2.tz Unit '(List "a" "b" "c")' '"cba"' +assert_output $CONTRACT_PATH/list_iter2.tz Unit '(List)' '""' + + # Identity on sets assert_output $CONTRACT_PATH/set_id.tz Unit '(Set "a" "b" "c")' '(Set "a" "b" "c")' assert_output $CONTRACT_PATH/set_id.tz Unit '(Set)' 'Set' @@ -110,6 +130,11 @@ assert_output $CONTRACT_PATH/set_size.tz Unit '(Set 1)' 1 assert_output $CONTRACT_PATH/set_size.tz Unit '(Set 1 2 3)' 3 assert_output $CONTRACT_PATH/set_size.tz Unit '(Set 1 2 3 4 5 6)' 6 +# Set iter +assert_output $CONTRACT_PATH/set_iter.tz Unit '(Set)' 0 +assert_output $CONTRACT_PATH/set_iter.tz Unit '(Set 1)' 1 +assert_output $CONTRACT_PATH/set_iter.tz Unit '(Set -100 1 2 3)' '-94' + # Map size assert_output $CONTRACT_PATH/map_size.tz Unit '(Map)' 0 assert_output $CONTRACT_PATH/map_size.tz Unit '(Map (Item "a" 1))' 1 @@ -154,6 +179,10 @@ assert_output $CONTRACT_PATH/get_map_value.tz \ '(Map (Item "1" "one") (Item "2" "two"))' \ '"1"' '(Some "one")' +# Map iter +assert_output $CONTRACT_PATH/map_iter.tz Unit '(Map (Item 0 100) (Item 2 100))' '(Pair 2 200)' +assert_output $CONTRACT_PATH/map_iter.tz Unit '(Map (Item 1 1) (Item 2 100))' '(Pair 3 101)' + # Return True if True branch of if was taken and False otherwise assert_output $CONTRACT_PATH/if.tz Unit True True assert_output $CONTRACT_PATH/if.tz Unit False False @@ -168,6 +197,10 @@ assert_output $CONTRACT_PATH/reverse.tz Unit '(List "c" "b" "a")' '(List "a" "b" assert_output $CONTRACT_PATH/reverse_loop.tz Unit '(List )' 'List' assert_output $CONTRACT_PATH/reverse_loop.tz Unit '(List "c" "b" "a")' '(List "a" "b" "c")' +# Reverse using LOOP_LEFT +assert_output $CONTRACT_PATH/loop_left.tz Unit '(List )' 'List' +assert_output $CONTRACT_PATH/loop_left.tz Unit '(List "c" "b" "a")' '(List "a" "b" "c")' + # Exec concat contract assert_output $CONTRACT_PATH/exec_concat.tz Unit '""' '"_abc"' assert_output $CONTRACT_PATH/exec_concat.tz Unit '"test"' '"test_abc"'