[Ada] Implement new pragma Warning_As_Error
Arnaud Charlet
charlet@adacore.com
Tue Feb 25 15:48:00 GMT 2014
This implements a new pragma Warning_As_Error which can be used to
specify that selected warnings are to be treated as errors. See
new documentation in GNAT RM for full details.
The pragma can appear either in a global configuration pragma file
(e.g. gnat.adc), or at the start of a file. Given a global
configuration pragma file containing:
pragma Warning_As_Error ("[-gnatwj]");
which will treat all obsolescent feature warnings as errors, the
following program compiles as shown (compile options here are
@option{-gnatwa.e -gnatld7 -gnatj60}).
1. pragma Warning_As_Error ("*never assigned*");
2. function Warnerr return String is
3. X : Integer;
|
>>> warning(error): variable "X" is never read and
never assigned [-gnatwv]
4. Y : Integer;
|
>>> warning: variable "Y" is assigned but never
read [-gnatwu]
5.
6. begin
7. Y := 0;
8. return %ABC%;
|
>>> warning(error): use of "%" is an obsolescent
feature (RM J.2(4)), use """ instead [-gnatwj]
9. end;
9 lines: No errors, 3 warnings (2 treated as errors)
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-02-25 Robert Dewar <dewar@adacore.com>
* atree.ads (Warnings_Treated_As_Errors): New variable.
* errout.adb (Error_Msg_Internal): Set Warn_Err flag in
error object (Initialize): Initialize Warnings_As_Errors_Count
(Write_Error_Summary): Include count of warnings treated as errors.
* erroutc.adb (Warning_Treated_As_Error): New function.
(Matches): Function moved to outer level of package.
* erroutc.ads (Error_Msg_Object): Add Warn_Err flag.
(Warning_Treated_As_Error): New function.
* gnat_rm.texi: Document pragma Treat_Warning_As_Error.
* opt.adb: Add handling of Warnings_As_Errors_Count[_Config].
* opt.ads (Config_Switches_Type): Add entry for
Warnings_As_Errors_Count.
(Warnings_As_Errors_Count): New variable.
(Warnings_As_Errors): New array.
* par-prag.adb: Add dummy entry for Warning_As_Error.
* sem_prag.adb (Analyze_Pragma): Implement new pragma
Warning_As_Error.
* snames.ads-tmpl: Add entries for Warning_As_Error pragma.
-------------- next part --------------
Index: gnat_rm.texi
===================================================================
--- gnat_rm.texi (revision 208144)
+++ gnat_rm.texi (working copy)
@@ -275,6 +275,7 @@
* Pragma Use_VADS_Size::
* Pragma Validity_Checks::
* Pragma Volatile::
+* Pragma Warning_As_Error::
* Pragma Warnings::
* Pragma Weak_External::
* Pragma Wide_Character_Encoding::
@@ -1109,6 +1110,7 @@
* Pragma Use_VADS_Size::
* Pragma Validity_Checks::
* Pragma Volatile::
+* Pragma Warning_As_Error::
* Pragma Warnings::
* Pragma Weak_External::
* Pragma Wide_Character_Encoding::
@@ -7557,6 +7559,80 @@
implementation of pragma Volatile is upwards compatible with the
implementation in DEC Ada 83.
+@node Pragma Warning_As_Error
+@unnumberedsec Pragma Warning_As_Error
+@findex Warning_As_Error
+@noindent
+Syntax:
+
+@smallexample @c ada
+pragma Warning_As_Error (static_string_EXPRESSION);
+@end smallexample
+
+@noindent
+This configuration pragma allows the programmer to specify a set
+of warnings that will be treated as errors. Any warning which
+matches the pattern given by the pragma argument will be treated
+as an error. This gives much more precise control that -gnatwe
+which treats all warnings as errors.
+
+The pattern may contain asterisks, which match zero or more characters in
+the message. For example, you can use
+@code{pragma Warnings (Off, "*bits of*unused")} to suppress the warning
+message @code{warning: 960 bits of "a" unused}. No other regular
+expression notations are permitted. All characters other than asterisk in
+these three specific cases are treated as literal characters in the match.
+The match is case insensitive, for example XYZ matches xyz.
+
+Another possibility for the static_string_EXPRESSION which works if
+error tags are enabled (@option{-gnatw.e}) is to use the tag string
+preceded by a space,
+as shown in the example below.
+
+The pragma can appear either in a global configuration pragma file
+(e.g. @file{gnat.adc}), or at the start of a file. Given a global
+configuration pragma file containing:
+
+@smallexample @c ada
+pragma Warning_As_Error (" [-gnatwj]");
+@end smallexample
+
+@noindent
+which will treat all obsolescent feature warnings as errors, the
+following program compiles as shown (compile options here are
+@option{-gnatwa.e -gnatld7 -gnatj60}).
+
+@smallexample @c ada
+ 1. pragma Warning_As_Error ("*never assigned*");
+ 2. function Warnerr return String is
+ 3. X : Integer;
+ |
+ >>> warning(error): variable "X" is never read and
+ never assigned [-gnatwv]
+
+ 4. Y : Integer;
+ |
+ >>> warning: variable "Y" is assigned but never
+ read [-gnatwu]
+
+ 5.
+ 6. begin
+ 7. Y := 0;
+ 8. return %ABC%;
+ |
+ >>> warning(error): use of "%" is an obsolescent
+ feature (RM J.2(4)), use """ instead [-gnatwj]
+
+ 9. end;
+
+ 9 lines: No errors, 3 warnings (2 treated as errors)
+@end smallexample
+
+@noindent
+Note that this pragma does not affect the set of warnings issued in
+any way, it merely changes the effect of a matching warning if one
+is produced as a result of other warnings options.
+
@node Pragma Warnings
@unnumberedsec Pragma Warnings
@findex Warnings
@@ -7609,12 +7685,14 @@
User's Guide}. This form can also be used as a configuration pragma.
@noindent
-The warnings controlled by the `-gnatw' switch are generated by the front end
-of the compiler. The `GCC' back end can provide additional warnings and they
-are controlled by the `-W' switch.
-The form with a single static_string_EXPRESSION argument also works for the
-latters, but the string must be a single full `-W' switch in this case.
-The above reference lists a few examples of these additional warnings.
+The warnings controlled by the @option{-gnatw} switch are generated by the
+front end of the compiler. The GCC back end can provide additional warnings
+and they are controlled by the @option{-W} switch. Such warnings can be
+identified by the appearance of a string of the form @code{[-Wxxx]} in the
+message which designates the @option{-Wxxx} switch that controls the message.
+The form with a single static_string_EXPRESSION argument also works for these
+warnings, but the string must be a single full @option{-Wxxx} switch in this
+case. The above reference lists a few examples of these additional warnings.
@noindent
The specified warnings will be in effect until the end of the program
@@ -7638,12 +7716,10 @@
The match is case insensitive, for example XYZ matches xyz.
The above use of patterns to match the message applies only to warning
-messages generated by the front end. This form of the pragma with a
-string argument can also be used to control back end warnings controlled
-by a "-Wxxx" switch. Such warnings can be identified by the appearance
-of a string of the form "[-Wxxx]" in the message which identifies the
-"-W" switch that controls the message. By using the text of the
-"-W" switch in the pragma, such back end warnings can be turned on and off.
+messages generated by the front end. This form of the pragma with a string
+argument can also be used to control warnings provided by the back end and
+mentioned above. By using a single full @option{-Wxxx} switch in the pragma,
+such warnings can be turned on and off.
There are two ways to use the pragma in this form. The OFF form can be used as a
configuration pragma. The effect is to suppress all warnings (if any)
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 208143)
+++ sem_prag.adb (working copy)
@@ -21269,6 +21269,31 @@
-- Volatile is handled by the same circuit as Atomic_Components
+ ----------------------
+ -- Warning_As_Error --
+ ----------------------
+
+ when Pragma_Warning_As_Error =>
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_Valid_Configuration_Pragma;
+
+ if not Is_Static_String_Expression (Arg1) then
+ Error_Pragma_Arg
+ ("argument of pragma% must be static string expression",
+ Arg1);
+
+ -- OK static string expression
+
+ else
+ String_To_Name_Buffer
+ (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
+ Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
+ Warnings_As_Errors (Warnings_As_Errors_Count) :=
+ new String'(Name_Buffer (1 .. Name_Len));
+ end if;
+
--------------
-- Warnings --
--------------
@@ -21481,14 +21506,14 @@
end loop;
end if;
- -- Error if not entity or static string literal case
+ -- Error if not entity or static string expression case
elsif not Is_Static_String_Expression (Arg2) then
Error_Pragma_Arg
("second argument of pragma% must be entity name "
& "or static string expression", Arg2);
- -- String literal case
+ -- Static string expression case
else
String_To_Name_Buffer
@@ -25885,6 +25910,7 @@
Pragma_Validity_Checks => -1,
Pragma_Volatile => 0,
Pragma_Volatile_Components => 0,
+ Pragma_Warning_As_Error => -1,
Pragma_Warnings => -1,
Pragma_Weak_External => -1,
Pragma_Wide_Character_Encoding => 0,
Index: errout.adb
===================================================================
--- errout.adb (revision 208143)
+++ errout.adb (working copy)
@@ -690,6 +690,9 @@
Temp_Msg : Error_Msg_Id;
+ Warn_Err : Boolean;
+ -- Set if warning to be treated as error
+
procedure Handle_Serious_Error;
-- Internal procedure to do all error message handling for a serious
-- error message, other than bumping the error counts and arranging
@@ -940,6 +943,7 @@
Line => Get_Physical_Line_Number (Sptr),
Col => Get_Column_Number (Sptr),
Warn => Is_Warning_Msg,
+ Warn_Err => False, -- reset below
Warn_Chr => Warning_Msg_Char,
Style => Is_Style_Msg,
Serious => Is_Serious_Error,
@@ -948,6 +952,21 @@
Deleted => False));
Cur_Msg := Errors.Last;
+ -- Test if warning to be treated as error
+
+ Warn_Err :=
+ Is_Warning_Msg
+ and then (Warning_Treated_As_Error (Msg_Buffer (1 .. Msglen))
+ or else
+ Warning_Treated_As_Error (Get_Warning_Tag (Cur_Msg)));
+
+ -- Propagate Warn_Err to this message and preceding continuations
+
+ for J in reverse 1 .. Errors.Last loop
+ Errors.Table (J).Warn_Err := Warn_Err;
+ exit when not Errors.Table (J).Msg_Cont;
+ end loop;
+
-- If immediate errors mode set, output error message now. Also output
-- now if the -d1 debug flag is set (so node number message comes out
-- just before actual error message)
@@ -1498,11 +1517,13 @@
Last_Error_Msg := No_Error_Msg;
Serious_Errors_Detected := 0;
Total_Errors_Detected := 0;
+ Warnings_Treated_As_Errors := 0;
Warnings_Detected := 0;
+ Warnings_As_Errors_Count := 0;
Cur_Msg := No_Error_Msg;
List_Pragmas.Init;
- -- Initialize warnings table
+ -- Initialize warnings tables
Warnings.Init;
Specific_Warnings.Init;
@@ -1656,6 +1677,11 @@
end if;
Write_Char (')');
+
+ elsif Warnings_Treated_As_Errors /= 0 then
+ Write_Str (" (");
+ Write_Int (Warnings_Treated_As_Errors);
+ Write_Str (" treated as errors)");
end if;
end if;
Index: par-prag.adb
===================================================================
--- par-prag.adb (revision 208138)
+++ par-prag.adb (working copy)
@@ -1336,6 +1336,7 @@
Pragma_Use_VADS_Size |
Pragma_Volatile |
Pragma_Volatile_Components |
+ Pragma_Warning_As_Error |
Pragma_Weak_External |
Pragma_Validity_Checks =>
null;
Index: atree.ads
===================================================================
--- atree.ads (revision 208088)
+++ atree.ads (working copy)
@@ -315,6 +315,10 @@
-- Number of warnings detected. Initialized to zero at the start of
-- compilation. Initialized for -gnatVa use, see comment above.
+ Warnings_Treated_As_Errors : Nat := 0;
+ -- Number of warnings changed into errors as a result of matching a pattern
+ -- given in a Warning_As_Error configuration pragma.
+
Configurable_Run_Time_Violations : Nat := 0;
-- Count of configurable run time violations so far. This is used to
-- suppress certain cascaded error messages when we know that we may not
Index: opt.adb
===================================================================
--- opt.adb (revision 208067)
+++ opt.adb (working copy)
@@ -66,6 +66,7 @@
SPARK_Mode_Config := SPARK_Mode;
SPARK_Mode_Pragma_Config := SPARK_Mode_Pragma;
Use_VADS_Size_Config := Use_VADS_Size;
+ Warnings_As_Errors_Count_Config := Warnings_As_Errors_Count;
-- Reset the indication that Optimize_Alignment was set locally, since
-- if we had a pragma in the config file, it would set this flag True,
@@ -103,6 +104,7 @@
SPARK_Mode := Save.SPARK_Mode;
SPARK_Mode_Pragma := Save.SPARK_Mode_Pragma;
Use_VADS_Size := Save.Use_VADS_Size;
+ Warnings_As_Errors_Count := Save.Warnings_As_Errors_Count;
-- Update consistently the value of Init_Or_Norm_Scalars. The value of
-- Normalize_Scalars is not saved/restored because after set to True its
@@ -141,6 +143,7 @@
Save.SPARK_Mode := SPARK_Mode;
Save.SPARK_Mode_Pragma := SPARK_Mode_Pragma;
Save.Use_VADS_Size := Use_VADS_Size;
+ Save.Warnings_As_Errors_Count := Warnings_As_Errors_Count;
end Save_Opt_Config_Switches;
-----------------------------
@@ -171,6 +174,9 @@
Use_VADS_Size := False;
Optimize_Alignment_Local := True;
+ -- Note: we do not need to worry about Warnings_As_Errors_Count since
+ -- we do not expect to get any warnings from compiling such a unit.
+
-- For an internal unit, assertions/debug pragmas are off unless this
-- is the main unit and they were explicitly enabled. We also make
-- sure we do not assume that values are necessarily valid and that
@@ -212,6 +218,7 @@
SPARK_Mode := SPARK_Mode_Config;
SPARK_Mode_Pragma := SPARK_Mode_Pragma_Config;
Use_VADS_Size := Use_VADS_Size_Config;
+ Warnings_As_Errors_Count := Warnings_As_Errors_Count_Config;
-- Update consistently the value of Init_Or_Norm_Scalars. The value
-- of Normalize_Scalars is not saved/restored because once set to
Index: opt.ads
===================================================================
--- opt.ads (revision 208140)
+++ opt.ads (working copy)
@@ -1761,6 +1761,10 @@
-- unless we are in GNATprove_Mode, which requires pragma Warnings to
-- be stored for the formal verification backend.
+ Warnings_As_Errors_Count : Natural;
+ -- GNAT
+ -- Number of entries stored in Warnings_As_Errors table
+
Wide_Character_Encoding_Method : WC_Encoding_Method := WCEM_Brackets;
-- GNAT, GNATBIND
-- Method used for encoding wide characters in the source program. See
@@ -1952,6 +1956,10 @@
-- is ignored for internal and predefined units (which are always compiled
-- with the standard Size semantics).
+ Warnings_As_Errors_Count_Config : Natural;
+ -- GNAT
+ -- Count of pattern strings stored from Warning_As_Error pragmas
+
type Config_Switches_Type is private;
-- Type used to save values of the switches set from Config values
@@ -2055,6 +2063,26 @@
-- that this is completely separate from the SPARK restriction defined in
-- GNAT to detect violations of a subset of SPARK 2005 rules.
+ ---------------------------
+ -- Error/Warning Control --
+ ---------------------------
+
+ -- The following array would more reasonably be located in Err_Vars or
+ -- Errour, but but we put them here to deal with licensing issues (we need
+ -- this to have the GPL exception licensing, since these variables and
+ -- subprograms are accessed from units with this licensing).
+
+ Warnings_As_Errors : array (1 .. 10_000) of String_Ptr;
+ -- Table for recording Warning_As_Error pragmas as they are processed.
+ -- It would be nicer to use Table, but there are circular elaboration
+ -- problems if we try to do this, and an attempt to find some other
+ -- appropriately licensed unit to declare this as a Table failed with
+ -- various elaboration circularities. Memory is getting cheap these days!
+
+ --------------------------
+ -- Private Declarations --
+ --------------------------
+
private
-- The following type is used to save and restore settings of switches in
@@ -2089,6 +2117,7 @@
SPARK_Mode : SPARK_Mode_Type;
SPARK_Mode_Pragma : Node_Id;
Use_VADS_Size : Boolean;
+ Warnings_As_Errors_Count : Natural;
end record;
-- The following declarations are for GCC version dependent flags. We do
Index: erroutc.adb
===================================================================
--- erroutc.adb (revision 208143)
+++ erroutc.adb (working copy)
@@ -45,6 +45,15 @@
package body Erroutc is
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ 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.
+ -- Case is ignored in the comparison (so X matches x).
+
---------------
-- Add_Class --
---------------
@@ -104,13 +113,13 @@
N1, N2 : Error_Msg_Id;
procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
- -- Called to delete message Delete, keeping message Keep. Marks
- -- all messages of Delete with deleted flag set to True, and also
- -- makes sure that for the error messages that are retained the
- -- preferred message is the one retained (we prefer the shorter
- -- one in the case where one has an Instance tag). Note that we
- -- always know that Keep has at least as many continuations as
- -- Delete (since we always delete the shorter sequence).
+ -- Called to delete message Delete, keeping message Keep. Marks all
+ -- messages of Delete with deleted flag set to True, and also makes sure
+ -- that for the error messages that are retained the preferred message
+ -- is the one retained (we prefer the shorter one in the case where one
+ -- has an Instance tag). Note that we always know that Keep has at least
+ -- as many continuations as Delete (since we always delete the shorter
+ -- sequence).
----------------
-- Delete_Msg --
@@ -219,7 +228,8 @@
begin
return Total_Errors_Detected /= 0
or else (Warnings_Detected /= 0
- and then Warning_Mode = Treat_As_Error);
+ and then Warning_Mode = Treat_As_Error)
+ or else Warnings_Treated_As_Errors /= 0;
end Compilation_Errors;
------------------
@@ -289,6 +299,89 @@
return Cur_Msg;
end Get_Msg_Id;
+ ---------------------
+ -- Get_Warning_Tag --
+ ---------------------
+
+ function Get_Warning_Tag (Id : Error_Msg_Id) return String is
+ Warn : constant Boolean := Errors.Table (Id).Warn;
+ Warn_Chr : constant Character := Errors.Table (Id).Warn_Chr;
+ begin
+ if Warn and then Warn_Chr /= ' ' then
+ if Warn_Chr = '?' then
+ return " [enabled by default]";
+ elsif Warn_Chr in 'a' .. 'z' then
+ return " [-gnatw" & Warn_Chr & ']';
+ else pragma Assert (Warn_Chr in 'A' .. 'Z');
+ return " [-gnatw." & Fold_Lower (Warn_Chr) & ']';
+ end if;
+ else
+ return "";
+ end if;
+ end Get_Warning_Tag;
+
+ -------------
+ -- Matches --
+ -------------
+
+ function Matches (S : String; P : String) return Boolean is
+ Slast : constant Natural := S'Last;
+ PLast : constant Natural := P'Last;
+
+ SPtr : Natural := S'First;
+ PPtr : Natural := P'First;
+
+ begin
+ -- Loop advancing through characters of string and pattern
+
+ SPtr := S'First;
+ PPtr := P'First;
+ loop
+ -- Return True if pattern is a single asterisk
+
+ if PPtr = PLast and then P (PPtr) = '*' then
+ return True;
+
+ -- Return True if both pattern and string exhausted
+
+ elsif PPtr > PLast and then SPtr > Slast then
+ return True;
+
+ -- Return False, if one exhausted and not the other
+
+ elsif PPtr > PLast or else SPtr > Slast then
+ return False;
+
+ -- Case where pattern starts with asterisk
+
+ elsif P (PPtr) = '*' then
+
+ -- Try all possible starting positions in S for match with the
+ -- remaining characters of the pattern. This is the recursive
+ -- call that implements the scanner backup.
+
+ for J in SPtr .. Slast loop
+ if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+
+ -- Dealt with end of string and *, advance if we have a match
+
+ elsif Fold_Lower (S (SPtr)) = Fold_Lower (P (PPtr)) then
+ SPtr := SPtr + 1;
+ PPtr := PPtr + 1;
+
+ -- If first characters do not match, that's decisive
+
+ else
+ return False;
+ end if;
+ end loop;
+ end Matches;
+
-----------------------
-- Output_Error_Msgs --
-----------------------
@@ -455,32 +548,12 @@
Length : Nat;
-- Maximum total length of lines
- Text : constant String_Ptr := Errors.Table (E).Text;
- Warn : constant Boolean := Errors.Table (E).Warn;
- Warn_Chr : constant Character := Errors.Table (E).Warn_Chr;
- Warn_Tag : String_Ptr;
- Ptr : Natural;
- Split : Natural;
- Start : Natural;
+ Text : constant String_Ptr := Errors.Table (E).Text;
+ Ptr : Natural;
+ Split : Natural;
+ Start : Natural;
begin
- -- Add warning doc tag if needed
-
- if Warn and then Warn_Chr /= ' ' then
- if Warn_Chr = '?' then
- Warn_Tag := new String'(" [enabled by default]");
-
- elsif Warn_Chr in 'a' .. 'z' then
- Warn_Tag := new String'(" [-gnatw" & Warn_Chr & ']');
-
- else pragma Assert (Warn_Chr in 'A' .. 'Z');
- Warn_Tag := new String'(" [-gnatw." & Fold_Lower (Warn_Chr) & ']');
- end if;
-
- else
- Warn_Tag := new String'("");
- end if;
-
-- Set error message line length
if Error_Msg_Line_Length = 0 then
@@ -492,7 +565,7 @@
Max := Integer (Length - Column + 1);
declare
- Txt : constant String := Text.all & Warn_Tag.all;
+ Txt : constant String := Text.all & Get_Warning_Tag (E);
Len : constant Natural := Txt'Length;
begin
@@ -502,8 +575,20 @@
if Len < 6
or else Txt (Txt'First .. Txt'First + 5) /= "info: "
then
- Write_Str ("warning: ");
- Max := Max - 9;
+ -- One more check, if warning is to be treated as error, then
+ -- here is where we deal with that.
+
+ if Errors.Table (E).Warn_Err then
+ Write_Str ("warning(error): ");
+ Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
+ Max := Max - 16;
+
+ -- Normal case
+
+ else
+ Write_Str ("warning: ");
+ Max := Max - 9;
+ end if;
end if;
-- No prefix needed for style message, "(style)" is there already
@@ -1358,75 +1443,6 @@
(Loc : Source_Ptr;
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
- -- wild card chars (*). The entire pattern must match the entire string.
- -- Case is ignored in the comparison (so X matches x).
-
- -------------
- -- Matches --
- -------------
-
- function Matches (S : String; P : String) return Boolean is
- Slast : constant Natural := S'Last;
- PLast : constant Natural := P'Last;
-
- SPtr : Natural := S'First;
- PPtr : Natural := P'First;
-
- begin
- -- Loop advancing through characters of string and pattern
-
- SPtr := S'First;
- PPtr := P'First;
- loop
- -- Return True if pattern is a single asterisk
-
- if PPtr = PLast and then P (PPtr) = '*' then
- return True;
-
- -- Return True if both pattern and string exhausted
-
- elsif PPtr > PLast and then SPtr > Slast then
- return True;
-
- -- Return False, if one exhausted and not the other
-
- elsif PPtr > PLast or else SPtr > Slast then
- return False;
-
- -- Case where pattern starts with asterisk
-
- elsif P (PPtr) = '*' then
-
- -- Try all possible starting positions in S for match with
- -- the remaining characters of the pattern. This is the
- -- recursive call that implements the scanner backup.
-
- for J in SPtr .. Slast loop
- if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then
- return True;
- end if;
- end loop;
-
- return False;
-
- -- Dealt with end of string and *, advance if we have a match
-
- elsif Fold_Lower (S (SPtr)) = Fold_Lower (P (PPtr)) then
- SPtr := SPtr + 1;
- PPtr := PPtr + 1;
-
- -- If first characters do not match, that's decisive
-
- else
- return False;
- end if;
- end loop;
- end Matches;
-
- -- Start of processing for Warning_Specifically_Suppressed
-
begin
-- Loop through specific warning suppression entries
@@ -1452,6 +1468,21 @@
return No_String;
end Warning_Specifically_Suppressed;
+ ------------------------------
+ -- Warning_Treated_As_Error --
+ ------------------------------
+
+ function Warning_Treated_As_Error (Msg : String) return Boolean is
+ begin
+ for J in 1 .. Warnings_As_Errors_Count loop
+ if Matches (Msg, Warnings_As_Errors (J).all) then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+ end Warning_Treated_As_Error;
+
-------------------------
-- Warnings_Suppressed --
-------------------------
Index: erroutc.ads
===================================================================
--- erroutc.ads (revision 208143)
+++ erroutc.ads (working copy)
@@ -195,6 +195,10 @@
Warn : Boolean;
-- True if warning message (i.e. insertion character ? appeared)
+ Warn_Err : Boolean;
+ -- True if this is a warning message which is to be treated as an error
+ -- as a result of a match with a Warning_As_Error pragma.
+
Warn_Chr : Character;
-- Warning character, valid only if Warn is True
-- ' ' -- ? appeared on its own in message
@@ -375,6 +379,10 @@
-- redundant. If so, the message to be deleted and all its continuations
-- are marked with the Deleted flag set to True.
+ function Get_Warning_Tag (Id : Error_Msg_Id) return String;
+ -- Given an error message ID, return tag showing warning message class, or
+ -- the null string if this option is not enabled or this is not a warning.
+
procedure Output_Error_Msgs (E : in out Error_Msg_Id);
-- Output source line, error flag, and text of stored error message and all
-- subsequent messages for the same line and unit. On return E is set to be
@@ -553,6 +561,11 @@
-- the corresponding warning string is returned (or the null string if no
-- Warning argument was present in the pragma).
+ function Warning_Treated_As_Error (Msg : String) return Boolean;
+ -- Returns True if the warning message Msg matches any of the strings
+ -- given by Warning_As_Error pragmas, as stored in the Warnings_As_Errors
+ -- table by Set_Warning_As_Error.
+
type Error_Msg_Proc is
access procedure (Msg : String; Flag_Location : Source_Ptr);
procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc);
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 208142)
+++ snames.ads-tmpl (working copy)
@@ -445,6 +445,7 @@
Name_Unsuppress : constant Name_Id := N + $; -- Ada 05
Name_Use_VADS_Size : constant Name_Id := N + $; -- GNAT
Name_Validity_Checks : constant Name_Id := N + $; -- GNAT
+ Name_Warning_As_Error : constant Name_Id := N + $; -- GNAT
Name_Warnings : constant Name_Id := N + $; -- GNAT
Name_Wide_Character_Encoding : constant Name_Id := N + $; -- GNAT
Last_Configuration_Pragma_Name : constant Name_Id := N + $;
@@ -1790,6 +1791,7 @@
Pragma_Unsuppress,
Pragma_Use_VADS_Size,
Pragma_Validity_Checks,
+ Pragma_Warning_As_Error,
Pragma_Warnings,
Pragma_Wide_Character_Encoding,
More information about the Gcc-patches
mailing list