mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 13:41:18 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2014-02-20  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch5.adb (Analyze_Iterator_Specification): Initialize
	properly the cursor type for subsequent volatile testing in SPARK
	mode, when domain is a formal container with an Iterabe aspect.

2014-02-20  Robert Dewar  <dewar@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.

From-SVN: r207943
This commit is contained in:
Arnaud Charlet 2014-02-20 14:42:58 +01:00
parent e449429213
commit 0c7e0c3254
15 changed files with 200 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
gcc/ada/ChangeLog
View File

@ -1,3 +1,37 @@
2014-02-20 Ed Schonberg <schonberg@adacore.com>
* sem_ch5.adb (Analyze_Iterator_Specification): Initialize
properly the cursor type for subsequent volatile testing in SPARK
mode, when domain is a formal container with an Iterabe aspect.
2014-02-20 Robert Dewar <dewar@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.
2014-02-20 Robert Dewar <dewar@adacore.com>
* einfo.ads: Minor comment addition: Etype of package is

18
gcc/ada/errout.adb
View File

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

19
gcc/ada/errout.ads
View File

@ -806,10 +806,11 @@ package Errout is
-- 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 @@ package Errout is
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;

33
gcc/ada/erroutc.adb
View File

@ -39,6 +39,7 @@ with Opt; use Opt;
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 @@ package body Erroutc is
procedure Set_Specific_Warning_Off
(Loc : Source_Ptr;
Msg : String;
Reason : String_Id;
Config : Boolean;
Used : Boolean := False)
is
@ -1118,6 +1120,7 @@ package body Erroutc is
((Start => Loc,
Msg => new String'(Msg),
Stop => Source_Last (Current_Source_File),
Reason => Reason,
Open => True,
Used => Used,
Config => Config));
@ -1163,7 +1166,7 @@ package body Erroutc is
-- 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 @@ package body Erroutc is
-- 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 @@ package body Erroutc is
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 @@ package body Erroutc is
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;

42
gcc/ada/erroutc.ads
View File

@ -267,9 +267,13 @@ package Erroutc is
-- 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 @@ package Erroutc is
-- 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 @@ package Erroutc is
-- 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 @@ package Erroutc is
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 @@ package Erroutc is
-- 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 @@ package Erroutc is
-- 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 @@ package Erroutc is
-- 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);

2
gcc/ada/errutil.adb
View File

@ -193,7 +193,7 @@ package body Errutil is
-- 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;

2
gcc/ada/gnat_rm.texi
View File

@ -7381,7 +7381,7 @@ pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
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

31
gcc/ada/par-prag.adb
View File

@ -1018,10 +1018,10 @@ begin
-- 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 @@ begin
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;

1
gcc/ada/sem_ch5.adb
View File

@ -1931,6 +1931,7 @@ package body Sem_Ch5 is
Set_Etype (Def_Id,
Get_Cursor_Type
(Parent (Find_Value_Of_Aspect (Typ, Aspect_Iterable)), Typ));
Ent := Etype (Def_Id);
else
Ent := First_Entity (Scope (Typ));

24
gcc/ada/sem_prag.adb
View File

@ -20815,14 +20815,17 @@ package body Sem_Prag is
-- 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 @@ package body Sem_Prag is
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 @@ package body Sem_Prag is
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 @@ package body Sem_Prag is
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);

24
gcc/ada/sem_util.adb
View File

@ -6767,6 +6767,30 @@ package body Sem_Util is
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 --
---------------------------

7
gcc/ada/sem_util.ads
View File

@ -851,6 +851,13 @@ package Sem_Util is
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

5
gcc/ada/sem_warn.ads
View File

@ -39,10 +39,13 @@ package Sem_Warn is
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

10
gcc/ada/stringt.adb
View File

@ -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 @@ package body Stringt is
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;

5
gcc/ada/stringt.ads
View File

@ -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 @@ package Stringt is
-- 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 --
--------------------------------------