diff --git a/src/proto/alpha/docs/language.md b/src/proto/alpha/docs/language.md index 54d14b0d7..b7267f676 100644 --- a/src/proto/alpha/docs/language.md +++ b/src/proto/alpha/docs/language.md @@ -768,6 +768,11 @@ constants as is, concatenate them and use them as keys. :: lambda (pair 'elt * 'b) 'b : set 'elt : 'b : 'S -> 'b : 'S + * `SIZE`: + Get the cardinality of the set. + + :: set 'elt : 'S -> nat : 'S + ### Operations on maps * `EMPTY_MAP 'key 'val`: @@ -806,6 +811,11 @@ constants as is, concatenate them and use them as keys. :: lambda (pair (pair 'key 'val) 'b) 'b : map 'key 'val : 'b : 'S -> 'b : 'S + * `SIZE`: + Get the cardinality of the map. + + :: map 'key 'val : 'S -> nat : 'S + ### Operations on optional values * `SOME`: @@ -832,6 +842,7 @@ constants as is, concatenate them and use them as keys. > IF_NONE ; C / (None) : S => bt ; C / S > IF_NONE ; C / (Some a) : S => bf ; C / a : S + ### Operations on unions * `LEFT 'b`: diff --git a/src/proto/alpha/script_interpreter.ml b/src/proto/alpha/script_interpreter.ml index e6278024f..655e0f8fc 100644 --- a/src/proto/alpha/script_interpreter.ml +++ b/src/proto/alpha/script_interpreter.ml @@ -190,6 +190,8 @@ let rec interp logged_return (Item (set_mem v set, rest), qta - 1, ctxt) | Set_update, Item (v, Item (presence, Item (set, rest))) -> logged_return (Item (set_update v presence set, rest), qta - 1, ctxt) + | Set_size, Item (set, rest) -> + logged_return (Item (set_size set, rest), qta - 1, ctxt) (* maps *) | Empty_map (t, _), rest -> logged_return (Item (empty_map t, rest), qta - 1, ctxt) @@ -219,6 +221,8 @@ let rec interp logged_return (Item (map_get v map, rest), qta - 1, ctxt) | Map_update, Item (k, Item (v, Item (map, rest))) -> logged_return (Item (map_update k v map, rest), qta - 1, ctxt) + | Map_size, Item (map, rest) -> + logged_return (Item (map_size map, rest), qta - 1, ctxt) (* timestamp operations *) | Add_seconds_to_timestamp, Item (n, Item (t, rest)) -> begin match Script_int.to_int64 n with diff --git a/src/proto/alpha/script_ir_translator.ml b/src/proto/alpha/script_ir_translator.ml index 517cec73e..278197b07 100644 --- a/src/proto/alpha/script_ir_translator.ml +++ b/src/proto/alpha/script_ir_translator.ml @@ -169,6 +169,11 @@ let set_fold = fun f (module Box) -> Box.OPS.fold f Box.boxed +let set_size + : type elt. elt set -> Script_int.n Script_int.num = + fun (module Box) -> + Script_int.(abs (of_int (Box.OPS.cardinal Box.boxed))) + let map_key_ty : type a b. (a, b) map -> a comparable_ty = fun (module Box) -> Box.key_ty @@ -217,6 +222,11 @@ let map_fold = fun f (module Box) -> Box.OPS.fold f Box.boxed +let map_size + : type key value. (key, value) map -> Script_int.n Script_int.num = + fun (module Box) -> + Script_int.(abs (of_int (Box.OPS.cardinal Box.boxed))) + (* ---- Unparsing (Typed IR -> Untyped epressions) --------------------------*) let ty_of_comparable_ty @@ -927,6 +937,9 @@ and parse_instr let ty = ty_of_comparable_ty elt in check_item_ty ty v loc "UPDATE" 1 3 >>=? fun (Eq _) -> return (typed loc (Set_update, Item_t (Set_t elt, rest))) + | Prim (loc, "SIZE", []), + Item_t (Set_t _, rest) -> + return (typed loc (Set_size, Item_t (Nat_t, rest))) (* maps *) | Prim (loc, "EMPTY_MAP", [ tk ; tv ]), stack -> @@ -964,6 +977,9 @@ and parse_instr check_item_ty vk k loc "UPDATE" 1 3 >>=? fun (Eq _) -> check_item_ty vv v loc "UPDATE" 2 3 >>=? fun (Eq _) -> return (typed loc (Map_update, Item_t (Map_t (ck, v), rest))) + | Prim (loc, "SIZE", []), + Item_t (Map_t (_, _), rest) -> + return (typed loc (Map_size, Item_t (Nat_t, rest))) (* control *) | Seq (loc, []), stack -> @@ -1275,7 +1291,7 @@ and parse_instr | Prim (loc, ("DROP" | "DUP" | "SWAP" | "SOME" | "UNIT" | "PAIR" | "CAR" | "CDR" | "CONS" | "MEM" | "UPDATE" | "MAP" | "REDUCE" - | "GET" | "EXEC" | "FAIL" + | "GET" | "EXEC" | "FAIL" | "SIZE" | "CONCAT" | "ADD" | "SUB" | "MUL" | "EDIV" | "OR" | "AND" | "XOR" | "NOT" @@ -1343,7 +1359,7 @@ and parse_instr [ "DROP" ; "DUP" ; "SWAP" ; "SOME" ; "UNIT" ; "PAIR" ; "CAR" ; "CDR" ; "CONS" ; "MEM" ; "UPDATE" ; "MAP" ; "REDUCE" ; - "GET" ; "EXEC" ; "FAIL" ; + "GET" ; "EXEC" ; "FAIL" ; "SIZE" ; "CONCAT" ; "ADD" ; "SUB" ; "MUL" ; "EDIV" ; "OR" ; "AND" ; "XOR" ; "NOT" ; diff --git a/src/proto/alpha/script_ir_translator.mli b/src/proto/alpha/script_ir_translator.mli index 3b5b78c57..08a05b082 100644 --- a/src/proto/alpha/script_ir_translator.mli +++ b/src/proto/alpha/script_ir_translator.mli @@ -64,6 +64,7 @@ val set_fold : 'elt Script_typed_ir.set -> 'acc -> 'acc val set_update : 'a -> bool -> 'a Script_typed_ir.set -> 'a Script_typed_ir.set val set_mem : 'elt -> 'elt Script_typed_ir.set -> bool +val set_size : 'elt Script_typed_ir.set -> Script_int.n Script_int.num val empty_map : 'a Script_typed_ir.comparable_ty -> ('a, 'b) Script_typed_ir.map val map_fold : @@ -74,6 +75,7 @@ val map_update : val map_mem : 'key -> ('key, 'value) Script_typed_ir.map -> bool val map_get : 'key -> ('key, 'value) Script_typed_ir.map -> 'value option val map_key_ty : ('a, 'b) Script_typed_ir.map -> 'a Script_typed_ir.comparable_ty +val map_size : ('a, 'b) Script_typed_ir.map -> Script_int.n Script_int.num val ty_eq : 'ta Script_typed_ir.ty -> 'tb Script_typed_ir.ty -> diff --git a/src/proto/alpha/script_typed_ir.ml b/src/proto/alpha/script_typed_ir.ml index 7c45b6add..0306bc518 100644 --- a/src/proto/alpha/script_typed_ir.ml +++ b/src/proto/alpha/script_typed_ir.ml @@ -146,6 +146,7 @@ and ('bef, 'aft) instr = ('elt * ('elt set * 'rest), bool * 'rest) instr | Set_update : ('elt * (bool * ('elt set * 'rest)), 'elt set * 'rest) instr + | Set_size : ('a set * 'rest, n num * 'rest) instr (* maps *) | Empty_map : 'a comparable_ty * 'v ty -> ('rest, ('a, 'v) map * 'rest) instr @@ -160,6 +161,7 @@ and ('bef, 'aft) instr = ('a * (('a, 'v) map * 'rest), 'v option * 'rest) instr | Map_update : ('a * ('v option * (('a, 'v) map * 'rest)), ('a, 'v) map * 'rest) instr + | Map_size : (('a, 'b) map * 'rest, n num * 'rest) instr (* string operations *) | Concat : (string * (string * 'rest), string * 'rest) instr diff --git a/test/contracts/map_size.tz b/test/contracts/map_size.tz new file mode 100644 index 000000000..befa00755 --- /dev/null +++ b/test/contracts/map_size.tz @@ -0,0 +1,4 @@ +parameter (map string nat); +return nat; +storage unit; +code {CAR; SIZE; UNIT; SWAP; PAIR} diff --git a/test/contracts/set_size.tz b/test/contracts/set_size.tz new file mode 100644 index 000000000..0fb1b10ad --- /dev/null +++ b/test/contracts/set_size.tz @@ -0,0 +1,4 @@ +parameter (set int); +storage unit; +return nat; +code {CAR; SIZE; UNIT; SWAP; PAIR} diff --git a/test/test_contracts.sh b/test/test_contracts.sh index 189f7ef2c..85597b49f 100755 --- a/test/test_contracts.sh +++ b/test/test_contracts.sh @@ -102,6 +102,20 @@ assert_output $CONTRACT_PATH/set_member.tz '(Set)' '"Hi"' 'False' assert_output $CONTRACT_PATH/set_member.tz '(Set "Hi")' '"Hi"' 'True' assert_output $CONTRACT_PATH/set_member.tz '(Set "Hello" "World")' '""' 'False' +# Set size +assert_output $CONTRACT_PATH/set_size.tz Unit '(Set)' 0 +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 + +# 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 +assert_output $CONTRACT_PATH/map_size.tz Unit \ + '(Map (Item "a" 1) (Item "b" 2) (Item "c" 3))' 3 +assert_output $CONTRACT_PATH/map_size.tz Unit \ + '(Map (Item "a" 1) (Item "b" 2) (Item "c" 3) (Item "d" 4) (Item "e" 5) (Item "f" 6))' 6 + # Contains all elements -- does the second list contain all of the same elements # as the first one? I'm ignoring element multiplicity assert_output $CONTRACT_PATH/contains_all.tz \