@@ -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 --
---------------
@@ -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;
@@ -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)
@@ -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;
@@ -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);
From: Ronan Desplanques <desplanques@adacore.com> This patch fixes a crash when -gnatdJ is enabled and a warning must be emitted about an ineffective pragma Warnings clause. Some modifications are made to the specific warnings machinery so that warnings carry the ID of the pragma node they're about, so the -gnatdJ mechanism can find an appropriate enclosing subprogram. gcc/ada/ * sem_prag.adb (Analyze_Pragma): Adapt call to new signature. * erroutc.ads (Set_Specific_Warning_Off): change signature and update documentation. (Validate_Specific_Warnings): Move ... * errout.adb: ... here and change signature. Also move body of Validate_Specific_Warnings from erroutc.adb. (Finalize): Adapt call. * errout.ads (Set_Specific_Warning_Off): Adapt signature of renaming. * erroutc.adb (Set_Specific_Warning_Off): Adapt signature and body. (Validate_Specific_Warnings): Move to the body of Errout. (Warning_Specifically_Suppressed): Adapt body. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/errout.adb | 50 +++++++++++++++++++++++++++++++++++++- gcc/ada/errout.ads | 2 +- gcc/ada/erroutc.adb | 58 +++++++------------------------------------- gcc/ada/erroutc.ads | 25 +++++++------------ gcc/ada/sem_prag.adb | 2 +- 5 files changed, 69 insertions(+), 68 deletions(-)