Add 'Error' primitives to 'Rule_Instance' and 'Arg_Project_Type'

This primitives are used to emit error messages about rule instances and
project files.

Author: HugoGGuerrier

lkql_checker/src/gnatcheck-compiler.adb

@@ -1066,7 +1066,7 @@ package body Gnatcheck.Compiler is
          if R_Id = Not_A_Restriction_Id
            and then Special_R_Id = Not_A_Special_Restriction_Id
          then
-            Error
+            Instance.Error
               ("wrong restriction identifier : " & Rest_Name & ", ignored");
             Bad_Rule_Detected := True;
             return;
@@ -1078,7 +1078,7 @@ package body Gnatcheck.Compiler is
            (Lower_Rest_Name, I_Name, Cursor, Success);
          if not Success and then Restriction_To_Instance (Cursor) /= I_Name
          then
-            Error
+            Instance.Error
               ("cannot enable the same restriction in different rule "
                & "instances: "
                & Rest_Name);
@@ -1097,7 +1097,7 @@ package body Gnatcheck.Compiler is
                exit;
 
             else
-               Error
+               Instance.Error
                  ("wrong structure of restriction rule parameter "
                   & Param
                   & ", ignored");
@@ -1111,7 +1111,7 @@ package body Gnatcheck.Compiler is
       if R_Id in All_Boolean_Restrictions then
 
          if Arg_Present then
-            Error
+            Instance.Error
               ("RESTRICTIONS rule parameter: "
                & Param
                & " can not contain expression, ignored");
@@ -1123,7 +1123,7 @@ package body Gnatcheck.Compiler is
       elsif R_Id /= Not_A_Restriction_Id then
 
          if not Arg_Present then
-            Error
+            Instance.Error
               ("RESTRICTIONS rule parameter: "
                & Param
                & " should contain an expression, ignored");
@@ -1150,7 +1150,7 @@ package body Gnatcheck.Compiler is
                         end if;
                      end loop;
 
-                     Error
+                     Instance.Error
                        ("expression for RESTRICTIONS rule parameter: "
                         & Param (First_Idx .. Last_Idx)
                         & " is specified more than once");
@@ -1160,7 +1160,7 @@ package body Gnatcheck.Compiler is
                   Restriction_Setting (R_Id).Param.Append (R_Val'Img);
                exception
                   when Constraint_Error =>
-                     Error
+                     Instance.Error
                        ("wrong restriction parameter expression in "
                         & Param
                         & ", ignored");
@@ -1186,7 +1186,7 @@ package body Gnatcheck.Compiler is
          case Special_R_Id is
             when No_Dependence =>
                if not Arg_Present then
-                  Error
+                  Instance.Error
                     ("Restrictions rule parameter: "
                      & Param
                      & " should contain a unit name, ignored");
@@ -1201,7 +1201,7 @@ package body Gnatcheck.Compiler is
 
             when No_Use_Of_Entity =>
                if not Arg_Present then
-                  Error
+                  Instance.Error
                     ("Restrictions rule parameter: "
                      & Param
                      & " should contain an entity name, ignored");
@@ -1216,7 +1216,7 @@ package body Gnatcheck.Compiler is
 
             when No_Specification_Of_Aspect =>
                if not Arg_Present then
-                  Error
+                  Instance.Error
                     ("Restrictions rule parameter: "
                      & Param
                      & " should contain an aspect name, ignored");
@@ -1357,7 +1357,7 @@ package body Gnatcheck.Compiler is
 
             Style_To_Instance.Insert ([C], Name, Cursor, Success);
             if not Success and then Style_To_Instance (Cursor) /= Name then
-               Error
+               Instance.Error
                  ("cannot enable the same style check in different rule "
                   & "instances: "
                   & C);
@@ -1433,7 +1433,7 @@ package body Gnatcheck.Compiler is
          if Param (J) in 'e' | 's'
            and then (J = Param'First or else Param (J - 1) not in '.' | '_')
          then
-            Error
+            Instance.Error
               ("Warnings rule cannot have "
                & Param (J)
                & " parameter, parameter string "
@@ -1458,7 +1458,7 @@ package body Gnatcheck.Compiler is
 
          Warning_To_Instance.Insert (Param (I .. J), Name, Cursor, Success);
          if not Success and then Warning_To_Instance (Cursor) /= Name then
-            Error
+            Instance.Error
               ("cannot enable the same warning in different rule instances: "
                & Param (I .. J));
             Bad_Rule_Detected := True;

lkql_checker/src/gnatcheck-projects.adb

@@ -144,6 +144,20 @@ package body Gnatcheck.Projects is
       return GPR2.Reporter.Regular;
    end Verbosity;
 
+   -----------
+   -- Error --
+   -----------
+
+   procedure Error (My_Project : Arg_Project_Type; Message : String) is
+   begin
+      if My_Project.Is_Specified then
+         Gnatcheck.Output.Error
+           (Message, Location => Source_Prj (My_Project) & ":1:1");
+      else
+         Gnatcheck.Output.Error (Message);
+      end if;
+   end Error;
+
    -----------------------
    -- Local subprograms --
    -----------------------
@@ -392,7 +406,8 @@ package body Gnatcheck.Projects is
 
    exception
       when E : GPR2.Options.Usage_Error =>
-         Error (Ada.Exceptions.Exception_Message (E));
+         My_Project.Error
+           ("libgpr2 usage error: " & Ada.Exceptions.Exception_Message (E));
    end Get_Sources_From_Project;
 
    ----------------------------
@@ -478,7 +493,7 @@ package body Gnatcheck.Projects is
                 Config       => Conf_Obj)
       then
          if not My_Project.Tree.Has_Runtime_Project then
-            Error ("no runtime information found");
+            My_Project.Error ("no runtime information found");
          end if;
 
          Error ("""" & Get_Aggregated_Project & """ processing failed");
@@ -492,7 +507,8 @@ package body Gnatcheck.Projects is
 
    exception
       when E : GPR2.Options.Usage_Error =>
-         Error ("usage error: " & Ada.Exceptions.Exception_Message (E));
+         My_Project.Error
+           ("libgpr2 usage error: " & Ada.Exceptions.Exception_Message (E));
          raise Parameter_Error;
    end Load_Aggregated_Project;
 
@@ -551,23 +567,15 @@ package body Gnatcheck.Projects is
       end if;
 
       if not My_Project.Tree.Languages.Contains (GPR2.Ada_Language) then
-         Error
-           (""""
-            & String (My_Project.Tree.Root_Project.Path_Name.Simple_Name)
-            & """ has no Ada sources, processing failed");
-
+         My_Project.Error ("project has no Ada sources, processing failed");
          raise Parameter_Error;
 
       elsif not My_Project.Tree.Has_Runtime_Project then
          --  Issue with the configuration of Ada
          for Msg of My_Project.Tree.Configuration.Log_Messages loop
             Print (Msg.Format);
          end loop;
-         Error
-           (""""
-            & String (My_Project.Tree.Root_Project.Path_Name.Simple_Name)
-            & """ processing failed");
-
+         My_Project.Error ("processing failed");
          raise Parameter_Error;
       end if;
 
@@ -604,7 +612,8 @@ package body Gnatcheck.Projects is
 
    exception
       when E : GPR2.Options.Usage_Error =>
-         Error ("usage error: " & Ada.Exceptions.Exception_Message (E));
+         My_Project.Error
+           ("libgpr2 usage error: " & Ada.Exceptions.Exception_Message (E));
          raise Parameter_Error;
    end Load_Tool_Project;
 

lkql_checker/src/gnatcheck-projects.ads

@@ -173,6 +173,9 @@ package Gnatcheck.Projects is
      (My_Project : Arg_Project_Type) return GPR2.Project.View.Object;
    --  Returns access to project view object
 
+   procedure Error (My_Project : Arg_Project_Type; Message : String);
+   --  Emit an error message about this ``My_Project`` project
+
    procedure Store_Project_Source
      (My_Project : in out Arg_Project_Type; Project_File_Name : String);
    --  If Project_File_Name ends with ".gpr", it is taken to be the name of

lkql_checker/src/gnatcheck-rules.adb

@@ -28,7 +28,8 @@ package body Gnatcheck.Rules is
    -- Local helpers --
    -------------------
 
-   function Expand_Env_Variables (Name : String) return String;
+   function Expand_Env_Variables
+     (Name : String; Instance : Rule_Instance'Class) return String;
    --  Assuming that Name is a name of a dictionary file (used as rule
    --  parameter) and that it may contain environment variables, tries
    --  to locate environment variables and to replace them with their values.
@@ -401,7 +402,9 @@ package body Gnatcheck.Rules is
    -- Expand_Env_Variables --
    --------------------------
 
-   function Expand_Env_Variables (Name : String) return String is
+   function Expand_Env_Variables
+     (Name : String; Instance : Rule_Instance'Class) return String
+   is
       Text_Start : Natural := Name'First;
       EV_Start   : Natural := Index (Name, "$");
       EV_End     : Positive;
@@ -423,7 +426,7 @@ package body Gnatcheck.Rules is
          Val : GNAT.OS_Lib.String_Access := Getenv (EV_Name);
       begin
          if Val = null or else Val.all = "" then
-            Error ("environment variable " & EV_Name & " undefined");
+            Instance.Error ("environment variable " & EV_Name & " undefined");
             Free (Val);
             return EV_Name;
          else
@@ -1224,7 +1227,8 @@ package body Gnatcheck.Rules is
    procedure Emit_Wrong_Parameter
      (Instance : Rule_Instance_Access; Param : String) is
    begin
-      Error ("(" & Instance_Name (Instance) & ") wrong parameter: " & Param);
+      Instance.Error
+        ("(" & Instance_Name (Instance) & ") wrong parameter: " & Param);
       Bad_Rule_Detected := True;
    end Emit_Wrong_Parameter;
 
@@ -1234,7 +1238,7 @@ package body Gnatcheck.Rules is
 
    procedure Emit_Required_Parameter (Instance : Rule_Instance_Access) is
    begin
-      Error
+      Instance.Error
         ("(" & Instance_Name (Instance) & ") parameter is required for +R");
       Bad_Rule_Detected := True;
    end Emit_Required_Parameter;
@@ -1245,7 +1249,8 @@ package body Gnatcheck.Rules is
 
    procedure Emit_No_Parameter_Allowed (Instance : Rule_Instance_Access) is
    begin
-      Error ("(" & Instance_Name (Instance) & ") no parameter allowed for -R");
+      Instance.Error
+        ("(" & Instance_Name (Instance) & ") no parameter allowed for -R");
       Bad_Rule_Detected := True;
    end Emit_No_Parameter_Allowed;
 
@@ -1256,7 +1261,7 @@ package body Gnatcheck.Rules is
    procedure Emit_Redefining (Instance : Rule_Instance_Access; Param : String)
    is
    begin
-      Error
+      Instance.Error
         ("redefining at "
          & Defined_Str (To_String (Instance.Defined_At))
          & " parameter"
@@ -1273,8 +1278,8 @@ package body Gnatcheck.Rules is
    procedure Emit_File_Load_Error
      (Instance : Rule_Instance_Access; File_Name : String) is
    begin
-      Error
-        ("(" & Instance_Name (Instance) & "): cannot load file " & File_Name);
+      Instance.Error
+        ("(" & Instance_Name (Instance) & ") cannot load file " & File_Name);
       Bad_Rule_Detected := True;
    end Emit_File_Load_Error;
 
@@ -1287,7 +1292,7 @@ package body Gnatcheck.Rules is
    begin
       --  If there is a provided param display an error
       if Param /= "" then
-         Error
+         Instance.Error
            ("no parameter can be set for rule "
             & Gnatcheck.Rules.Instance_Name (Instance)
             & ", "
@@ -1475,7 +1480,7 @@ package body Gnatcheck.Rules is
          if Rule_Name (Instance) = "name_clashes" then
             if Load_Dictionary
                  (Instance,
-                  Expand_Env_Variables (Param),
+                  Expand_Env_Variables (Param, Instance.all),
                   Tagged_Instance.Param)
             then
                Ada.Strings.Unbounded.Set_Unbounded_String
@@ -1921,7 +1926,8 @@ package body Gnatcheck.Rules is
             if Load_Dictionary
                  (Instance,
                   Expand_Env_Variables
-                    (Norm_Param (Norm_Param'First + 8 .. Norm_Param'Last)),
+                    (Norm_Param (Norm_Param'First + 8 .. Norm_Param'Last),
+                     Instance.all),
                   Tagged_Instance.Exclude)
             then
                Set_Unbounded_Wide_Wide_String
@@ -2216,7 +2222,7 @@ package body Gnatcheck.Rules is
          --  error in the parameter syntax.
          First_Equal := Index (Param, "=");
          if First_Equal = 0 then
-            Error
+            Instance.Error
               ("("
                & Gnatcheck.Rules.Instance_Name (Instance)
                & ") missing = in parameter argument: "
@@ -2253,7 +2259,7 @@ package body Gnatcheck.Rules is
                          (To_Text (Param (First_Equal + 1 .. Param'Last)))));
             else
                --  Else, display an error and disable the instance
-               Error
+               Instance.Error
                  ("("
                   & Gnatcheck.Rules.Instance_Name (Instance)
                   & ") unknown parameter: "
@@ -2386,7 +2392,7 @@ package body Gnatcheck.Rules is
 
       procedure Error is
       begin
-         Gnatcheck.Output.Error
+         Instance.Error
            ("("
             & Instance_Name (Instance)
             & ") wrong parameter: "
@@ -2429,7 +2435,7 @@ package body Gnatcheck.Rules is
         and then Last /= 0
         and then Slice_Count (Create (To_String (Instance.Param), ",")) /= 5
       then
-         Error
+         Instance.Error
            ("("
             & Instance_Name (Instance)
             & ") requires 5 parameters, got: "
@@ -2970,6 +2976,20 @@ package body Gnatcheck.Rules is
       end if;
    end Annotate_Diag;
 
+   -----------
+   -- Error --
+   -----------
+
+   procedure Error (Self : Rule_Instance'Class; Message : String) is
+   begin
+      if Self.Defined_At /= Null_Unbounded_String then
+         Gnatcheck.Output.Error
+           (Message, Location => To_String (Self.Defined_At));
+      else
+         Gnatcheck.Output.Error (Message);
+      end if;
+   end Error;
+
    --  == Overriding operations on rule instances
 
    ------------------------------------
@@ -3044,7 +3064,8 @@ package body Gnatcheck.Rules is
             Param_Value  : constant String :=
               Expect_Literal (Params_Object, "dictionary_file");
             File_Content : constant Unbounded_String :=
-              Load_Dictionary_File (Expand_Env_Variables (Param_Value));
+              Load_Dictionary_File
+                (Expand_Env_Variables (Param_Value, Instance));
          begin
             Params_Object.Unset_Field ("dictionary_file");
             if File_Content /= Null_Unbounded_String then
@@ -3282,7 +3303,8 @@ package body Gnatcheck.Rules is
             Exclude_File : constant String :=
               Expect_Literal (Params_Object, "exclude");
             File_Content : constant Unbounded_String :=
-              Load_Dictionary_File (Expand_Env_Variables (Exclude_File));
+              Load_Dictionary_File
+                (Expand_Env_Variables (Exclude_File, Instance));
          begin
             Params_Object.Unset_Field ("exclude");
             if File_Content /= Null_Unbounded_String then