This is an internal change to allow retrieval of the Reason argument
for a given message suppressed by Warnings (Off). No functional effect.
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-20 Robert Dewar <de...@adacore.com>
* errout.adb (Set_Warnings_Mode_Off): Add Reason argument.
(Set_Specific_Warning_Off): Add Reason argument.
* errout.ads (Set_Warnings_Mode_Off): Add Reason argument.
(Set_Specific_Warning_Off): Add Reason argument.
* erroutc.adb (Warnings_Entry): Add Reason field
(Specific_Warning_Entry): Add Reason field.
(Warnings_Suppressed): return String_Id for Reason.
(Warning_Specifically_Suppressed): return String_Id for Reason.
* erroutc.ads (Warnings_Entry): Add Reason field.
(Specific_Warning_Entry): Add Reason field.
(Set_Specific_Warning_Off): Add Reason argument.
(Set_Warnings_Mode_Off): Add Reason argument.
(Warnings_Suppressed): return String_Id for Reason.
(Warning_Specifically_Suppressed): return String_Id for Reason.
* errutil.adb (Warnings_Suppressed): returns String_Id for Reason
(Warning_Specifically_Suppressed): returns String_Id for Reason
* gnat_rm.texi: Document that Warning parameter is string literal
or a concatenation of string literals.
* par-prag.adb: New handling for Reason argument.
* sem_prag.adb (Analyze_Pragma, case Warning): New handling
for Reason argument.
* sem_util.ads, sem_util.adb (Get_Reason_String): New procedure.
* sem_warn.ads (Warnings_Off_Entry): Add reason field.
* stringt.adb: Set Null_String_Id.
* stringt.ads (Null_String_Id): New constant.
Index: gnat_rm.texi
===================================================================
--- gnat_rm.texi (revision 207905)
+++ gnat_rm.texi (working copy)
@@ -7381,7 +7381,7 @@
pragma Warnings (static_string_EXPRESSION [,REASON]);
pragma Warnings (On | Off, static_string_EXPRESSION [,REASON]);
-REASON ::= Reason => static_string_EXPRESSION
+REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
@end smallexample
@noindent
Index: stringt.adb
===================================================================
--- stringt.adb (revision 207879)
+++ stringt.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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- --
@@ -472,4 +472,12 @@
end if;
end Write_String_Table_Entry;
+-- Setup the null string
+
+pragma Warnings (Off); -- kill strange warning from code below ???
+
+begin
+ Start_String;
+ Null_String_Id := End_String;
+
end Stringt;
Index: stringt.ads
===================================================================
--- stringt.ads (revision 207879)
+++ stringt.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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- --
@@ -48,6 +48,9 @@
-- value for two identical strings stored separately and also cannot count on
-- the two Id values being different.
+ Null_String_Id : String_Id;
+ -- Gets set to a null string with length zero
+
--------------------------------------
-- String Table Access Subprograms --
--------------------------------------
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 207942)
+++ sem_prag.adb (working copy)
@@ -20815,14 +20815,17 @@
-- REASON ::= Reason => Static_String_Expression
- when Pragma_Warnings => Warnings : begin
+ when Pragma_Warnings => Warnings : declare
+ Reason : String_Id;
+
+ begin
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
-- See if last argument is labeled Reason. If so, make sure we
- -- have a static string expression, but otherwise just ignore
- -- the REASON argument by decreasing Num_Args by 1 (all the
- -- remaining tests look only at the first Num_Args arguments).
+ -- have a static string expression, and acquire the REASON string.
+ -- Then remove the REASON argument by decreasing Num_Args by one;
+ -- Remaining processing looks only at first Num_Args arguments).
declare
Last_Arg : constant Node_Id :=
@@ -20831,12 +20834,19 @@
if Nkind (Last_Arg) = N_Pragma_Argument_Association
and then Chars (Last_Arg) = Name_Reason
then
- Check_Arg_Is_Static_Expression (Last_Arg, Standard_String);
+ Start_String;
+ Get_Reason_String (Get_Pragma_Arg (Last_Arg));
+ Reason := End_String;
Arg_Count := Arg_Count - 1;
-- Not allowed in compiler units (bootstrap issues)
Check_Compiler_Unit (N);
+
+ -- No REASON string, set null string as reason
+
+ else
+ Reason := Null_String_Id;
end if;
end;
@@ -20986,7 +20996,7 @@
and then Warn_On_Warnings_Off
and then not In_Instance
then
- Warnings_Off_Pragmas.Append ((N, E));
+ Warnings_Off_Pragmas.Append ((N, E, Reason));
end if;
if Is_Enumeration_Type (E) then
@@ -21040,7 +21050,7 @@
if Chars (Argx) = Name_Off then
Set_Specific_Warning_Off
- (Loc, Name_Buffer (1 .. Name_Len),
+ (Loc, Name_Buffer (1 .. Name_Len), Reason,
Config => Is_Configuration_Pragma,
Used => Inside_A_Generic or else In_Instance);
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 207942)
+++ sem_util.adb (working copy)
@@ -6767,6 +6767,30 @@
return Get_Pragma_Id (Pragma_Name (N));
end Get_Pragma_Id;
+ -----------------------
+ -- Get_Reason_String --
+ -----------------------
+
+ procedure Get_Reason_String (N : Node_Id) is
+ begin
+ if Nkind (N) = N_String_Literal then
+ Store_String_Chars (Strval (N));
+
+ elsif Nkind (N) = N_Op_Concat then
+ Get_Reason_String (Left_Opnd (N));
+ Get_Reason_String (Right_Opnd (N));
+
+ -- If not of required form, error
+
+ else
+ Error_Msg_N
+ ("Reason for pragma Warnings has wrong form", N);
+ Error_Msg_N
+ ("\must be string literal or concatenation of string literals", N);
+ return;
+ end if;
+ end Get_Reason_String;
+
---------------------------
-- Get_Referenced_Object --
---------------------------
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 207904)
+++ sem_util.ads (working copy)
@@ -851,6 +851,13 @@
pragma Inline (Get_Pragma_Id);
-- Obtains the Pragma_Id from the Chars field of Pragma_Identifier (N)
+ procedure Get_Reason_String (N : Node_Id);
+ -- Recursive routine to analyze reason argument for pragma Warnings. The
+ -- value of the reason argument is appended to the current string using
+ -- Store_String_Chars. The reason argument is expected to be a string
+ -- literal or concatenation of string literals. An error is given for
+ -- any other form.
+
function Get_Referenced_Object (N : Node_Id) return Node_Id;
-- Given a node, return the renamed object if the node represents a renamed
-- object, otherwise return the node unchanged. The node may represent an
Index: errout.adb
===================================================================
--- errout.adb (revision 207879)
+++ errout.adb (working copy)
@@ -332,7 +332,9 @@
-- that style checks are not considered warning messages for this
-- purpose.
- if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then
+ if Is_Warning_Msg
+ and then Warnings_Suppressed (Orig_Loc) /= No_String
+ then
return;
-- For style messages, check too many messages so far
@@ -774,7 +776,10 @@
-- Immediate return if warning message and warnings are suppressed
- if Warnings_Suppressed (Optr) or else Warnings_Suppressed (Sptr) then
+ if Warnings_Suppressed (Optr) /= No_String
+ or else
+ Warnings_Suppressed (Sptr) /= No_String
+ then
Cur_Msg := No_Error_Msg;
return;
end if;
@@ -1321,10 +1326,11 @@
begin
if (CE.Warn and not CE.Deleted)
- and then
- (Warning_Specifically_Suppressed (CE.Sptr, CE.Text)
- or else
- Warning_Specifically_Suppressed (CE.Optr, CE.Text))
+ and then (Warning_Specifically_Suppressed (CE.Sptr, CE.Text) /=
+ No_String
+ or else
+ Warning_Specifically_Suppressed (CE.Optr, CE.Text) /=
+ No_String)
then
Delete_Warning (Cur);
Index: errout.ads
===================================================================
--- errout.ads (revision 207879)
+++ errout.ads (working copy)
@@ -806,10 +806,11 @@
-- ignored. A call with To=False restores the default treatment in which
-- error calls are treated as usual (and as described in this spec).
- procedure Set_Warnings_Mode_Off (Loc : Source_Ptr)
+ procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id)
renames Erroutc.Set_Warnings_Mode_Off;
-- Called in response to a pragma Warnings (Off) to record the source
- -- location from which warnings are to be turned off.
+ -- location from which warnings are to be turned off. Reason is the
+ -- Reason from the pragma, or the null string if none is given.
procedure Set_Warnings_Mode_On (Loc : Source_Ptr)
renames Erroutc.Set_Warnings_Mode_On;
@@ -819,14 +820,20 @@
procedure Set_Specific_Warning_Off
(Loc : Source_Ptr;
Msg : String;
+ Reason : String_Id;
Config : Boolean;
Used : Boolean := False)
renames Erroutc.Set_Specific_Warning_Off;
-- This is called in response to the two argument form of pragma Warnings
- -- where the first argument is OFF, and the second argument is the prefix
- -- of 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.
+ -- 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 has the effect of suppressing a warning.
procedure Set_Specific_Warning_On
(Loc : Source_Ptr;
Index: par-prag.adb
===================================================================
--- par-prag.adb (revision 207879)
+++ par-prag.adb (working copy)
@@ -1018,10 +1018,10 @@
-- Warnings (GNAT) --
---------------------
- -- pragma Warnings (On | Off);
- -- pragma Warnings (On | Off, LOCAL_NAME);
- -- pragma Warnings (static_string_EXPRESSION);
- -- pragma Warnings (On | Off, static_string_EXPRESSION);
+ -- pragma Warnings (On | Off [,REASON]);
+ -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
+ -- pragma Warnings (static_string_EXPRESSION [,REASON]);
+ -- pragma Warnings (On | Off, static_string_EXPRESSION [,REASON]);
-- The one argument ON/OFF case is processed by the parser, since it may
-- control parser warnings as well as semantic warnings, and in any case
@@ -1042,12 +1042,33 @@
declare
Argx : constant Node_Id := Expression (Arg1);
+
+ function Get_Reason return String_Id;
+ -- Analyzes Reason argument and returns corresponding String_Id
+ -- value, or null if there is no Reason argument, or if the
+ -- argument is not of the required form.
+
+ ----------------
+ -- Get_Reason --
+ ----------------
+
+ function Get_Reason return String_Id is
+ begin
+ if Arg_Count = 1 then
+ return Null_String_Id;
+ else
+ Start_String;
+ Get_Reason_String (Expression (Arg2));
+ return End_String;
+ end if;
+ end Get_Reason;
+
begin
if Nkind (Argx) = N_Identifier then
if Chars (Argx) = Name_On then
Set_Warnings_Mode_On (Pragma_Sloc);
elsif Chars (Argx) = Name_Off then
- Set_Warnings_Mode_Off (Pragma_Sloc);
+ Set_Warnings_Mode_Off (Pragma_Sloc, Get_Reason);
end if;
end if;
end;
Index: errutil.adb
===================================================================
--- errutil.adb (revision 207879)
+++ errutil.adb (working copy)
@@ -193,7 +193,7 @@
-- Immediate return if warning message and warnings are suppressed.
-- Note that style messages are not warnings for this purpose.
- if Is_Warning_Msg and then Warnings_Suppressed (Sptr) then
+ if Is_Warning_Msg and then Warnings_Suppressed (Sptr) /= No_String then
Cur_Msg := No_Error_Msg;
return;
end if;
Index: sem_warn.ads
===================================================================
--- sem_warn.ads (revision 207879)
+++ sem_warn.ads (working copy)
@@ -39,10 +39,13 @@
type Warnings_Off_Entry is record
N : Node_Id;
- -- A pragma Warnings (Off, ent) node
+ -- A pragma Warnings (Off, ent [,Reason]) node
E : Entity_Id;
-- The entity involved
+
+ R : String_Id;
+ -- Warning reason if present, or null if not (not currently used)
end record;
-- An entry is made in the following table for any valid Pragma Warnings
Index: erroutc.adb
===================================================================
--- erroutc.adb (revision 207879)
+++ erroutc.adb (working copy)
@@ -39,6 +39,7 @@
with Output; use Output;
with Sinput; use Sinput;
with Snames; use Snames;
+with Stringt; use Stringt;
with Targparm; use Targparm;
with Uintp; use Uintp;
@@ -1110,6 +1111,7 @@
procedure Set_Specific_Warning_Off
(Loc : Source_Ptr;
Msg : String;
+ Reason : String_Id;
Config : Boolean;
Used : Boolean := False)
is
@@ -1118,6 +1120,7 @@
((Start => Loc,
Msg => new String'(Msg),
Stop => Source_Last (Current_Source_File),
+ Reason => Reason,
Open => True,
Used => Used,
Config => Config));
@@ -1163,7 +1166,7 @@
-- Set_Warnings_Mode_Off --
---------------------------
- procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is
+ procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id) is
begin
-- Don't bother with entries from instantiation copies, since we will
-- already have a copy in the template, which is what matters.
@@ -1197,10 +1200,10 @@
-- source file. This ending point will be adjusted by a subsequent
-- corresponding pragma Warnings (On).
- Warnings.Increment_Last;
- Warnings.Table (Warnings.Last).Start := Loc;
- Warnings.Table (Warnings.Last).Stop :=
- Source_Last (Current_Source_File);
+ Warnings.Append
+ ((Start => Loc,
+ Stop => Source_Last (Current_Source_File),
+ Reason => Reason));
end Set_Warnings_Mode_Off;
--------------------------
@@ -1342,7 +1345,7 @@
function Warning_Specifically_Suppressed
(Loc : Source_Ptr;
- Msg : String_Ptr) return Boolean
+ Msg : String_Ptr) return String_Id
is
function Matches (S : String; P : String) return Boolean;
-- Returns true if the String S patches the pattern P, which can contain
@@ -1429,36 +1432,36 @@
then
if Matches (Msg.all, SWE.Msg.all) then
SWE.Used := True;
- return True;
+ return SWE.Reason;
end if;
end if;
end;
end loop;
- return False;
+ return No_String;
end Warning_Specifically_Suppressed;
-------------------------
-- Warnings_Suppressed --
-------------------------
- function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
+ function Warnings_Suppressed (Loc : Source_Ptr) return String_Id is
begin
- if Warning_Mode = Suppress then
- return True;
- end if;
-
-- 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
then
- return True;
+ return Warnings.Table (J).Reason;
end if;
end loop;
- return False;
+ if Warning_Mode = Suppress then
+ return Null_String_Id;
+ else
+ return No_String;
+ end if;
end Warnings_Suppressed;
end Erroutc;
Index: erroutc.ads
===================================================================
--- erroutc.ads (revision 207879)
+++ erroutc.ads (working copy)
@@ -267,9 +267,13 @@
-- values in this table always reference the original template, not an
-- instantiation copy, in the generic case.
+ -- Reason is the reason from the pragma Warnings (Off,..) or the null
+ -- string if no reason parameter is given.
+
type Warnings_Entry is record
- Start : Source_Ptr;
- Stop : Source_Ptr;
+ Start : Source_Ptr;
+ Stop : Source_Ptr;
+ Reason : String_Id;
end record;
package Warnings is new Table.Table (
@@ -282,7 +286,7 @@
-- The second table is used for the specific forms of the pragma, where
-- the first argument is ON or OFF, and the second parameter is a string
- -- which is the entire message to suppress, or a prefix of it.
+ -- which is the pattern to match for suppressing a warning.
type Specific_Warning_Entry is record
Start : Source_Ptr;
@@ -290,6 +294,9 @@
-- Starting and ending source pointers for the range. These are always
-- from the same source file.
+ Reason : String_Id;
+ -- Reason string from pragma Warnings, or null string if none
+
Msg : String_Ptr;
-- Message from pragma Warnings (Off, string)
@@ -466,6 +473,7 @@
procedure Set_Specific_Warning_Off
(Loc : Source_Ptr;
Msg : String;
+ Reason : String_Id;
Config : Boolean;
Used : Boolean := False);
-- This is called in response to the two argument form of pragma Warnings
@@ -473,10 +481,11 @@
-- 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). 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
- -- has the effect of suppressing a warning.
+ -- 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 has the effect of suppressing a warning.
procedure Set_Specific_Warning_On
(Loc : Source_Ptr;
@@ -489,9 +498,10 @@
-- string from the pragma. Err is set to True on return to report the error
-- of no matching Warnings Off pragma preceding this one.
- procedure Set_Warnings_Mode_Off (Loc : Source_Ptr);
+ procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id);
-- Called in response to a pragma Warnings (Off) to record the source
- -- location from which warnings are to be turned off.
+ -- location from which warnings are to be turned off. Reason is the
+ -- Reason from the pragma, or the null string if none is given.
procedure Set_Warnings_Mode_On (Loc : Source_Ptr);
-- Called in response to a pragma Warnings (On) to record the source
@@ -518,18 +528,24 @@
-- Note that the call has no effect for continuation messages (those whose
-- first character is '\'), and all variables are left unchanged.
- function Warnings_Suppressed (Loc : Source_Ptr) return Boolean;
+ function Warnings_Suppressed (Loc : Source_Ptr) return String_Id;
-- Determines if given location is covered by a warnings off suppression
-- range in the warnings table (or is suppressed by compilation option,
-- which generates a warning range for the whole source file). This routine
- -- only deals with the general ON/OFF case, not specific warnings. True
- -- is also returned if warnings are globally suppressed.
+ -- only deals with the general ON/OFF case, not specific warnings. The
+ -- returned result is No_String if warnings are not suppressed. If warnings
+ -- are suppressed for the given location, then then corresponding Reason
+ -- parameter from the pragma is returned (or the null string if no Reason
+ -- parameter was present).
function Warning_Specifically_Suppressed
(Loc : Source_Ptr;
- Msg : String_Ptr) return Boolean;
+ Msg : String_Ptr) return String_Id;
-- Determines if given message to be posted at given location is suppressed
-- by specific ON/OFF Warnings pragmas specifying this particular message.
+ -- If the warning is not suppressed then No_String is returned, otherwise
+ -- the corresponding warning string is returned (or the null string if no
+ -- Warning argument was present in the pragma).
type Error_Msg_Proc is
access procedure (Msg : String; Flag_Location : Source_Ptr);
