diff options
| -rw-r--r-- | gcc/ada/errout.adb | 50 | ||||
| -rw-r--r-- | gcc/ada/errout.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/erroutc.adb | 58 | ||||
| -rw-r--r-- | gcc/ada/erroutc.ads | 25 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 2 |
5 files changed, 69 insertions, 68 deletions
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index c4761bd..4622290 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -213,6 +213,10 @@ package body Errout is -- should have 'Class appended to its name (see Add_Class procedure), and -- is otherwise unchanged. + procedure Validate_Specific_Warnings; + -- Checks that specific warnings are consistent (for non-configuration + -- case, properly closed, and used). + function Warn_Insertion return String; -- This is called for warning messages only (so Warning_Msg_Char is set) -- and returns a corresponding string to use at the beginning of generated @@ -1745,7 +1749,7 @@ package body Errout is -- do this on the last call, after all possible warnings are posted. if Last_Call then - Validate_Specific_Warnings (Error_Msg'Access); + Validate_Specific_Warnings; end if; end Finalize; @@ -2001,6 +2005,50 @@ package body Errout is -- True if S starts with Size_For end Is_Size_Too_Small_Message; + -------------------------------- + -- Validate_Specific_Warnings -- + -------------------------------- + + procedure Validate_Specific_Warnings is + begin + if not Warnsw.Warn_On_Warnings_Off then + return; + end if; + + for J in Specific_Warnings.First .. Specific_Warnings.Last loop + declare + SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J); + + begin + if not SWE.Config then + + -- Warn for unmatched Warnings (Off, ...) + + if SWE.Open then + Error_Msg_N + ("?.w?pragma Warnings Off with no matching Warnings On", + SWE.Start); + + -- Warn for ineffective Warnings (Off, ..) + + elsif not SWE.Used + + -- Do not issue this warning for -Wxxx messages since the + -- back-end doesn't report the information. Note that there + -- is always an asterisk at the start of every message. + + and then not + (SWE.Msg'Length > 3 and then SWE.Msg (2 .. 3) = "-W") + then + Error_Msg_N + ("?.w?no warning suppressed by this pragma", + SWE.Start); + end if; + end if; + end; + end loop; + end Validate_Specific_Warnings; + --------------- -- Last_Node -- --------------- diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 5a7764a..089da86 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -896,7 +896,7 @@ package Errout is -- location from which warnings are to be turned back on. procedure Set_Specific_Warning_Off - (Loc : Source_Ptr; + (Node : Node_Id; Msg : String; Reason : String_Id; Config : Boolean; diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 125cbf8..96d8d12 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -38,6 +38,7 @@ with Fname; use Fname; with Namet; use Namet; with Opt; use Opt; with Output; use Output; +with Sinfo.Nodes; with Sinput; use Sinput; with Snames; use Snames; with Stringt; use Stringt; @@ -1650,15 +1651,16 @@ package body Erroutc is ------------------------------ procedure Set_Specific_Warning_Off - (Loc : Source_Ptr; + (Node : Node_Id; Msg : String; Reason : String_Id; Config : Boolean; Used : Boolean := False) is + Loc : constant Source_Ptr := Sinfo.Nodes.Sloc (Node); begin Specific_Warnings.Append - ((Start => Loc, + ((Start => Node, Msg => new String'(Msg), Stop => Source_Last (Get_Source_File_Index (Loc)), Reason => Reason, @@ -1680,12 +1682,13 @@ package body Erroutc is for J in 1 .. Specific_Warnings.Last loop declare SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J); + Start_Loc : constant Source_Ptr := Sinfo.Nodes.Sloc (SWE.Start); begin if Msg = SWE.Msg.all - and then Loc > SWE.Start + and then Loc > Start_Loc and then SWE.Open - and then Get_Source_File_Index (SWE.Start) = + and then Get_Source_File_Index (Start_Loc) = Get_Source_File_Index (Loc) then SWE.Stop := Loc; @@ -1801,49 +1804,6 @@ package body Erroutc is return False; end Sloc_In_Range; - -------------------------------- - -- Validate_Specific_Warnings -- - -------------------------------- - - procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is - begin - if not Warn_On_Warnings_Off then - return; - end if; - - for J in Specific_Warnings.First .. Specific_Warnings.Last loop - declare - SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J); - - begin - if not SWE.Config then - - -- Warn for unmatched Warnings (Off, ...) - - if SWE.Open then - Eproc.all - ("?.w?pragma Warnings Off with no matching Warnings On", - SWE.Start); - - -- Warn for ineffective Warnings (Off, ..) - - elsif not SWE.Used - - -- Do not issue this warning for -Wxxx messages since the - -- back-end doesn't report the information. Note that there - -- is always an asterisk at the start of every message. - - and then not - (SWE.Msg'Length > 3 and then SWE.Msg (2 .. 3) = "-W") - then - Eproc.all - ("?.w?no warning suppressed by this pragma", SWE.Start); - end if; - end if; - end; - end loop; - end Validate_Specific_Warnings; - ------------------------------------- -- Warning_Specifically_Suppressed -- ------------------------------------- @@ -1859,13 +1819,13 @@ package body Erroutc is for J in Specific_Warnings.First .. Specific_Warnings.Last loop declare SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J); - + Start_Loc : constant Source_Ptr := Sinfo.Nodes.Sloc (SWE.Start); begin -- Pragma applies if it is a configuration pragma, or if the -- location is in range of a specific non-configuration pragma. if SWE.Config - or else Sloc_In_Range (Loc, SWE.Start, SWE.Stop) + or else Sloc_In_Range (Loc, Start_Loc, SWE.Stop) then if Matches (Msg.all, SWE.Msg.all) or else Matches (Tag, SWE.Msg.all) diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 9463109..250461f 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -347,7 +347,7 @@ package Erroutc is -- which is the pattern to match for suppressing a warning. type Specific_Warning_Entry is record - Start : Source_Ptr; + Start : Node_Id; Stop : Source_Ptr; -- Starting and ending source pointers for the range. These are always -- from the same source file. @@ -651,7 +651,7 @@ package Erroutc is -- last non-deleted message. procedure Set_Specific_Warning_Off - (Loc : Source_Ptr; + (Node : Node_Id; Msg : String; Reason : String_Id; Config : Boolean; @@ -659,13 +659,13 @@ package Erroutc is -- This is called in response to the two argument form of pragma Warnings -- where the first argument is OFF, and the second argument is a string -- which identifies a specific warning to be suppressed. The first argument - -- is the start of the suppression range, and the second argument is the - -- string from the pragma. Loc is the location of the pragma (which is the - -- start of the range to suppress). Reason is the reason string from the - -- pragma, or the null string if no reason is given. Config is True for the - -- configuration pragma case (where there is no requirement for a matching - -- OFF pragma). Used is set True to disable the check that the warning - -- actually has the effect of suppressing a warning. + -- is the corresponding N_Pragma node, and the second argument is the + -- string from the pragma. Sloc (Node) is the start of the range to + -- suppress. Reason is the reason string from the pragma, or the null + -- string if no reason is given. Config is True for the configuration + -- pragma case (where there is no requirement for a matching OFF pragma). + -- Used is set True to disable the check that the warning actually has the + -- effect of suppressing a warning. procedure Set_Specific_Warning_On (Loc : Source_Ptr; @@ -717,11 +717,4 @@ package Erroutc is -- given by Warning_As_Error pragmas, as stored in the Warnings_As_Errors -- table. - type Error_Msg_Proc is - access procedure (Msg : String; Flag_Location : Source_Ptr); - procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc); - -- Checks that specific warnings are consistent (for non-configuration - -- case, properly closed, and used). The argument is a pointer to the - -- Error_Msg procedure to be called if any inconsistencies are detected. - end Erroutc; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index d7acd46..dfc415d 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -27014,7 +27014,7 @@ package body Sem_Prag is begin if Chars (Argx) = Name_Off then Set_Specific_Warning_Off - (Loc, Message, Reason, + (N, Message, Reason, Config => Is_Configuration_Pragma, Used => Inside_A_Generic or else In_Instance); |