diff --git a/docs/whitedoc/michelson.rst b/docs/whitedoc/michelson.rst index 4bda58fb4..3ccf4b932 100644 --- a/docs/whitedoc/michelson.rst +++ b/docs/whitedoc/michelson.rst @@ -2149,9 +2149,8 @@ Syntax Primitive applications can receive one or many annotations. An annotation is a sequence of characters that matches the regular -expression ``[@:%](|[_a-ZA-Z][_0-9a-zA-Z\.]*)``. They come after the -primitive name and before its potential arguments for primitive -applications. +expression ``[@:%](|[@%]|[_a-ZA-Z][_0-9a-zA-Z\.]*)``. They come after +the primitive name and before its potential arguments. :: @@ -2308,6 +2307,27 @@ type (which can be changed). For instance the annotated typing rule for :: @l (list 'e) : 'A -> 'A iff body :: [ @l.elt e' : 'A -> 'A ] +Special Annotations +~~~~~~~~~~~~~~~~~~~ + +The special variable annotation ``@%`` can be used on instructions +``CAR`` and ``CDR``. It means to use the accessed field name (if any) as +a name for the value on the stack. + +:: + CAR @% + :: (pair ('a %fst) ('b %snd)) : 'S -> @fst 'a : 'S + + +The special variable annotation ``%@`` can be used on instructions +``PAIR``, ``SOME``, ``LEFT``, ``RIGHT``. It means to use the variable +name annotation in the stack as a field name for the constructed +element. An example with ``PAIR`` follows, + +:: + PAIR %@ %@ + :: @x 'a : @y 'b : 'S -> (pair ('a %x) ('b %y)) : 'S + XI - JSON syntax --------------- diff --git a/emacs/michelson-mode.el b/emacs/michelson-mode.el index 4c98d5a19..7e14fbfdf 100644 --- a/emacs/michelson-mode.el +++ b/emacs/michelson-mode.el @@ -172,8 +172,8 @@ Overrides `michelson-print-errors' and `michelson-highlight-errors'" (defconst michelson-font-lock-defaults (list (list - '("\\<[@]\\(\\|[A-Za-z-_][A-Za-z-_0-9\.]*\\)\\>" . michelson-face-var-annotation) - '("\\<[%:]\\(\\|[A-Za-z-_][A-Za-z-_0-9\.]*\\)\\>" . michelson-face-type-annotation) + '("\\<[@]\\(\\|%\\|[A-Za-z-_][A-Za-z-_0-9\.]*\\)\\>" . michelson-face-var-annotation) + '("\\<[%:]\\(\\|@\\|[A-Za-z-_][A-Za-z-_0-9\.]*\\)\\>" . michelson-face-type-annotation) '("\\<[0-9]+\\>" . michelson-face-constant) '("\\<[A-Z][a-z_0-9]+\\>" . michelson-face-constant) '("\\<[A-Z][A-Z_0-9]*\\>" . michelson-face-instruction) diff --git a/src/bin_client/test/contracts/vote_for_delegate.tz b/src/bin_client/test/contracts/vote_for_delegate.tz index 0fba38a62..43a68338a 100644 --- a/src/bin_client/test/contracts/vote_for_delegate.tz +++ b/src/bin_client/test/contracts/vote_for_delegate.tz @@ -3,7 +3,7 @@ storage (pair (pair %mgr1 (address %addr) (option key_hash)) (pair %mgr2 (address %addr) (option key_hash))) ; code { # Update the storage - DUP ; CDAAR %addr; SOURCE ; + DUP ; CDAAR %addr @%; SOURCE ; PAIR %@ %@; UNPAIR; IFCMPEQ { UNPAIR ; SWAP ; SET_CADR } { DUP ; CDDAR ; SOURCE ; diff --git a/src/lib_micheline/micheline_parser.ml b/src/lib_micheline/micheline_parser.ml index c5d39417e..c7aab702a 100644 --- a/src/lib_micheline/micheline_parser.ml +++ b/src/lib_micheline/micheline_parser.ml @@ -152,7 +152,7 @@ let tokenize source = | Some _ | None -> false in let allowed_annot_char c = match uchar_to_char c with - | Some ('a'..'z' | 'A'..'Z' | '_' | '.' | '0'..'9') -> true + | Some ('a'..'z' | 'A'..'Z' | '_' | '.' | '%' | '@' | '0'..'9') -> true | Some _ | None -> false in let rec skip acc = match next () with diff --git a/src/proto_alpha/lib_protocol/src/script_ir_annot.ml b/src/proto_alpha/lib_protocol/src/script_ir_annot.ml index 1cbc3500d..825e558c5 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/src/script_ir_annot.ml @@ -122,23 +122,30 @@ let error_unexpected_annot loc annot = let fail_unexpected_annot loc annot = Lwt.return (error_unexpected_annot loc annot) -let parse_annots loc l = +let parse_annots loc ?(allow_special_var = false) ?(allow_special_field = false) l = (* allow emtpty annotations as wildcards but otherwise only accept - annotations that starto with [a-zA-Z_] *) - let sub_or_wildcard wrap s acc = + annotations that start with [a-zA-Z_] *) + let sub_or_wildcard ~specials wrap s acc = let len = String.length s in if Compare.Int.(len = 1) then ok @@ wrap None :: acc else match s.[1] with | 'a' .. 'z' | 'A' .. 'Z' | '_' -> ok @@ wrap (Some (String.sub s 1 (len - 1))) :: acc + | ('%' | '@' as c) when Compare.Int.(len = 2) && List.mem c specials -> + ok @@ wrap (Some (String.sub s 1 (len - 1))) :: acc | _ -> error (Unexpected_annotation loc) in List.fold_left (fun acc s -> match acc with | Ok acc -> begin match s.[0] with - | '@' -> sub_or_wildcard (fun a -> `Var_annot a) s acc - | ':' -> sub_or_wildcard (fun a -> `Type_annot a) s acc - | '%' -> sub_or_wildcard (fun a -> `Field_annot a) s acc + | ':' -> sub_or_wildcard ~specials:[] (fun a -> `Type_annot a) s acc + | '@' -> + sub_or_wildcard + ~specials:(if allow_special_var then ['%'] else []) + (fun a -> `Var_annot a) s acc + | '%' -> sub_or_wildcard + ~specials:(if allow_special_field then ['@'] else []) + (fun a -> `Field_annot a) s acc | _ -> error (Unexpected_annotation loc) | exception Invalid_argument _ -> error (Unexpected_annotation loc) end @@ -294,14 +301,27 @@ let parse_var_annot | None -> None let parse_constr_annot - : int -> string list -> + : int -> + ?if_special_first:field_annot option -> + ?if_special_second:field_annot option -> + string list -> (var_annot option * type_annot option * field_annot option * field_annot option) tzresult - = fun loc annot -> - parse_annots loc annot >>? + = fun loc ?if_special_first ?if_special_second annot -> + parse_annots ~allow_special_field:true loc annot >>? classify_annot loc >>? fun (vars, types, fields) -> get_one_annot loc vars >>? fun v -> get_one_annot loc types >>? fun t -> - get_two_annot loc fields >|? fun (f1, f2) -> + get_two_annot loc fields >>? fun (f1, f2) -> + begin match if_special_first, f1 with + | Some special_var, Some `Field_annot "@" -> ok special_var + | None, Some `Field_annot "@" -> error (Unexpected_annotation loc) + | _, _ -> ok f1 + end >>? fun f1 -> + begin match if_special_second, f2 with + | Some special_var, Some `Field_annot "@" -> ok special_var + | None, Some `Field_annot "@" -> error (Unexpected_annotation loc) + | _, _ -> ok f2 + end >|? fun f2 -> (v, t, f1, f2) let parse_two_var_annot @@ -314,14 +334,18 @@ let parse_two_var_annot get_two_annot loc vars let parse_var_field_annot - : int -> string list -> (var_annot option * field_annot option) tzresult - = fun loc annot -> - parse_annots loc annot >>? + : int -> ?if_special_var:var_annot option -> string list -> + (var_annot option * field_annot option) tzresult + = fun loc ?if_special_var annot -> + parse_annots loc ~allow_special_var:true annot >>? classify_annot loc >>? fun (vars, types, fields) -> error_unexpected_annot loc types >>? fun () -> get_one_annot loc vars >>? fun v -> - get_one_annot loc fields >|? fun f -> - (v, f) + get_one_annot loc fields >>? fun f -> + match if_special_var, v with + | Some special_var, Some `Var_annot "%" -> ok (special_var, f) + | None, Some `Var_annot "%" -> error (Unexpected_annotation loc) + | _, _ -> ok (v, f) let parse_var_type_annot : int -> string list -> (var_annot option * type_annot option) tzresult diff --git a/src/proto_alpha/lib_protocol/src/script_ir_annot.mli b/src/proto_alpha/lib_protocol/src/script_ir_annot.mli index e57d4811a..ac39a8a18 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/src/script_ir_annot.mli @@ -119,7 +119,10 @@ val parse_var_annot : string list -> var_annot option tzresult val parse_constr_annot : - int -> string list -> + int -> + ?if_special_first:field_annot option -> + ?if_special_second:field_annot option -> + string list -> (var_annot option * type_annot option * field_annot option * field_annot option) tzresult @@ -127,7 +130,8 @@ val parse_two_var_annot : int -> string list -> (var_annot option * var_annot option) tzresult val parse_var_field_annot : - int -> string list -> (var_annot option * field_annot option) tzresult + int -> ?if_special_var:var_annot option -> string list -> + (var_annot option * field_annot option) tzresult val parse_var_type_annot : int -> string list -> (var_annot option * type_annot option) tzresult diff --git a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml index 796e69cc8..1ae911c9f 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml @@ -1073,12 +1073,12 @@ let address_size = (* Lwt versions *) let parse_var_annot loc ?default annot = Lwt.return (parse_var_annot loc ?default annot) -let parse_constr_annot loc annot = - Lwt.return (parse_constr_annot loc annot) +let parse_constr_annot loc ?if_special_first ?if_special_second annot = + Lwt.return (parse_constr_annot loc ?if_special_first ?if_special_second annot) let parse_two_var_annot loc annot = Lwt.return (parse_two_var_annot loc annot) -let parse_var_field_annot loc annot = - Lwt.return (parse_var_field_annot loc annot) +let parse_var_field_annot loc ?if_special_var annot = + Lwt.return (parse_var_field_annot loc ?if_special_var annot) let parse_var_type_annot loc annot = Lwt.return (parse_var_type_annot loc annot) @@ -1491,8 +1491,10 @@ and parse_instr typed ctxt loc (Const ()) (Item_t (Unit_t ty_name, stack, annot)) (* options *) | Prim (loc, I_SOME, [], annot), - Item_t (t, rest, _) -> - parse_constr_annot loc annot >>=? fun (annot, ty_name, some_field, none_field) -> + Item_t (t, rest, stack_annot) -> + parse_constr_annot loc annot + ~if_special_first:(var_to_field_annot stack_annot) + >>=? fun (annot, ty_name, some_field, none_field) -> typed ctxt loc Cons_some (Item_t (Option_t ((t, some_field), none_field, ty_name), rest, annot)) | Prim (loc, I_NONE, [ t ], annot), @@ -1516,12 +1518,17 @@ and parse_instr (* pairs *) | Prim (loc, I_PAIR, [], 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) -> + parse_constr_annot loc annot + ~if_special_first:(var_to_field_annot fst_annot) + ~if_special_second:(var_to_field_annot snd_annot) + >>=? fun (annot, ty_name, l_field, r_field) -> typed ctxt loc Cons_pair (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, a_annot), _, _), rest, pair_annot) -> - parse_var_field_annot loc annot >>=? fun (annot, field_annot) -> + parse_var_field_annot loc annot + ~if_special_var:(field_to_var_annot expected_field_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 @@ -1529,7 +1536,9 @@ and parse_instr typed ctxt loc Car (Item_t (a, rest, annot)) | Prim (loc, I_CDR, [], annot), Item_t (Pair_t (_, (b, expected_field_annot, b_annot), _), rest, pair_annot) -> - parse_var_field_annot loc annot >>=? fun (annot, field_annot) -> + parse_var_field_annot loc annot + ~if_special_var:(field_to_var_annot expected_field_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 @@ -1537,14 +1546,18 @@ and parse_instr typed ctxt loc Cdr (Item_t (b, rest, annot)) (* unions *) | Prim (loc, I_LEFT, [ tr ], annot), - Item_t (tl, rest, _stack_annot) -> + Item_t (tl, rest, stack_annot) -> Lwt.return @@ parse_ty ~allow_big_map:false ~allow_operation:true tr >>=? fun (Ex_ty tr) -> - parse_constr_annot loc annot >>=? fun (annot, tname, l_field, r_field) -> + parse_constr_annot loc annot + ~if_special_first:(var_to_field_annot stack_annot) + >>=? fun (annot, tname, l_field, r_field) -> typed ctxt loc Left (Item_t (Union_t ((tl, l_field), (tr, r_field), tname), rest, annot)) | Prim (loc, I_RIGHT, [ tl ], annot), - Item_t (tr, rest, _stack_annot) -> + Item_t (tr, rest, stack_annot) -> Lwt.return @@ parse_ty ~allow_big_map:false ~allow_operation:true tl >>=? fun (Ex_ty tl) -> - parse_constr_annot loc annot >>=? fun (annot, tname, l_field, r_field) -> + parse_constr_annot loc annot + ~if_special_second:(var_to_field_annot stack_annot) + >>=? fun (annot, tname, l_field, r_field) -> typed ctxt loc Right (Item_t (Union_t ((tl, l_field), (tr, r_field), tname), rest, annot)) | Prim (loc, I_IF_LEFT, [ bt ; bf ], annot), (Item_t (Union_t ((tl, l_field), (tr, r_field), _), rest, union_annot) as bef) ->