From 6dacd8f6a51eb6bec87454ac629678a2a06b19d4 Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Fri, 8 Jun 2018 13:43:40 +0200 Subject: [PATCH] Michelson: Force annotations of the same kind to be grouped --- docs/whitedoc/michelson.rst | 5 ++- .../lib_client/michelson_v1_error_reporter.ml | 5 +++ .../lib_protocol/src/script_ir_annot.ml | 43 +++++++++++++------ .../lib_protocol/src/script_tc_errors.ml | 1 + .../src/script_tc_errors_registration.ml | 10 +++++ 5 files changed, 50 insertions(+), 14 deletions(-) diff --git a/docs/whitedoc/michelson.rst b/docs/whitedoc/michelson.rst index dbd197162..3c07fbc84 100644 --- a/docs/whitedoc/michelson.rst +++ b/docs/whitedoc/michelson.rst @@ -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 ~~~~~~~~~~~~~~~~~~~~~~ diff --git a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml index 13c851c76..be655fae6 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -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 "@[%aunexpected annotation." print_loc loc + | Ungrouped_annotations loc -> + Format.fprintf ppf + "@[%aAnnotations of the same kind must be grouped." + print_loc loc | Type_too_large (loc, size, maximum_size) -> Format.fprintf ppf "@[%atype size (%d) exceeded maximum type size (%d)." 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 5475a9498..a631263f8 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/src/script_ir_annot.ml @@ -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 -> diff --git a/src/proto_alpha/lib_protocol/src/script_tc_errors.ml b/src/proto_alpha/lib_protocol/src/script_tc_errors.ml index ade9ef6ec..67dc7ed3b 100644 --- a/src/proto_alpha/lib_protocol/src/script_tc_errors.ml +++ b/src/proto_alpha/lib_protocol/src/script_tc_errors.ml @@ -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 diff --git a/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml b/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml index 60a683440..64ddff35d 100644 --- a/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml +++ b/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml @@ -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