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

Michelson: keep field annotations in SET_CADR, MAP_CADR macros

Browse Source
This commit is contained in:
Alain Mebsout 2018-06-12 12:45:19 +02:00 committed by Benjamin Canou
parent 040fa2a075
commit 1fccffb61c
7 changed files with 156 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
docs/whitedoc/michelson.rst
View File

@ -2149,7 +2149,7 @@ Syntax
Primitive applications can receive one or many annotations. Primitive applications can receive one or many annotations.
An annotation is a sequence of characters that matches the regular An annotation is a sequence of characters that matches the regular
expression ``[@:%](|[@%]|[_a-ZA-Z][_0-9a-zA-Z\.]*)``. They come after expression ``[@:%](|@|%|%%|[_a-ZA-Z][_0-9a-zA-Z\.]*)``. They come after
the primitive name and before its potential arguments. the primitive name and before its potential arguments.
:: ::
@ -2310,24 +2310,32 @@ type (which can be changed). For instance the annotated typing rule for
Special Annotations Special Annotations
~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~
The special variable annotation ``@%`` can be used on instructions The special variable annotations ``@%%`` can be used on instructions
``CAR`` and ``CDR``. It means to use the accessed field name (if any) as ``CAR`` and ``CDR``. It means to use the accessed field name (if any) as
a name for the value on the stack. a name for the value on the stack. The following typing rule
demonstrates their use for instruction ``CAR``.
:: ::
CAR @% CAR @%
:: (pair ('a %fst) ('b %snd)) : 'S -> @fst 'a : 'S :: @p (pair ('a %fst) ('b %snd)) : 'S -> @fst 'a : 'S
CAR @%%
:: @p (pair ('a %fst) ('b %snd)) : 'S -> @p.fst 'a : 'S
The special variable annotation ``%@`` can be used on instructions The special variable annotation ``%@`` can be used on instructions
``PAIR``, ``SOME``, ``LEFT``, ``RIGHT``. It means to use the variable ``PAIR``, ``SOME``, ``LEFT``, ``RIGHT``. It means to use the variable
name annotation in the stack as a field name for the constructed name annotation in the stack as a field name for the constructed
element. An example with ``PAIR`` follows, element. Two examples with ``PAIR`` follows, notice the special
treatment of annotations with `.`.
:: ::
PAIR %@ %@ PAIR %@ %@
:: @x 'a : @y 'b : 'S -> (pair ('a %x) ('b %y)) : 'S :: @x 'a : @y 'b : 'S -> (pair ('a %x) ('b %y)) : 'S
PAIR %@ %@
:: @p.x 'a : @p.y 'b : 'S -> @p (pair ('a %x) ('b %y)) : 'S
:: @p.x 'a : @q.y 'b : 'S -> (pair ('a %x) ('b %y)) : 'S
XI - JSON syntax XI - JSON syntax
--------------- ---------------

4
emacs/michelson-mode.el
View File

@ -172,7 +172,7 @@ Overrides `michelson-print-errors' and `michelson-highlight-errors'"
(defconst michelson-font-lock-defaults (defconst michelson-font-lock-defaults
(list (list
(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) '("\\<[0-9]+\\>" . michelson-face-constant)
'("\\<[A-Z][a-z_0-9]+\\>" . michelson-face-constant) '("\\<[A-Z][a-z_0-9]+\\>" . michelson-face-constant)
@ -501,7 +501,7 @@ If `DO-NOT-OVERWRITE' is non-nil, the existing contents of the buffer are mainta
(lexical-let* (lexical-let*
((pp-no-trailing-newline ((pp-no-trailing-newline
(lambda (sexp) (lambda (sexp)
(let* ((str (pp-to-string sexp)) (let* ((str (replace-regexp-in-string "\\\\\." "." (pp-to-string sexp)))
(len (length str))) (len (length str)))
(if (equal "\n" (substring str (- len 1) len)) (if (equal "\n" (substring str (- len 1) len))
(substring str 0 (- len 1)) (substring str 0 (- len 1))

8
src/bin_client/test/contracts/vote_for_delegate.tz
View File

@ -1,14 +1,14 @@
parameter (option key_hash) ; parameter (option key_hash) ;
storage (pair storage (pair
(pair %mgr1 (address %addr) (option key_hash)) (pair %mgr1 (address %addr) (option %key key_hash))
(pair %mgr2 (address %addr) (option key_hash))) ; (pair %mgr2 (address %addr) (option %key key_hash))) ;
code { # Update the storage code { # Update the storage
DUP ; CDAAR %addr @%; SOURCE ; PAIR %@ %@; UNPAIR; DUP ; CDAAR %addr @%; SOURCE ; PAIR %@ %@; UNPAIR;
IFCMPEQ IFCMPEQ
{ UNPAIR ; SWAP ; SET_CADR } { UNPAIR ; SWAP ; SET_CADR %key @changed_mgr1_key }
{ DUP ; CDDAR ; SOURCE ; { DUP ; CDDAR ; SOURCE ;
IFCMPEQ IFCMPEQ
{ UNPAIR ; SWAP ; SET_CDDR } { UNPAIR ; SWAP ; SET_CDDR %key }
{ FAIL } } ; { FAIL } } ;
# Now compare the proposals # Now compare the proposals
DUP ; CADR ; DUP ; CADR ;

120
src/proto_alpha/lib_client/michelson_v1_macros.ml
View File

@ -61,7 +61,7 @@ let extract_first_annot annot char =
extract_first_annot [] annot extract_first_annot [] annot
let extract_first_field_annot annot = extract_first_annot annot '%' let extract_first_field_annot annot = extract_first_annot annot '%'
let extract_first_bind_annot annot = extract_first_annot annot '$' let extract_first_var_annot annot = extract_first_annot annot '@'
let extract_field_annots annot = let extract_field_annots annot =
List.partition (fun a -> List.partition (fun a ->
@ -84,7 +84,11 @@ let expand_set_caddadr original =
| [] -> ok () | [] -> ok ()
| _ :: _ -> error (Invalid_arity (str, List.length args, 0)) | _ :: _ -> error (Invalid_arity (str, List.length args, 0))
end >>? fun () -> end >>? fun () ->
let field_annot, annot = extract_first_field_annot annot in begin match extract_field_annots annot with
| [], annot -> ok (None, annot)
| [f], annot -> ok (Some f, annot)
| _, _ -> error (Unexpected_macro_annotation str)
end >>? fun (field_annot, annot) ->
let rec parse i acc = let rec parse i acc =
if i = 4 then if i = 4 then
acc acc
@ -97,11 +101,11 @@ let expand_set_caddadr original =
[ Prim (loc, "DUP", [], []) ; [ Prim (loc, "DUP", [], []) ;
Prim (loc, "DIP", Prim (loc, "DIP",
[ Seq (loc, [ Seq (loc,
[ Prim (loc, "CAR", [], []) ; [ Prim (loc, "CAR", [], [ "@%%" ]) ;
acc ]) ], []) ; acc ]) ], []) ;
Prim (loc, "CDR", [], []) ; Prim (loc, "CDR", [], [ "@%%" ]) ;
Prim (loc, "SWAP", [], []) ; Prim (loc, "SWAP", [], []) ;
Prim (loc, "PAIR", [], annot) ]) in Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ]) in
parse (i - 1) acc parse (i - 1) acc
| 'D' -> | 'D' ->
let acc = let acc =
@ -109,10 +113,10 @@ let expand_set_caddadr original =
[ Prim (loc, "DUP", [], []) ; [ Prim (loc, "DUP", [], []) ;
Prim (loc, "DIP", Prim (loc, "DIP",
[ Seq (loc, [ Seq (loc,
[ Prim (loc, "CDR", [], []) ; [ Prim (loc, "CDR", [], [ "@%%" ]) ;
acc ]) ], []) ; acc ]) ], []) ;
Prim (loc, "CAR", [], []) ; Prim (loc, "CAR", [], [ "@%%" ]) ;
Prim (loc, "PAIR", [], annot) ]) in Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ]) in
parse (i - 1) acc parse (i - 1) acc
| _ -> assert false in | _ -> assert false in
match String.get str (len - 2) with match String.get str (len - 2) with
@ -123,9 +127,10 @@ let expand_set_caddadr original =
Prim (loc, "CAR", [], [ f ]) ; Prim (loc, "CAR", [], [ f ]) ;
Prim (loc, "DROP", [], []) ; Prim (loc, "DROP", [], []) ;
] in ] in
let encoding = [ Prim (loc, "CDR", [], []) ; let encoding = [ Prim (loc, "CDR", [], [ "@%%" ]) ;
Prim (loc, "SWAP", [], []) ] in Prim (loc, "SWAP", [], []) ] in
let pair = [ Prim (loc, "PAIR", [], []) ] in let pair = [ Prim (loc, "PAIR", [],
[ Option.unopt field_annot ~default:"%" ; "%@" ]) ] in
let init = Seq (loc, access_check @ encoding @ pair) in let init = Seq (loc, access_check @ encoding @ pair) in
ok (Some (parse (len - 3) init)) ok (Some (parse (len - 3) init))
| 'D' -> | 'D' ->
@ -135,8 +140,9 @@ let expand_set_caddadr original =
Prim (loc, "CDR", [], [ f ]) ; Prim (loc, "CDR", [], [ f ]) ;
Prim (loc, "DROP", [], []) ; Prim (loc, "DROP", [], []) ;
] in ] in
let encoding = [ Prim (loc, "CAR", [], []) ] in let encoding = [ Prim (loc, "CAR", [], [ "@%%" ]) ] in
let pair = [ Prim (loc, "PAIR", [], []) ] in let pair = [ Prim (loc, "PAIR", [],
[ "%@" ; Option.unopt field_annot ~default:"%" ]) ] in
let init = Seq (loc, access_check @ encoding @ pair) in let init = Seq (loc, access_check @ encoding @ pair) in
ok (Some (parse (len - 3) init)) ok (Some (parse (len - 3) init))
| _ -> assert false | _ -> assert false
@ -158,8 +164,11 @@ let expand_map_caddadr original =
| [ _ ] -> error (Sequence_expected str) | [ _ ] -> error (Sequence_expected str)
| [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1)) | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))
end >>? fun code -> end >>? fun code ->
let field_annot, annot = extract_first_field_annot annot in begin match extract_field_annots annot with
let bind_annot, annot = extract_first_bind_annot annot in | [], annot -> ok (None, annot)
| [f], annot -> ok (Some f, annot)
| _, _ -> error (Unexpected_macro_annotation str)
end >>? fun (field_annot, annot) ->
let rec parse i acc = let rec parse i acc =
if i = 4 then if i = 4 then
acc acc
@ -172,11 +181,11 @@ let expand_map_caddadr original =
[ Prim (loc, "DUP", [], []) ; [ Prim (loc, "DUP", [], []) ;
Prim (loc, "DIP", Prim (loc, "DIP",
[ Seq (loc, [ Seq (loc,
[ Prim (loc, "CAR", [], []) ; [ Prim (loc, "CAR", [], [ "@%%" ]) ;
acc ]) ], []) ; acc ]) ], []) ;
Prim (loc, "CDR", [], []) ; Prim (loc, "CDR", [], [ "@%%" ]) ;
Prim (loc, "SWAP", [], []) ; Prim (loc, "SWAP", [], []) ;
Prim (loc, "PAIR", [], annot) ]) in Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ]) in
parse (i - 1) acc parse (i - 1) acc
| 'D' -> | 'D' ->
let acc = let acc =
@ -184,30 +193,26 @@ let expand_map_caddadr original =
[ Prim (loc, "DUP", [], []) ; [ Prim (loc, "DUP", [], []) ;
Prim (loc, "DIP", Prim (loc, "DIP",
[ Seq (loc, [ Seq (loc,
[ Prim (loc, "CDR", [], []) ; [ Prim (loc, "CDR", [], [ "@%%" ]) ;
acc ]) ], []) ; acc ]) ], []) ;
Prim (loc, "CAR", [], []) ; Prim (loc, "CAR", [], [ "@%%" ]) ;
Prim (loc, "PAIR", [], annot) ]) in Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ]) in
parse (i - 1) acc parse (i - 1) acc
| _ -> assert false in | _ -> assert false in
let cr_annot = let cr_annot = match field_annot with
let f = match field_annot with | None -> []
| None -> [] | Some f -> [ "@" ^ String.sub f 1 (String.length f - 1) ] in
| Some f -> [ f ] in
let b = match bind_annot with
| None -> []
| Some b -> [ "@" ^ String.sub b 1 (String.length b - 1) ] in
f @ b in
match String.get str (len - 2) with match String.get str (len - 2) with
| 'A' -> | 'A' ->
let init = let init =
Seq (loc, Seq (loc,
[ Prim (loc, "DUP", [], []) ; [ Prim (loc, "DUP", [], []) ;
Prim (loc, "CDR", [], []) ; Prim (loc, "CDR", [], [ "@%%" ]) ;
Prim (loc, "DIP", Prim (loc, "DIP",
[ Seq (loc, [ Prim (loc, "CAR", [], cr_annot) ; code ]) ], []) ; [ Seq (loc, [ Prim (loc, "CAR", [], cr_annot) ; code ]) ], []) ;
Prim (loc, "SWAP", [], []) ; Prim (loc, "SWAP", [], []) ;
Prim (loc, "PAIR", [], []) ]) in Prim (loc, "PAIR", [],
[ Option.unopt field_annot ~default:"%" ; "%@"]) ]) in
ok (Some (parse (len - 3) init)) ok (Some (parse (len - 3) init))
| 'D' -> | 'D' ->
let init = let init =
@ -216,8 +221,9 @@ let expand_map_caddadr original =
Prim (loc, "CDR", [], cr_annot) ; Prim (loc, "CDR", [], cr_annot) ;
code ; code ;
Prim (loc, "SWAP", [], []) ; Prim (loc, "SWAP", [], []) ;
Prim (loc, "CAR", [], []) ; Prim (loc, "CAR", [], [ "@%%" ]) ;
Prim (loc, "PAIR", [], []) ]) in Prim (loc, "PAIR", [],
[ "%@" ; Option.unopt field_annot ~default:"%" ]) ]) in
ok (Some (parse (len - 3) init)) ok (Some (parse (len - 3) init))
| _ -> assert false | _ -> assert false
else else
@ -640,47 +646,49 @@ let unexpand_caddadr expanded =
let unexpand_set_caddadr expanded = let unexpand_set_caddadr expanded =
let rec steps acc annots = function let rec steps acc annots = function
| Seq (loc, | Seq (loc,
[ Prim (_, "CDR", [], []) ; [ Prim (_, "CDR", [], _) ;
Prim (_, "SWAP", [], []) ; Prim (_, "SWAP", [], _) ;
Prim (_, "PAIR", [], []) ]) -> Prim (_, "PAIR", [], _) ]) ->
Some (loc, "A" :: acc, annots) Some (loc, "A" :: acc, annots)
| Seq (loc, | Seq (loc,
[ Prim (_, "DUP", [], []) ; [ Prim (_, "DUP", [], []) ;
Prim (_, "CAR", [], [ field_annot ]) ; Prim (_, "CAR", [], [ field_annot ]) ;
Prim (_, "DROP", [], []) ; Prim (_, "DROP", [], []) ;
Prim (_, "CDR", [], []) ; Prim (_, "CDR", [], _) ;
Prim (_, "SWAP", [], []) ; Prim (_, "SWAP", [], []) ;
Prim (_, "PAIR", [], []) ]) -> Prim (_, "PAIR", [], _) ]) ->
Some (loc, "A" :: acc, field_annot :: annots) Some (loc, "A" :: acc, field_annot :: annots)
| Seq (loc, | Seq (loc,
[ Prim (_, "CAR", [], []) ; [ Prim (_, "CAR", [], _) ;
Prim (_, "PAIR", [], []) ]) -> Prim (_, "PAIR", [], _) ]) ->
Some (loc, "D" :: acc, annots) Some (loc, "D" :: acc, annots)
| Seq (loc, | Seq (loc,
[ Prim (_, "DUP", [], []) ; [ Prim (_, "DUP", [], []) ;
Prim (_, "CDR", [], [ field_annot ]) ; Prim (_, "CDR", [], [ field_annot ]) ;
Prim (_, "DROP", [], []) ; Prim (_, "DROP", [], []) ;
Prim (_, "CAR", [], []) ; Prim (_, "CAR", [], _) ;
Prim (_, "PAIR", [], []) ]) -> Prim (_, "PAIR", [], _) ]) ->
Some (loc, "D" :: acc, field_annot :: annots) Some (loc, "D" :: acc, field_annot :: annots)
| Seq (_, | Seq (_,
[ Prim (_, "DUP", [], []) ; [ Prim (_, "DUP", [], []) ;
Prim (_, "DIP", Prim (_, "DIP",
[ Seq (_, [ Seq (_,
[ Prim (_, "CAR", [], []) ; [ Prim (_, "CAR", [], _) ;
sub ]) ], []) ; sub ]) ], []) ;
Prim (_, "CDR", [], []) ; Prim (_, "CDR", [], _) ;
Prim (_, "SWAP", [], []) ; Prim (_, "SWAP", [], []) ;
Prim (_, "PAIR", [], pair_annots) ]) -> Prim (_, "PAIR", [], pair_annots) ]) ->
let _, pair_annots = extract_field_annots pair_annots in
steps ("A" :: acc) (List.rev_append pair_annots annots) sub steps ("A" :: acc) (List.rev_append pair_annots annots) sub
| Seq (_, | Seq (_,
[ Prim (_, "DUP", [], []) ; [ Prim (_, "DUP", [], []) ;
Prim (_, "DIP", Prim (_, "DIP",
[ Seq (_, [ Seq (_,
[ Prim (_, "CDR", [], []) ; [ Prim (_, "CDR", [], _) ;
sub ]) ], []) ; sub ]) ], []) ;
Prim (_, "CAR", [], []) ; Prim (_, "CAR", [], _) ;
Prim (_, "PAIR", [], pair_annots) ]) -> Prim (_, "PAIR", [], pair_annots) ]) ->
let _, pair_annots = extract_field_annots pair_annots in
steps ("D" :: acc) (List.rev_append pair_annots annots) sub steps ("D" :: acc) (List.rev_append pair_annots annots) sub
| _ -> None in | _ -> None in
match steps [] [] expanded with match steps [] [] expanded with
@ -693,49 +701,50 @@ let unexpand_map_caddadr expanded =
let rec steps acc annots = function let rec steps acc annots = function
| Seq (loc, | Seq (loc,
[ Prim (_, "DUP", [], []) ; [ Prim (_, "DUP", [], []) ;
Prim (_, "CDR", [], []) ; Prim (_, "CDR", [], _) ;
Prim (_, "SWAP", [], []) ; Prim (_, "SWAP", [], []) ;
Prim (_, "DIP", Prim (_, "DIP",
[ Seq (_, [ Seq (_,
[ Prim (_, "CAR", [], []) ; [ Prim (_, "CAR", [], []) ;
code ]) ], []) ; code ]) ], []) ;
Prim (_, "PAIR", [], []) ]) -> Prim (_, "PAIR", [], _) ]) ->
Some (loc, "A" :: acc, annots, code) Some (loc, "A" :: acc, annots, code)
| Seq (loc, | Seq (loc,
[ Prim (_, "DUP", [], []) ; [ Prim (_, "DUP", [], []) ;
Prim (_, "CDR", [], []) ; Prim (_, "CDR", [], _) ;
Prim (_, "SWAP", [], []) ; Prim (_, "SWAP", [], []) ;
Prim (_, "DIP", Prim (_, "DIP",
[ Seq (_, [ Seq (_,
[ Prim (_, "CAR", [], [ field_annot ]) ; [ Prim (_, "CAR", [], [ field_annot ]) ;
code ]) ], []) ; code ]) ], []) ;
Prim (_, "PAIR", [], []) ]) -> Prim (_, "PAIR", [], _) ]) ->
Some (loc, "A" :: acc, field_annot :: annots, code) Some (loc, "A" :: acc, field_annot :: annots, code)
| Seq (loc, | Seq (loc,
[ Prim (_, "DUP", [], []) ; [ Prim (_, "DUP", [], []) ;
Prim (_, "CDR", [], []) ; Prim (_, "CDR", [], []) ;
code ; code ;
Prim (_, "SWAP", [], []) ; Prim (_, "SWAP", [], []) ;
Prim (_, "CAR", [], []) ; Prim (_, "CAR", [], _) ;
Prim (_, "PAIR", [], []) ]) -> Prim (_, "PAIR", [], _) ]) ->
Some (loc, "D" :: acc, annots, code) Some (loc, "D" :: acc, annots, code)
| Seq (loc, | Seq (loc,
[ Prim (_, "DUP", [], []) ; [ Prim (_, "DUP", [], []) ;
Prim (_, "CDR", [], [ field_annot ]) ; Prim (_, "CDR", [], [ field_annot ]) ;
code ; code ;
Prim (_, "SWAP", [], []) ; Prim (_, "SWAP", [], []) ;
Prim (_, "CAR", [], []) ; Prim (_, "CAR", [], _) ;
Prim (_, "PAIR", [], []) ]) -> Prim (_, "PAIR", [], _) ]) ->
Some (loc, "D" :: acc, field_annot :: annots, code) Some (loc, "D" :: acc, field_annot :: annots, code)
| Seq (_, | Seq (_,
[ Prim (_, "DUP", [], []) ; [ Prim (_, "DUP", [], []) ;
Prim (_, "DIP", Prim (_, "DIP",
[ Seq (_, [ Seq (_,
[ Prim (_, "CAR", [], []) ; [ Prim (_, "CAR", [], _) ;
sub ]) ], []) ; sub ]) ], []) ;
Prim (_, "CDR", [], []) ; Prim (_, "CDR", [], _) ;
Prim (_, "SWAP", [], []) ; Prim (_, "SWAP", [], []) ;
Prim (_, "PAIR", [], pair_annots) ]) -> Prim (_, "PAIR", [], pair_annots) ]) ->
let _, pair_annots = extract_field_annots pair_annots in
steps ("A" :: acc) (List.rev_append pair_annots annots) sub steps ("A" :: acc) (List.rev_append pair_annots annots) sub
| Seq (_, | Seq (_,
[ Prim (_, "DUP", [], []) ; [ Prim (_, "DUP", [], []) ;
@ -745,6 +754,7 @@ let unexpand_map_caddadr expanded =
sub ]) ], []) ; sub ]) ], []) ;
Prim (_, "CAR", [], []) ; Prim (_, "CAR", [], []) ;
Prim (_, "PAIR", [], pair_annots) ]) -> Prim (_, "PAIR", [], pair_annots) ]) ->
let _, pair_annots = extract_field_annots pair_annots in
steps ("D" :: acc) (List.rev_append pair_annots annots) sub steps ("D" :: acc) (List.rev_append pair_annots annots) sub
| _ -> None in | _ -> None in
match steps [] [] expanded with match steps [] [] expanded with

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

@ -131,8 +131,14 @@ let parse_annots loc ?(allow_special_var = false) ?(allow_special_field = false)
else match s.[1] with else match s.[1] with
| 'a' .. 'z' | 'A' .. 'Z' | '_' -> | 'a' .. 'z' | 'A' .. 'Z' | '_' ->
ok @@ wrap (Some (String.sub s 1 (len - 1))) :: acc ok @@ wrap (Some (String.sub s 1 (len - 1))) :: acc
| ('%' | '@' as c) when Compare.Int.(len = 2) && List.mem c specials -> | '@' when Compare.Int.(len = 2) && List.mem '@' specials ->
ok @@ wrap (Some (String.sub s 1 (len - 1))) :: acc ok @@ wrap (Some "@") :: acc
| '%' when List.mem '%' specials ->
if Compare.Int.(len = 2)
then ok @@ wrap (Some "%") :: acc
else if Compare.Int.(len = 3) && Compare.Char.(s.[2] = '%')
then ok @@ wrap (Some "%%") :: acc
else error (Unexpected_annotation loc)
| _ -> error (Unexpected_annotation loc) in | _ -> error (Unexpected_annotation loc) in
List.fold_left (fun acc s -> List.fold_left (fun acc s ->
match acc with match acc with
@ -300,6 +306,27 @@ let parse_var_annot
| Some a -> a | Some a -> a
| None -> None | None -> None
let split_last_dot = function
| None -> None, None
| Some `Field_annot s ->
try
let i = String.rindex s '.' in
let s1 = String.sub s 0 i in
let s2 = String.sub s (i + 1) (String.length s - i - 1) in
let f =
if Compare.String.equal s2 "car" || Compare.String.equal s2 "cdr"
then None
else Some (`Field_annot s2) in
Some (`Var_annot s1), f
with Not_found -> None, Some (`Field_annot s)
let common_prefix v1 v2 =
match v1, v2 with
| Some (`Var_annot s1), Some (`Var_annot s2) when Compare.String.equal s1 s2 -> v1
| Some _, None -> v1
| None, Some _ -> v2
| _, _ -> None
let parse_constr_annot let parse_constr_annot
: int -> : int ->
?if_special_first:field_annot option -> ?if_special_first:field_annot option ->
@ -313,15 +340,20 @@ let parse_constr_annot
get_one_annot loc types >>? fun t -> 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 begin match if_special_first, f1 with
| Some special_var, Some `Field_annot "@" -> ok special_var | Some special_var, Some `Field_annot "@" ->
ok (split_last_dot special_var)
| None, Some `Field_annot "@" -> error (Unexpected_annotation loc) | None, Some `Field_annot "@" -> error (Unexpected_annotation loc)
| _, _ -> ok f1 | _, _ -> ok (v, f1)
end >>? fun f1 -> end >>? fun (v1, f1) ->
begin match if_special_second, f2 with begin match if_special_second, f2 with
| Some special_var, Some `Field_annot "@" -> ok special_var | Some special_var, Some `Field_annot "@" ->
ok (split_last_dot special_var)
| None, Some `Field_annot "@" -> error (Unexpected_annotation loc) | None, Some `Field_annot "@" -> error (Unexpected_annotation loc)
| _, _ -> ok f2 | _, _ -> ok (v, f2)
end >|? fun f2 -> end >|? fun (v2, f2) ->
let v = match v with
| None -> common_prefix v1 v2
| Some _ -> v in
(v, t, f1, f2) (v, t, f1, f2)
let parse_two_var_annot let parse_two_var_annot
@ -333,19 +365,24 @@ let parse_two_var_annot
error_unexpected_annot loc fields >>? fun () -> error_unexpected_annot loc fields >>? fun () ->
get_two_annot loc vars get_two_annot loc vars
let parse_var_field_annot let parse_destr_annot
: int -> ?if_special_var:var_annot option -> string list -> : int -> string list -> default_accessor:field_annot option ->
(var_annot option * field_annot option) tzresult field_name:field_annot option ->
= fun loc ?if_special_var annot -> pair_annot:var_annot option -> value_annot:var_annot option ->
(var_annot option * field_annot option) tzresult
= fun loc annot ~default_accessor ~field_name ~pair_annot ~value_annot ->
parse_annots loc ~allow_special_var:true annot >>? parse_annots loc ~allow_special_var:true annot >>?
classify_annot loc >>? fun (vars, types, fields) -> classify_annot loc >>? fun (vars, types, fields) ->
error_unexpected_annot loc types >>? fun () -> error_unexpected_annot loc types >>? fun () ->
get_one_annot loc vars >>? fun v -> get_one_annot loc vars >>? fun v ->
get_one_annot loc fields >>? fun f -> get_one_annot loc fields >|? fun f ->
match if_special_var, v with let default = gen_access_annot pair_annot field_name ~default:default_accessor in
| Some special_var, Some `Var_annot "%" -> ok (special_var, f) let v = match v with
| None, Some `Var_annot "%" -> error (Unexpected_annotation loc) | Some `Var_annot "%" -> field_to_var_annot field_name
| _, _ -> ok (v, f) | Some `Var_annot "%%" -> default
| Some _ -> v
| None -> value_annot in
(v, f)
let parse_var_type_annot let parse_var_type_annot
: int -> string list -> (var_annot option * type_annot option) tzresult : int -> string list -> (var_annot option * type_annot option) tzresult

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

@ -129,8 +129,12 @@ val parse_constr_annot :
val parse_two_var_annot : val parse_two_var_annot :
int -> string list -> (var_annot option * var_annot option) tzresult int -> string list -> (var_annot option * var_annot option) tzresult
val parse_var_field_annot : val parse_destr_annot :
int -> ?if_special_var:var_annot option -> string list -> int -> string list ->
default_accessor:field_annot option ->
field_name:field_annot option ->
pair_annot:var_annot option ->
value_annot:var_annot option ->
(var_annot option * field_annot option) tzresult (var_annot option * field_annot option) tzresult
val parse_var_type_annot : val parse_var_type_annot :

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

@ -1077,8 +1077,8 @@ 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) Lwt.return (parse_constr_annot loc ?if_special_first ?if_special_second annot)
let parse_two_var_annot loc annot = let parse_two_var_annot loc annot =
Lwt.return (parse_two_var_annot loc annot) Lwt.return (parse_two_var_annot loc annot)
let parse_var_field_annot loc ?if_special_var annot = let parse_destr_annot loc annot ~default_accessor ~field_name ~pair_annot ~value_annot =
Lwt.return (parse_var_field_annot loc ?if_special_var annot) Lwt.return (parse_destr_annot loc annot ~default_accessor ~field_name ~pair_annot ~value_annot)
let parse_var_type_annot loc annot = let parse_var_type_annot loc annot =
Lwt.return (parse_var_type_annot loc annot) Lwt.return (parse_var_type_annot loc annot)
@ -1526,22 +1526,22 @@ and parse_instr
(Item_t (Pair_t((a, l_field, fst_annot), (b, r_field, snd_annot), 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), | Prim (loc, I_CAR, [], annot),
Item_t (Pair_t ((a, expected_field_annot, a_annot), _, _), rest, pair_annot) -> Item_t (Pair_t ((a, expected_field_annot, a_annot), _, _), rest, pair_annot) ->
parse_var_field_annot loc annot parse_destr_annot loc annot
~if_special_var:(field_to_var_annot expected_field_annot) ~pair_annot
~value_annot:a_annot
~field_name:expected_field_annot
~default_accessor:default_car_annot
>>=? fun (annot, 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
Lwt.return @@ check_correct_field field_annot expected_field_annot >>=? fun () -> Lwt.return @@ check_correct_field field_annot expected_field_annot >>=? fun () ->
typed ctxt loc Car (Item_t (a, rest, annot)) typed ctxt loc Car (Item_t (a, rest, annot))
| Prim (loc, I_CDR, [], annot), | Prim (loc, I_CDR, [], annot),
Item_t (Pair_t (_, (b, expected_field_annot, b_annot), _), rest, pair_annot) -> Item_t (Pair_t (_, (b, expected_field_annot, b_annot), _), rest, pair_annot) ->
parse_var_field_annot loc annot parse_destr_annot loc annot
~if_special_var:(field_to_var_annot expected_field_annot) ~pair_annot
~value_annot:b_annot
~field_name:expected_field_annot
~default_accessor:default_cdr_annot
>>=? fun (annot, 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
Lwt.return @@ check_correct_field field_annot expected_field_annot >>=? fun () -> Lwt.return @@ check_correct_field field_annot expected_field_annot >>=? fun () ->
typed ctxt loc Cdr (Item_t (b, rest, annot)) typed ctxt loc Cdr (Item_t (b, rest, annot))
(* unions *) (* unions *)