Commit 6dacd8f6 authored by Alain Mebsout's avatar Alain Mebsout Committed by Benjamin Canou

Michelson: Force annotations of the same kind to be grouped

parent 1748f370
......@@ -2158,7 +2158,8 @@ name and before its potential arguments for primitive applications.
Ordering between different kinds of annotations is not significant, but
ordering among annotations of the same kind is.
ordering among annotations of the same kind is. Annotations of a same
kind must be grouped together.
For instance these two annotated instructions are equivalent:
......@@ -2166,7 +2167,7 @@ For instance these two annotated instructions are equivalent:
PAIR :t @my_pair %x %y
PAIR %x :t %y @my_pair
PAIR %x %y :t @my_pair
Annotations and Macros
~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -72,6 +72,7 @@ let collect_error_locations errs =
(Invalid_arity (loc, _, _, _)
| Inconsistent_type_annotations (loc, _, _)
| Unexpected_annotation loc
| Ungrouped_annotations loc
| Type_too_large (loc, _, _)
| Invalid_namespace (loc, _, _, _)
| Invalid_primitive (loc, _, _)
......@@ -388,6 +389,10 @@ let report_errors ~details ~show_source ?parsed ppf errs =
Format.fprintf ppf
"@[<v 2>%aunexpected annotation."
print_loc loc
| Ungrouped_annotations loc ->
Format.fprintf ppf
"@[<v 2>%aAnnotations of the same kind must be grouped."
print_loc loc
| Type_too_large (loc, size, maximum_size) ->
Format.fprintf ppf
"@[<v 2>%atype size (%d) exceeded maximum type size (%d)."
......
......@@ -214,14 +214,33 @@ let parse_field_annot loc annot =
Lwt.return (parse_field_annot loc annot)
let classify_annot
: annot list -> var_annot list * type_annot list * field_annot list
= fun l ->
let rv, rt, rf = List.fold_left (fun (rv, rt, rf) -> function
| `Var_annot _ as a -> a :: rv, rt, rf
| `Type_annot _ as a -> rv, a :: rt, rf
| `Field_annot _ as a -> rv, rt, a :: rf
) ([], [], []) l in
List.rev rv, List.rev rt, List.rev rf
: int -> annot list ->
(var_annot list * type_annot list * field_annot list) tzresult Lwt.t
= fun loc l ->
try
let _, rv, _, rt, _, rf =
List.fold_left
(fun (in_v, rv, in_t, rt, in_f, rf) a ->
match a, in_v, rv, in_t, rt, in_f, rf with
| (`Var_annot _ as a), true, _, _, _, _, _
| (`Var_annot _ as a), false, [], _, _, _, _ ->
true, a :: rv,
false, rt,
false, rf
| (`Type_annot _ as a), _, _, true, _, _, _
| (`Type_annot _ as a), _, _, false, [], _, _ ->
false, rv,
true, a :: rt,
false, rf
| (`Field_annot _ as a), _, _, _, _, true, _
| (`Field_annot _ as a), _, _, _, _, false, [] ->
false, rv,
false, rt,
true, a :: rf
| _ -> raise Exit
) (false, [], false, [], false, []) l in
Lwt.return (ok (List.rev rv, List.rev rt, List.rev rf))
with Exit -> Lwt.return (error (Ungrouped_annotations loc))
let get_one_annot loc = function
| [] -> Lwt.return (ok None)
......@@ -239,7 +258,7 @@ let parse_constr_annot
(var_annot option * type_annot option * field_annot option * field_annot option) tzresult Lwt.t
= fun loc annot ->
Lwt.return (parse_annots loc annot) >>=? fun annot ->
let vars, types, fields = classify_annot annot in
classify_annot loc annot >>=? 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) ->
......@@ -249,7 +268,7 @@ let parse_two_var_annot
: int -> string list -> (var_annot option * var_annot option) tzresult Lwt.t
= fun loc annot ->
Lwt.return (parse_annots loc annot) >>=? fun annot ->
let vars, types, fields = classify_annot annot in
classify_annot loc annot >>=? fun (vars, types, fields) ->
fail_unexpected_annot loc types >>=? fun () ->
fail_unexpected_annot loc fields >>=? fun () ->
get_two_annot loc vars
......@@ -258,7 +277,7 @@ let parse_var_field_annot
: int -> string list -> (var_annot option * field_annot option) tzresult Lwt.t
= fun loc annot ->
Lwt.return (parse_annots loc annot) >>=? fun annot ->
let vars, types, fields = classify_annot annot in
classify_annot loc annot >>=? fun (vars, types, fields) ->
fail_unexpected_annot loc types >>=? fun () ->
get_one_annot loc vars >>=? fun v ->
get_one_annot loc fields >>|? fun f ->
......@@ -268,7 +287,7 @@ let parse_var_type_annot
: int -> string list -> (var_annot option * type_annot option) tzresult Lwt.t
= fun loc annot ->
Lwt.return (parse_annots loc annot) >>=? fun annot ->
let vars, types, fields = classify_annot annot in
classify_annot loc annot >>=? fun (vars, types, fields) ->
fail_unexpected_annot loc fields >>=? fun () ->
get_one_annot loc vars >>=? fun v ->
get_one_annot loc types >>|? fun t ->
......
......@@ -43,6 +43,7 @@ type error += Inconsistent_annotations of string * string
type error += Inconsistent_type_annotations : Script.location * _ ty * _ ty -> error
type error += Inconsistent_field_annotations of string * string
type error += Unexpected_annotation of Script.location
type error += Ungrouped_annotations 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
......
......@@ -370,6 +370,16 @@ let () =
(function Unexpected_annotation loc -> Some (loc, ())
| _ -> None)
(fun (loc, ()) -> Unexpected_annotation loc);
(* Unexpected annotation *)
register_error_kind
`Permanent
~id:"ungroupedAnnotations"
~title:"Annotations of the same kind were found spread apart"
~description:"Annotations of the same kind must be grouped"
(located empty)
(function Ungrouped_annotations loc -> Some (loc, ())
| _ -> None)
(fun (loc, ()) -> Ungrouped_annotations loc);
(* Unmatched branches *)
register_error_kind
`Permanent
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment