diff gcc/ada/erroutc.adb @ 145:1830386684a0

gcc-9.2.0
author anatofuz
date Thu, 13 Feb 2020 11:34:05 +0900
parents 84e7813d76e9
children
line wrap: on
line diff
--- a/gcc/ada/erroutc.adb	Thu Oct 25 07:37:49 2018 +0900
+++ b/gcc/ada/erroutc.adb	Thu Feb 13 11:34:05 2020 +0900
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2018, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2019, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -53,9 +53,15 @@
 
    function Matches (S : String; P : String) return Boolean;
    --  Returns true if the String S patches the pattern P, which can contain
-   --  wild card chars (*). The entire pattern must match the entire string.
+   --  wildcard chars (*). The entire pattern must match the entire string.
    --  Case is ignored in the comparison (so X matches x).
 
+   function Sloc_In_Range (Loc, Start, Stop : Source_Ptr) return Boolean;
+   --  Return whether Loc is in the range Start .. Stop, taking instantiation
+   --  locations of Loc into account. This is useful for suppressing warnings
+   --  from generic instantiations by using pragma Warnings around generic
+   --  instances, as needed in GNATprove.
+
    ---------------
    -- Add_Class --
    ---------------
@@ -618,155 +624,145 @@
       Length : Nat;
       --  Maximum total length of lines
 
-      Text  : constant String_Ptr := Errors.Table (E).Text;
+      E_Msg : Error_Msg_Object renames Errors.Table (E);
+      Text  : constant String_Ptr := E_Msg.Text;
       Ptr   : Natural;
       Split : Natural;
       Start : Natural;
+      Tag : constant String := Get_Warning_Tag (E);
+      Txt : String_Ptr;
+      Len : Natural;
 
    begin
-      declare
-         Tag : constant String := Get_Warning_Tag (E);
-         Txt : String_Ptr;
-         Len : Natural;
-
-      begin
-         --  Postfix warning tag to message if needed
+      --  Postfix warning tag to message if needed
 
-         if Tag /= "" and then Warning_Doc_Switch then
-            if Include_Subprogram_In_Messages then
-               Txt :=
-                 new String'
-                   (Subprogram_Name_Ptr (Errors.Table (E).Node) &
-                    ": " & Text.all & ' ' & Tag);
-            else
-               Txt := new String'(Text.all & ' ' & Tag);
-            end if;
-
-         elsif Include_Subprogram_In_Messages
-           and then (Errors.Table (E).Warn or else Errors.Table (E).Style)
-         then
+      if Tag /= "" and then Warning_Doc_Switch then
+         if Include_Subprogram_In_Messages then
             Txt :=
               new String'
-                (Subprogram_Name_Ptr (Errors.Table (E).Node) &
-                 ": " & Text.all);
+                (Subprogram_Name_Ptr (E_Msg.Node) &
+                 ": " & Text.all & ' ' & Tag);
          else
-            Txt := Text;
+            Txt := new String'(Text.all & ' ' & Tag);
          end if;
 
-         --  Deal with warning case
+      elsif Include_Subprogram_In_Messages
+        and then (E_Msg.Warn or else E_Msg.Style)
+      then
+         Txt :=
+           new String'(Subprogram_Name_Ptr (E_Msg.Node) & ": " & Text.all);
+      else
+         Txt := Text;
+      end if;
 
-         if Errors.Table (E).Warn or else Errors.Table (E).Info then
+      --  For info messages, prefix message with "info: "
 
-            --  For info messages, prefix message with "info: "
+      if E_Msg.Info then
+         Txt := new String'("info: " & Txt.all);
+
+      --  Warning treated as error
+
+      elsif E_Msg.Warn_Err then
 
-            if Errors.Table (E).Info then
-               Txt := new String'("info: " & Txt.all);
+      --  We prefix with "error:" rather than warning: and postfix
+      --  [warning-as-error] at the end.
+
+         Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
+         Txt := new String'("error: " & Txt.all & " [warning-as-error]");
+
+      --  Normal warning, prefix with "warning: "
 
-            --  Warning treated as error
+      elsif E_Msg.Warn then
+         Txt := new String'("warning: " & Txt.all);
+
+      --  No prefix needed for style message, "(style)" is there already
 
-            elsif Errors.Table (E).Warn_Err then
+      elsif E_Msg.Style then
+         null;
+
+      --  No prefix needed for check message, severity is there already
+
+      elsif E_Msg.Check then
+         null;
 
-               --  We prefix with "error:" rather than warning: and postfix
-               --  [warning-as-error] at the end.
+      --  All other cases, add "error: " if unique error tag set
+
+      elsif Opt.Unique_Error_Tag then
+         Txt := new String'("error: " & Txt.all);
+      end if;
 
-               Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
-               Txt := new String'("error: " & Txt.all & " [warning-as-error]");
+      --  Set error message line length and length of message
+
+      if Error_Msg_Line_Length = 0 then
+         Length := Nat'Last;
+      else
+         Length := Error_Msg_Line_Length;
+      end if;
 
-            --  Normal case, prefix with "warning: "
+      Max := Integer (Length - Column + 1);
+      Len := Txt'Length;
+
+      --  Here we have to split the message up into multiple lines
+
+      Ptr := 1;
+      loop
+         --  Make sure we do not have ludicrously small line
+
+         Max := Integer'Max (Max, 20);
+
+         --  If remaining text fits, output it respecting LF and we are done
 
-            else
-               Txt := new String'("warning: " & Txt.all);
-            end if;
+         if Len - Ptr < Max then
+            for J in Ptr .. Len loop
+               if Txt (J) = ASCII.LF then
+                  Write_Eol;
+                  Write_Spaces (Offs);
+               else
+                  Write_Char (Txt (J));
+               end if;
+            end loop;
 
-            --  No prefix needed for style message, "(style)" is there already
+            return;
+
+         --  Line does not fit
 
-         elsif Errors.Table (E).Style then
-            null;
+         else
+            Start := Ptr;
+
+            --  First scan forward looking for a hard end of line
 
-            --  No prefix needed for check message, severity is there already
+            for Scan in Ptr .. Ptr + Max - 1 loop
+               if Txt (Scan) = ASCII.LF then
+                  Split := Scan - 1;
+                  Ptr := Scan + 1;
+                  goto Continue;
+               end if;
+            end loop;
 
-         elsif Errors.Table (E).Check then
-            null;
+            --  Otherwise scan backwards looking for a space
 
-            --  All other cases, add "error: " if unique error tag set
+            for Scan in reverse Ptr .. Ptr + Max - 1 loop
+               if Txt (Scan) = ' ' then
+                  Split := Scan - 1;
+                  Ptr := Scan + 1;
+                  goto Continue;
+               end if;
+            end loop;
 
-         elsif Opt.Unique_Error_Tag then
-            Txt := new String'("error: " & Txt.all);
+            --  If we fall through, no space, so split line arbitrarily
+
+            Split := Ptr + Max - 1;
+            Ptr := Split + 1;
          end if;
 
-         --  Set error message line length and length of message
-
-         if Error_Msg_Line_Length = 0 then
-            Length := Nat'Last;
-         else
-            Length := Error_Msg_Line_Length;
+         <<Continue>>
+         if Start <= Split then
+            Write_Line (Txt (Start .. Split));
+            Write_Spaces (Offs);
          end if;
 
          Max := Integer (Length - Column + 1);
-         Len := Txt'Length;
-
-         --  Here we have to split the message up into multiple lines
-
-         Ptr := 1;
-         loop
-            --  Make sure we do not have ludicrously small line
-
-            Max := Integer'Max (Max, 20);
-
-            --  If remaining text fits, output it respecting LF and we are done
-
-            if Len - Ptr < Max then
-               for J in Ptr .. Len loop
-                  if Txt (J) = ASCII.LF then
-                     Write_Eol;
-                     Write_Spaces (Offs);
-                  else
-                     Write_Char (Txt (J));
-                  end if;
-               end loop;
-
-               return;
-
-            --  Line does not fit
-
-            else
-               Start := Ptr;
-
-               --  First scan forward looking for a hard end of line
-
-               for Scan in Ptr .. Ptr + Max - 1 loop
-                  if Txt (Scan) = ASCII.LF then
-                     Split := Scan - 1;
-                     Ptr := Scan + 1;
-                     goto Continue;
-                  end if;
-               end loop;
-
-               --  Otherwise scan backwards looking for a space
-
-               for Scan in reverse Ptr .. Ptr + Max - 1 loop
-                  if Txt (Scan) = ' ' then
-                     Split := Scan - 1;
-                     Ptr := Scan + 1;
-                     goto Continue;
-                  end if;
-               end loop;
-
-               --  If we fall through, no space, so split line arbitrarily
-
-               Split := Ptr + Max - 1;
-               Ptr := Split + 1;
-            end if;
-
-            <<Continue>>
-            if Start <= Split then
-               Write_Line (Txt (Start .. Split));
-               Write_Spaces (Offs);
-            end if;
-
-            Max := Integer (Length - Column + 1);
-         end loop;
-      end;
+      end loop;
    end Output_Msg_Text;
 
    ---------------------
@@ -1588,6 +1584,25 @@
       end if;
    end Set_Warnings_Mode_On;
 
+   -------------------
+   -- Sloc_In_Range --
+   -------------------
+
+   function Sloc_In_Range (Loc, Start, Stop : Source_Ptr) return Boolean is
+      Cur_Loc : Source_Ptr := Loc;
+
+   begin
+      while Cur_Loc /= No_Location loop
+         if Start <= Cur_Loc and then Cur_Loc <= Stop then
+            return True;
+         end if;
+
+         Cur_Loc := Instantiation_Location (Cur_Loc);
+      end loop;
+
+      return False;
+   end Sloc_In_Range;
+
    --------------------------------
    -- Validate_Specific_Warnings --
    --------------------------------
@@ -1652,7 +1667,7 @@
             --  location is in range of a specific non-configuration pragma.
 
             if SWE.Config
-              or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
+              or else Sloc_In_Range (Loc, SWE.Start, SWE.Stop)
             then
                if Matches (Msg.all, SWE.Msg.all)
                  or else Matches (Tag, SWE.Msg.all)
@@ -1691,8 +1706,8 @@
       --  Loop through table of ON/OFF warnings
 
       for J in Warnings.First .. Warnings.Last loop
-         if Warnings.Table (J).Start <= Loc
-           and then Loc <= Warnings.Table (J).Stop
+         if Sloc_In_Range (Loc, Warnings.Table (J).Start,
+                                Warnings.Table (J).Stop)
          then
             return Warnings.Table (J).Reason;
          end if;