Add optional location to warning messages

Author: HugoGGuerrier

lkql_checker/src/gnatcheck-compiler.adb

@@ -1252,7 +1252,7 @@ package body Gnatcheck.Compiler is
           | Static_Dispatch_Tables
           | No_Exception_Propagation
       then
-         Warning
+         Instance.Warning
            ("restriction "
             & To_Mixed (R_Id'Img)
             & " ignored - only fully effective during code generation");
@@ -1272,22 +1272,22 @@ package body Gnatcheck.Compiler is
           | No_Entry_Queue
           | No_Reentrancy
       then
-         Warning
+         Instance.Warning
            ("restriction "
             & To_Mixed (R_Id'Img)
             & " ignored - cannot be checked statically");
 
          Restriction_Setting (R_Id).Active := False;
 
       elsif R_Id = No_Recursion then
-         Warning
+         Instance.Warning
            ("restriction No_Recursion ignored (cannot be checked statically), "
             & "use rule Recursive_Subprograms instead");
 
          Restriction_Setting (R_Id).Active := False;
 
       elsif R_Id = Max_Asynchronous_Select_Nesting and then R_Val /= 0 then
-         Warning
+         Instance.Warning
            ("restriction Max_Asynchronous_Select_Nesting ignored - "
             & "cannot be checked statically if parameter is not 0");
          Restriction_Setting (R_Id).Active := False;

lkql_checker/src/gnatcheck-output.adb

@@ -573,16 +573,17 @@ package body Gnatcheck.Output is
    -- Warning --
    -------------
 
-   procedure Warning (Message : String) is
+   procedure Warning (Message : String; Location : String := "") is
    begin
       if Arg.Warnings_As_Errors.Get then
-         Error (Message);
+         Error (Message, Location);
          Error_From_Warning := True;
       else
          Emit_Message
            (Message,
             Tag         => Warning,
-            Tool_Name   => True,
+            Tool_Name   => Location = "",
+            Location    => Location,
             New_Line    => True,
             Log_Message => True);
       end if;

lkql_checker/src/gnatcheck-output.ads

@@ -46,7 +46,7 @@ package Gnatcheck.Output is
    --  ``Location`` is an empty string, otherwise the message is prefixed
    --  by "<location>: error: ".
 
-   procedure Warning (Message : String);
+   procedure Warning (Message : String; Location : String := "");
    --  Sends ``Message`` into stderr, prefixed by "tool_name: warning: ".
 
    procedure Info (Message : String);

lkql_checker/src/gnatcheck-rules-rule_table.adb

@@ -1298,7 +1298,8 @@ package body Gnatcheck.Rules.Rule_Table is
       Output_Rule_File   : constant String :=
         (if Arg.Full_Source_Locations.Get
          then LKQL_Rule_File_Name
-         else Base_Name (LKQL_Rule_File_Name));
+         else Base_Name (LKQL_Rule_File_Name))
+        & ":1:1";
       Rule_Name          : constant String := Instance_Object.Get ("ruleName");
       Instance_Name      : constant String :=
         (if Instance_Object.Has_Field ("instanceName")
@@ -1333,7 +1334,7 @@ package body Gnatcheck.Rules.Rule_Table is
 
       procedure Error_In_Rule_File (Msg : String) is
       begin
-         Error (Msg, Location => Output_Rule_File & ":1:1");
+         Error (Msg, Location => Output_Rule_File);
          Bad_Rule_Detected := True;
       end Error_In_Rule_File;
 

lkql_checker/src/gnatcheck-rules.adb

@@ -2990,6 +2990,20 @@ package body Gnatcheck.Rules is
       end if;
    end Error;
 
+   -------------
+   -- Warning --
+   -------------
+
+   procedure Warning (Self : Rule_Instance'Class; Message : String) is
+   begin
+      if Self.Defined_At /= Null_Unbounded_String then
+         Gnatcheck.Output.Warning
+           (Message, Location => To_String (Self.Defined_At));
+      else
+         Gnatcheck.Output.Warning (Message);
+      end if;
+   end Warning;
+
    --  == Overriding operations on rule instances
 
    ------------------------------------

lkql_checker/src/gnatcheck-rules.ads

@@ -276,6 +276,9 @@ package Gnatcheck.Rules is
    procedure Error (Self : Rule_Instance'Class; Message : String);
    --  Emit an error message about the ``Self`` rule instance
 
+   procedure Warning (Self : Rule_Instance'Class; Message : String);
+   --  Emit a warning message about the ``Self`` rule instance
+
    procedure Free is new
      Ada.Unchecked_Deallocation (Rule_Instance'Class, Rule_Instance_Access);
    --  Free the memory allocated for a rule instance

testsuite/tests/gnatcheck/warnings_as_errors/test.out

@@ -1,12 +1,12 @@
 Without "warnings as errors"
 ============================
 
-gnatcheck: warning: restriction No_Recursion ignored (cannot be checked statically), use rule Recursive_Subprograms instead
+rules.lkql:1:1: warning: restriction No_Recursion ignored (cannot be checked statically), use rule Recursive_Subprograms instead
 main.adb:3:04: rule violation: goto statement
 
 With "warnings as errors"
 =========================
 
-gnatcheck: error: restriction No_Recursion ignored (cannot be checked statically), use rule Recursive_Subprograms instead
+rules.lkql:1:1: error: restriction No_Recursion ignored (cannot be checked statically), use rule Recursive_Subprograms instead
 main.adb:3:04: rule violation: goto statement
 >>>program returned status code 2