Michelson: special annotations %@ and @%

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
+expression ``[@:%](|[@%]|[_a-ZA-Z][_0-9a-zA-Z\.]*)``. They come after
-primitive name and before its potential arguments for primitive
+the primitive name and before its potential arguments.
-applications.
 
 ::
 
@@ -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
 ---------------
 

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-var-annotation)
-    '("\\<[%:]\\(\\|[A-Za-z-_][A-Za-z-_0-9\.]*\\)\\>" . michelson-face-type-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)

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 ;

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

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_] *)
+     annotations that start with [a-zA-Z_] *)
-  let sub_or_wildcard wrap s acc =
+  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 ~specials:[] (fun a -> `Type_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:(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 ->
+  = fun loc ?if_special_first ?if_special_second annot ->
-    parse_annots loc 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
+  : int -> ?if_special_var:var_annot option -> string list ->
-  = fun loc annot ->
+    (var_annot option * field_annot option) tzresult
-    parse_annots loc annot >>?
+  = 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 ->
+    get_one_annot loc fields >>? fun f ->
-    (v, 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

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

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 =
+let parse_constr_annot loc ?if_special_first ?if_special_second annot =
-  Lwt.return (parse_constr_annot loc 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 =
+let parse_var_field_annot loc ?if_special_var annot =
-  Lwt.return (parse_var_field_annot loc 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, _) ->
+      Item_t (t, rest, stack_annot) ->
-        parse_constr_annot loc annot >>=? fun (annot, ty_name, some_field, none_field) ->
+        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) ->