Enhance the 'identifier_prefixes' rule to handle prefix exclusivity

Before this patch, prefix exclusivity violations were reported with the
same message as the one used when an identifier doesn't start with the
required prefix.
With this patch, exclusivity violations are now reported with a more
understandable message.

Author: HugoGGuerrier

lkql_checker/share/lkql/identifier_prefixes.lkql

@@ -183,10 +183,9 @@ fun identifier_prefixes(
     |"       Exc_2   : exception;                      --  FLAG
     |"    end Foo;
     {
-        val str_prefix = " does not start with ";
-
         fun check_exclusive(
-            str,
+            name,
+            expected_prefix,
             type_exclusive=true,
             concurrent_exclusive=true,
             access_exclusive=true,
@@ -196,26 +195,75 @@ fun identifier_prefixes(
             exception_exclusive=true,
             enum_exclusive=true
         ) =
-            exclusive
-            and (
-                (type_exclusive and str.starts_with(type))
-                or (concurrent_exclusive and str.starts_with(concurrent))
-                or (access_exclusive and str.starts_with(access))
-                or (class_access_exclusive and str.starts_with(class_access))
-                or (subprogram_access_exclusive and str.starts_with(subprogram_access))
-                or (constant_exclusive and str.starts_with(constant))
-                or (exception_exclusive and str.starts_with(exception))
-                or (enum_exclusive and str.starts_with(enum))
-            );
+            |" If the ``exclusive`` rule's parameter is ``true``, this function
+            |" checks whether ``str`` starts with one of the provided prefixes and
+            |" returns a diagnostic string if so. Else it return unit.
+            |" Use ``xxx_exclusive`` parameters to exempt checking on a precise
+            |" prefix.
+            if exclusive
+            then [
+                name.text & " is not " & s[3] & " but starts with " & s[2]
+                for s in [
+                    (concurrent_exclusive, concurrent, "a concurrent"),
+                    (class_access_exclusive, class_access, "an access-to-class"),
+                    (subprogram_access_exclusive, subprogram_access, "an access-to-subprogram"),
+                    (access_exclusive, access, "an access"),
+                    (type_exclusive, type, "a type"),
+                    (constant_exclusive, constant, "a constant"),
+                    (exception_exclusive, exception, "an exception"),
+                    (enum_exclusive, enum, "an enumeration")
+                ]
+                if (
+                    s[1]
+                    and name.f_name.text.starts_with(s[2])
+                    and not expected_prefix.starts_with(s[2])
+                )
+            ]?[1]
+            else ();
 
-        fun check_enum(str) =
+        fun check_prefix_and_exclusive(
+            name,
+            expected_prefix,
+            prefix_kind,
+            check_previous_part_on=null,
+            type_exclusive=true,
+            concurrent_exclusive=true,
+            access_exclusive=true,
+            class_access_exclusive=true,
+            subprogram_access_exclusive=true,
+            constant_exclusive=true,
+            exception_exclusive=true,
+            enum_exclusive=true
+        ) =
             if (
-                (enum != "-" and not str.starts_with(enum))
-                or check_exclusive(str, enum_exclusive=false)
+                if check_previous_part_on is not null
+                then check_previous_part_on.p_previous_part() is (null | IncompleteTypeDecl)
+            ) then (
+                if expected_prefix != "-" and not name.f_name.text.starts_with(expected_prefix)
+                then name.text & " does not start with " & prefix_kind & " prefix " & expected_prefix
+                else check_exclusive(
+                    name,
+                    expected_prefix,
+                    type_exclusive,
+                    concurrent_exclusive,
+                    access_exclusive,
+                    class_access_exclusive,
+                    subprogram_access_exclusive,
+                    constant_exclusive,
+                    exception_exclusive,
+                    enum_exclusive
+                )
             )
-            then str_prefix & "enumeration prefix " & enum
             else ();
 
+        fun check_enum(name) =
+            check_prefix_and_exclusive(
+                name,
+                enum,
+                "enumeration",
+                enum_exclusive=false
+            );
+
         @memoized
         fun get_derived(t) = {
             |" Return the element from derived corresponding to t, if any, or ""
@@ -225,7 +273,7 @@ fun identifier_prefixes(
             if not res then "" else res[res.length]
         };
 
-        fun check_prefix(name) =
+        fun check_name(name) =
             |" Given a DefiningName, check that it is validating all expressed
             |" prefix constraints. Returns a string containing the message
             |" explaining the constraint violation if the defining name is
@@ -237,14 +285,13 @@ fun identifier_prefixes(
               when p is not SingleTaskTypeDecl
                and concurrent != "-"
             =>
-                if (
-                    p.p_previous_part() is (null | IncompleteTypeDecl) and (
-                        not name.f_name.text.starts_with(concurrent)
-                        or check_exclusive(name.f_name.text, concurrent_exclusive=false)
-                    )
+                check_prefix_and_exclusive(
+                    name,
+                    concurrent,
+                    "concurrent",
+                    check_previous_part_on=p,
+                    concurrent_exclusive=false
                 )
-                then str_prefix & "concurrent prefix " & concurrent
-                else ()
 
             # 'Class access
             | (
@@ -254,14 +301,13 @@ fun identifier_prefixes(
                 )
             ) when class_access != "-"
             =>
-                if (
-                    p.p_previous_part() is (null | IncompleteTypeDecl) and (
-                        not name.f_name.text.starts_with(class_access)
-                        or check_exclusive(name.f_name.text, class_access_exclusive=false)
-                    )
+                check_prefix_and_exclusive(
+                    name,
+                    class_access,
+                    "access-to-class",
+                    check_previous_part_on=p,
+                    class_access_exclusive=false
                 )
-                then str_prefix & "access-to-class prefix " & class_access
-                else ()
 
             # Subprogram access
             | (
@@ -271,14 +317,13 @@ fun identifier_prefixes(
                 )
             ) when subprogram_access != "-"
             =>
-                if (
-                    p.p_previous_part() is (null | IncompleteTypeDecl) and (
-                        not name.f_name.text.starts_with(subprogram_access)
-                        or check_exclusive(name.f_name.text, subprogram_access_exclusive=false)
-                    )
+                check_prefix_and_exclusive(
+                    name,
+                    subprogram_access,
+                    "access-to-subprogram",
+                    check_previous_part_on=p,
+                    subprogram_access_exclusive=false
                 )
-                then str_prefix & "access-to-subprogram prefix " & subprogram_access
-                else ()
 
             # Other access types
             | (
@@ -288,22 +333,18 @@ fun identifier_prefixes(
                 )
             ) when access != "-"
             =>
-                if (
-                    p.p_previous_part() is (null | IncompleteTypeDecl) and (
-                        not name.f_name.text.starts_with(access)
-                        or check_exclusive(
-                            name.f_name.text,
-                            access_exclusive=false,
-                            # If both an Access prefix and a Type prefix are
-                            # set and the type prefix is a prefix of the access
-                            # prefix, we don't want to flag this access because
-                            # it broke the exclusivity of the type prefix.
-                            type_exclusive=false
-                        )
-                    )
+                check_prefix_and_exclusive(
+                    name,
+                    access,
+                    "access",
+                    check_previous_part_on=p,
+                    # If both an Access prefix and a Type prefix are set and the
+                    # type prefix is a prefix of the access prefix, we don't
+                    # want to flag this access because it broke the exclusivity
+                    # of the type prefix.
+                    access_exclusive=false,
+                    type_exclusive=false
                 )
-                then str_prefix & "access prefix " & access
-                else ()
 
             # (Sub)Types derived from `derived`
             | p@(TypeDecl(f_type_def: DerivedTypeDef) | SubtypeDecl)
@@ -312,14 +353,14 @@ fun identifier_prefixes(
                    when get_derived(t) != ""
             => {
                 val derived_res = get_derived(p.p_canonical_type().p_base_type());
-                if (
-                    p.p_previous_part() is (null | IncompleteTypeDecl) and (
-                        derived_res != ""
-                        and not name.f_name.text.starts_with(derived_res.split(":")[2])
-                    )
+                if derived_res != ""
+                then check_prefix_and_exclusive(
+                    name,
+                    derived_res.split(":")[2],
+                    "derived",
+                    check_previous_part_on=p
                 )
-                then str_prefix & "derived prefix " & derived_res.split(":")[2]
-                else ()
+                else check_exclusive(name, "")
             }
 
             # Exclude IncompleteTypeDecl
@@ -329,17 +370,16 @@ fun identifier_prefixes(
             | p@BaseTypeDecl
               when p is not SingleTaskTypeDecl
             =>
-                if (
-                    p.p_previous_part() is (null | IncompleteTypeDecl) and (
-                        (type != "-" and not name.f_name.text.starts_with(type))
-                        or check_exclusive(name.f_name.text, type_exclusive=false)
-                    )
+                check_prefix_and_exclusive(
+                    name,
+                    type,
+                    "subtype",
+                    check_previous_part_on=p,
+                    type_exclusive=false
                 )
-                then str_prefix & "subtype prefix " & type
-                else ()
 
             # Enums
-            | EnumLiteralDecl => check_enum(name.f_name.text)
+            | EnumLiteralDecl => check_enum(name)
 
             # Look one level up for remaining cases
             | p => match p.parent
@@ -348,50 +388,45 @@ fun identifier_prefixes(
                     ObjectDecl(p_is_constant_object(): true)
                     | NumberDecl
                 ) =>
-                    if (
-                        name.p_previous_part() is null and (
-                            (constant != "-" and not name.f_name.text.starts_with(constant))
-                            or check_exclusive(name.f_name.text, constant_exclusive=false)
-                        )
+                    check_prefix_and_exclusive(
+                        name,
+                        constant,
+                        "constant",
+                        check_previous_part_on=name,
+                        constant_exclusive=false
                     )
-                    then str_prefix & "constant prefix " & constant
-                    else ()
-
 
                 # Function renaming an enum literal
                 | r@SubpRenamingDecl
                   when r.f_renames?.f_renamed_object?.p_referenced_decl?() is EnumLiteralDecl
                 =>
-                    check_enum(name.f_name.text)
+                    check_enum(name)
 
                 # Exceptions
                 | ExceptionDecl =>
-                    if (
-                        (exception != "-" and not name.f_name.text.starts_with(exception))
-                        or check_exclusive(name.f_name.text, exception_exclusive=false)
+                    check_prefix_and_exclusive(
+                        name,
+                        exception,
+                        "exception",
+                        exception_exclusive=false
                     )
-                    then str_prefix & "exception prefix " & exception
-                    else ()
 
                 # Avoid checking declaration completions
                 | p@(BodyNode | SubpRenamingDecl | ObjectDecl) => {
                     val n = if p is ObjectDecl then name else p;
-                    if n.p_previous_part() is null and check_exclusive(name.f_name.text)
-                    then " does not have an exclusive prefix"
+                    if n.p_previous_part() is (null | IncompleteTypeDecl)
+                    then check_exclusive(name, "")
                     else ()
                 }
 
                 # All other cases, check the exclusivity
-                | * =>
-                    if check_exclusive(name.f_name.text)
-                    then " does not have an exclusive prefix"
-                    else ();
+                | * => check_exclusive(name, "");
 
         # Iterate over all defining names and check prefixes for each
         [
-            {message: s[1].text & s[2], loc: s[1]}
+            {message: s[2], loc: s[1]}
             for s in [
-                (n, check_prefix(n))
+                (n, check_name(n))
                 for n in from unit.root select DefiningName
             ]
             if s[2] != ()

lkql_checker/src/gnatcheck-rules.adb

@@ -1038,7 +1038,10 @@ package body Gnatcheck.Rules is
 
    function Id_Prefix_Param_From_Diag (Diag : String) return String is
    begin
-      if Index (Diag, "task") /= 0 or else Index (Diag, "protected") /= 0 then
+      if Index (Diag, "but starts with") /= 0 then
+         return "exclusive";
+      elsif Index (Diag, "task") /= 0 or else Index (Diag, "protected") /= 0
+      then
          return "concurrent";
       elsif Index (Diag, "access-to-class") /= 0 then
          return "class_access";
@@ -1056,8 +1059,6 @@ package body Gnatcheck.Rules is
          return "access";
       elsif Index (Diag, "subtype") /= 0 then
          return "type";
-      elsif Index (Diag, "exclusive") /= 0 then
-         return "exclusive";
       else
          return "";
       end if;

testsuite/tests/checks/identifier_prefixes/prefix.ads

@@ -1,7 +1,3 @@
---  +RIdentifier_Prefixes:
---  Type=Type_,Constant=Const_,Exception=X_,Enum=E_,Derived=Prefix.Root:Root_,
---  Class_Access=CA_
-
 package Prefix is
    --  type
    type Root;                                 --  NOFLAG
@@ -40,6 +36,7 @@ package Prefix is
    --  derived type
    type Root_1 is new Root;
    type Root2 is new Root;                   --  FLAG
+   type Root_1 is new Integer;               --  FLAG
 
    --  derived type via subtype
    subtype Type_Sub1 is Root;                --  NOFLAG
@@ -48,22 +45,26 @@ package Prefix is
    type Root4 is new Type_Sub2;              --  FLAG
 
    --  concurrent type
-   task type Type_Task is                    --  NOFLAG
+   task type Type_Conc_Task is               --  NOFLAG
       entry E;
    end Type_Task;
 
    task type My_Task is                      --  FLAG
       entry E;
    end My_Task;
 
-   protected type Type_Protected is          --  NOFLAG
+   protected type Type_Conc_Protected is     --  NOFLAG
       entry E;
    end Type_Protected;
 
    protected type My_Protected is            --  FLAG
       entry E;
    end My_Protected;
 
+   type Type_Conc_Rec is null record;        --  FLAG
+   type Type_Conc_Der is new Integer;        --  FLAG
+
+   Const_Or_Node : Integer := 1;             --  FLAG
 private
    type Priv is new Integer;                 --  NOFLAG: completion
    Private_Const : constant Priv := 0;       --  NOFLAG: completion