mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-26 07:40:26 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2014-02-25  Robert Dewar  <dewar@adacore.com>

	* sem_ch3.adb (Array_Type_Declaration): Check for case of using
	type name as index.
	* lib.ads: Minor reformatting.
	* einfo.ads: Minor reformatting.

2014-02-25  Doug Rupp  <rupp@adacore.com>

	* sem_mech.adb (Set_Mechanisms): For convention Fortran on VMS
	use Short_Descriptor(S) as the argument passing mechanism.

2014-02-25  Eric Botcazou  <ebotcazou@adacore.com>

	* sigtramp-ppcvxw.c (CFI_COMMON_REGS): Also include r0.

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.

From-SVN: r208145
This commit is contained in:
Arnaud Charlet 2014-02-25 16:48:05 +01:00
parent 5acb4d2943
commit 0c3985a955
16 changed files with 390 additions and 127 deletions

37
gcc/ada/ChangeLog

@ -1,3 +1,40 @@
2014-02-25 Robert Dewar <dewar@adacore.com>
* sem_ch3.adb (Array_Type_Declaration): Check for case of using
type name as index.
* lib.ads: Minor reformatting.
* einfo.ads: Minor reformatting.
2014-02-25 Doug Rupp <rupp@adacore.com>
* sem_mech.adb (Set_Mechanisms): For convention Fortran on VMS
use Short_Descriptor(S) as the argument passing mechanism.
2014-02-25 Eric Botcazou <ebotcazou@adacore.com>
* sigtramp-ppcvxw.c (CFI_COMMON_REGS): Also include r0.
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.
2014-02-25 Eric Botcazou <ebotcazou@adacore.com>
* sigtramp.h: Fix minor inaccuracy.

4
gcc/ada/atree.ads

@ -315,6 +315,10 @@ package Atree is
-- 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

8
gcc/ada/einfo.ads

@ -820,10 +820,10 @@ package Einfo is
-- depends on a private type.
-- Designated_Type (synthesized)
-- Applies to access types. Returns the designated type. Differs
-- from Directly_Designated_Type in that if the access type refers
-- to an incomplete type, and the full type is available, then this
-- full type is returned instead of the incomplete type.
-- Applies to access types. Returns the designated type. Differs from
-- Directly_Designated_Type in that if the access type refers to an
-- incomplete type, and the full type is available, then this full type
-- is returned instead of the incomplete type.
-- Digits_Value (Uint17)
-- Defined in floating point types and subtypes and decimal types and

28
gcc/ada/errout.adb

@ -690,6 +690,9 @@ package body Errout is
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 @@ package body Errout is
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 @@ package body Errout is
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 @@ package body Errout is
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 @@ package body Errout is
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;

239
gcc/ada/erroutc.adb

@ -45,6 +45,15 @@ with Uintp; use Uintp;
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 @@ package body Erroutc is
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 @@ package body Erroutc is
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 @@ package body Erroutc is
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 @@ package body Erroutc is
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 @@ package body Erroutc is
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 @@ package body Erroutc is
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 @@ package body Erroutc is
(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 @@ package body Erroutc is
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 --
-------------------------

13
gcc/ada/erroutc.ads

@ -195,6 +195,10 @@ package Erroutc is
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 @@ package Erroutc is
-- 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 @@ package Erroutc is
-- 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);

100
gcc/ada/gnat_rm.texi

@ -275,6 +275,7 @@ Implementation Defined Pragmas
* 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 @@ consideration, the use of these pragmas should be minimized.
* 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 @@ in some Ada 83 compilers, including DEC Ada 83. The Ada 95 / Ada 2005
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 @@ full details see @ref{Warning Message Control,,, gnat_ugn, @value{EDITION}
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 @@ these three specific cases are treated as literal characters in the match.
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)

2
gcc/ada/lib.ads

@ -308,7 +308,7 @@ package Lib is
-- from running (i.e. fatal error during parsing stops semantics,
-- fatal error during semantics stops code generation). Note that
-- currently, errors of any kind cause Fatal_Error to be set, but
-- eventually perhaps only errors labeled as Fatal_Errors should be
-- eventually perhaps only errors labeled as fatal errors should be
-- this severe if we decide to try Sem on sources with minor errors.
-- Generate_Code

7
gcc/ada/opt.adb

@ -66,6 +66,7 @@ package body Opt is
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 @@ package body Opt is
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 @@ package body Opt is
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 @@ package body Opt is
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 @@ package body Opt is
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

29
gcc/ada/opt.ads

@ -1761,6 +1761,10 @@ package Opt is
-- 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 @@ package Opt is
-- 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 @@ package Opt is
-- 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 @@ private
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

1
gcc/ada/par-prag.adb

@ -1336,6 +1336,7 @@ begin
Pragma_Use_VADS_Size |
Pragma_Volatile |
Pragma_Volatile_Components |
Pragma_Warning_As_Error |
Pragma_Weak_External |
Pragma_Validity_Checks =>
null;

10
gcc/ada/sem_ch3.adb

@ -5007,6 +5007,16 @@ package body Sem_Ch3 is
while Present (Index) loop
Analyze (Index);
-- Test for odd case of trying to index a type by the type itself
if Is_Entity_Name (Index) and then Entity (Index) = T then
Error_Msg_N ("type& cannot be indexed by itself", Index);
Set_Entity (Index, Standard_Boolean);
Set_Etype (Index, Standard_Boolean);
end if;
-- Check SPARK restriction requiring a subtype mark
if not Nkind_In (Index, N_Identifier, N_Expanded_Name) then
Check_SPARK_Restriction ("subtype mark required", Index);
end if;

6
gcc/ada/sem_mech.adb

@ -462,8 +462,8 @@ package body Sem_Mech is
when Convention_Fortran =>
-- In OpenVMS, pass a character of array of character
-- value using Descriptor(S).
-- In OpenVMS, pass character and string types using
-- Short_Descriptor(S)
if OpenVMS_On_Target
and then (Root_Type (Typ) = Standard_Character
@ -473,7 +473,7 @@ package body Sem_Mech is
Root_Type (Component_Type (Typ)) =
Standard_Character))
then
Set_Mechanism (Formal, By_Descriptor_S);
Set_Mechanism (Formal, By_Short_Descriptor_S);
-- Access types are passed by default (presumably this
-- will mean they are passed by copy)

30
gcc/ada/sem_prag.adb

@ -21269,6 +21269,31 @@ package body Sem_Prag is
-- 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 @@ package body Sem_Prag is
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 @@ package body Sem_Prag is
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,

1
gcc/ada/sigtramp-ppcvxw.c

@ -186,6 +186,7 @@ CR(".cfi_def_cfa " S(CFA_REG) ", 0")
#define CFI_COMMON_REGS \
CR("# CFI for common registers\n") \
TCR(COMMON_CFI(GR(0))) \
TCR(COMMON_CFI(GR(1))) \
TCR(COMMON_CFI(GR(2))) \
TCR(COMMON_CFI(GR(3))) \

2
gcc/ada/snames.ads-tmpl

@ -445,6 +445,7 @@ package Snames is
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 @@ package Snames is
Pragma_Unsuppress,
Pragma_Use_VADS_Size,
Pragma_Validity_Checks,
Pragma_Warning_As_Error,
Pragma_Warnings,
Pragma_Wide_Character_Encoding,