mirrors/gcc
0
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2024-12-29 22:15:03 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2013-02-06  Gary Dismukes  <dismukes@adacore.com>

	* sem_ch6.adb (Check_For_Primitive_Subprogram): Test for
	the special case of a user-defined equality that overrides
	the predefined equality of a nonderived type declared in a
	declarative part.
	* sem_util.adb (Collect_Primitive_Operations): Add test for
	Is_Primitive when looping over the subprograms following a type,
	to catch the case of primitives such as a user-defined equality,
	which otherwise won't be found when the type is not a derived
	type and is declared in a declarative part.

2013-02-06  Vincent Celier  <celier@adacore.com>

	* prj-conf.adb (Check_Target): Always return True when Target
	is empty (Get_Or_Create_Configuration_File.Get_Project_Target):
	New procedure to get the value of attribute Target in the main
	project.
	(Get_Or_Create_Configuration_File.Do_Autoconf): No
	need to get the value of attribute Target in the main project.
	(Get_Or_Create_Configuration_File): Call Get_Project_Target and
	use the target fom this call.

2013-02-06  Eric Botcazou  <ebotcazou@adacore.com>

	* erroutc.adb (Validate_Specific_Warning): Do not issue the
	warning about an ineffective Pragma Warnings for -Wxxx warnings.
	* sem_prag.adb (Analyze_Pragma) <Warnings>: Accept -Wxxx warnings.
	* gnat_rm.texi (Pragma Warnings): Document coordination with
	warnings of the GCC back-end.

From-SVN: r195786
This commit is contained in:
Arnaud Charlet 2013-02-06 11:00:38 +01:00
parent 2ae395d6c2
commit 1aee1fb38d
7 changed files with 188 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
gcc/ada/ChangeLog
View File

@ -1,3 +1,34 @@
2013-02-06 Gary Dismukes <dismukes@adacore.com>
* sem_ch6.adb (Check_For_Primitive_Subprogram): Test for
the special case of a user-defined equality that overrides
the predefined equality of a nonderived type declared in a
declarative part.
* sem_util.adb (Collect_Primitive_Operations): Add test for
Is_Primitive when looping over the subprograms following a type,
to catch the case of primitives such as a user-defined equality,
which otherwise won't be found when the type is not a derived
type and is declared in a declarative part.
2013-02-06 Vincent Celier <celier@adacore.com>
* prj-conf.adb (Check_Target): Always return True when Target
is empty (Get_Or_Create_Configuration_File.Get_Project_Target):
New procedure to get the value of attribute Target in the main
project.
(Get_Or_Create_Configuration_File.Do_Autoconf): No
need to get the value of attribute Target in the main project.
(Get_Or_Create_Configuration_File): Call Get_Project_Target and
use the target fom this call.
2013-02-06 Eric Botcazou <ebotcazou@adacore.com>
* erroutc.adb (Validate_Specific_Warning): Do not issue the
warning about an ineffective Pragma Warnings for -Wxxx warnings.
* sem_prag.adb (Analyze_Pragma) <Warnings>: Accept -Wxxx warnings.
* gnat_rm.texi (Pragma Warnings): Document coordination with
warnings of the GCC back-end.
2013-02-06 Javier Miranda <miranda@adacore.com> 2013-02-06 Javier Miranda <miranda@adacore.com>
* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Do not build the body * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Do not build the body

11
gcc/ada/erroutc.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -1282,7 +1282,14 @@ package body Erroutc is
Eproc.all Eproc.all
("?pragma Warnings Off with no matching Warnings On", ("?pragma Warnings Off with no matching Warnings On",
SWE.Start); SWE.Start);
elsif not SWE.Used then
-- Do not issue this warning for -Wxxx messages since the
-- back-end doesn't report the information.
elsif not SWE.Used
and then not (SWE.Msg'Length > 2
and then SWE.Msg (1 .. 2) = "-W")
then
Eproc.all Eproc.all
("?no warning suppressed by this pragma", SWE.Start); ("?no warning suppressed by this pragma", SWE.Start);
end if; end if;

14
gcc/ada/gnat_rm.texi
View File

@ -6153,6 +6153,14 @@ the list of warnings switches supported. For
full details see @ref{Warning Message Control,,, gnat_ugn, @value{EDITION} full details see @ref{Warning Message Control,,, gnat_ugn, @value{EDITION}
User's Guide}. User's Guide}.
@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.
@noindent @noindent
The specified warnings will be in effect until the end of the program The specified warnings will be in effect until the end of the program
or another pragma Warnings is encountered. The effect of the pragma is or another pragma Warnings is encountered. The effect of the pragma is
@ -6173,6 +6181,12 @@ message @code{warning: 960 bits of "a" unused}. No other regular
expression notations are permitted. All characters other than asterisk in expression notations are permitted. All characters other than asterisk in
these three specific cases are treated as literal characters in the match. these three specific cases are treated as literal characters in the match.
@noindent
The fourth form also works for the additional warnings of the `GCC' back end,
but the string must again be a single full `-W' switch in this case. Note that
the message issued for these warnings explicitly lists the full `-W' switch
they are associated with.
There are two ways to use the pragma in this form. The OFF form can be used as a 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) configuration pragma. The effect is to suppress all warnings (if any)
that match the pattern string throughout the compilation. that match the pattern string throughout the compilation.

111
gcc/ada/prj-conf.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2006-2012, Free Software Foundation, Inc. -- -- Copyright (C) 2006-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -565,12 +565,11 @@ package body Prj.Conf is
Tgt_Name := Variable.Value; Tgt_Name := Variable.Value;
end if; end if;
if Target = "" then OK :=
OK := Autoconf_Specified or else Tgt_Name = No_Name; Target = ""
else or else
OK := Tgt_Name /= No_Name (Tgt_Name /= No_Name
and then Target = Get_Name_String (Tgt_Name); and then Target = Get_Name_String (Tgt_Name));
end if;
if not OK then if not OK then
if Autoconf_Specified then if Autoconf_Specified then
@ -625,6 +624,8 @@ package body Prj.Conf is
-- The configuration project file name. May be modified if there are -- The configuration project file name. May be modified if there are
-- switches --config= in the Builder package of the main project. -- switches --config= in the Builder package of the main project.
Selected_Target : String_Access := new String'(Target_Name);
function Default_File_Name return String; function Default_File_Name return String;
-- Return the name of the default config file that should be tested -- Return the name of the default config file that should be tested
@ -635,6 +636,10 @@ package body Prj.Conf is
procedure Check_Builder_Switches; procedure Check_Builder_Switches;
-- Check for switches --config and --RTS in package Builder -- Check for switches --config and --RTS in package Builder
procedure Get_Project_Target;
-- Target_Name is empty, get the specifiedtarget in the project file,
-- if any.
function Get_Config_Switches return Argument_List_Access; function Get_Config_Switches return Argument_List_Access;
-- Return the --config switches to use for gprconfig -- Return the --config switches to use for gprconfig
@ -766,6 +771,47 @@ package body Prj.Conf is
end if; end if;
end Check_Builder_Switches; end Check_Builder_Switches;
------------------------
-- Get_Project_Target --
------------------------
procedure Get_Project_Target is
begin
if Selected_Target'Length = 0 then
-- Check if attribute Target is specified in the main
-- project, or in a project it extends. If it is, use this
-- target to invoke gprconfig.
declare
Variable : Variable_Value;
Proj : Project_Id;
Tgt_Name : Name_Id := No_Name;
begin
Proj := Project;
Project_Loop :
while Proj /= No_Project loop
Variable :=
Value_Of (Name_Target, Proj.Decl.Attributes, Shared);
if Variable /= Nil_Variable_Value
and then not Variable.Default
and then Variable.Value /= No_Name
then
Tgt_Name := Variable.Value;
exit Project_Loop;
end if;
Proj := Proj.Extends;
end loop Project_Loop;
if Tgt_Name /= No_Name then
Selected_Target := new String'(Get_Name_String (Tgt_Name));
end if;
end;
end if;
end Get_Project_Target;
----------------------- -----------------------
-- Default_File_Name -- -- Default_File_Name --
----------------------- -----------------------
@ -775,13 +821,14 @@ package body Prj.Conf is
Tmp : String_Access; Tmp : String_Access;
begin begin
if Target_Name /= "" then if Selected_Target'Length /= 0 then
if Ada_RTS /= "" then if Ada_RTS /= "" then
return return
Target_Name & '-' & Ada_RTS & Config_Project_File_Extension; Selected_Target.all & '-' &
Ada_RTS & Config_Project_File_Extension;
else else
return return
Target_Name & Config_Project_File_Extension; Selected_Target.all & Config_Project_File_Extension;
end if; end if;
elsif Ada_RTS /= "" then elsif Ada_RTS /= "" then
@ -972,51 +1019,17 @@ package body Prj.Conf is
if Normalized_Hostname = "" then if Normalized_Hostname = "" then
Arg_Last := 3; Arg_Last := 3;
else else
if Target_Name = "" then if Selected_Target'Length = 0 then
if At_Least_One_Compiler_Command then
-- Check if attribute Target is specified in the main
-- project, or in a project it extends. If it is, use this
-- target to invoke gprconfig.
declare
Variable : Variable_Value;
Proj : Project_Id;
Tgt_Name : Name_Id := No_Name;
begin
Proj := Project;
Project_Loop :
while Proj /= No_Project loop
Variable :=
Value_Of (Name_Target, Proj.Decl.Attributes, Shared);
if Variable /= Nil_Variable_Value
and then not Variable.Default
and then Variable.Value /= No_Name
then
Tgt_Name := Variable.Value;
exit Project_Loop;
end if;
Proj := Proj.Extends;
end loop Project_Loop;
if Tgt_Name /= No_Name then
Args (4) :=
new String'("--target=" &
Get_Name_String (Tgt_Name));
elsif At_Least_One_Compiler_Command then
Args (4) := new String'("--target=all"); Args (4) := new String'("--target=all");
else else
Args (4) := Args (4) :=
new String'("--target=" & Normalized_Hostname); new String'("--target=" & Normalized_Hostname);
end if; end if;
end;
else else
Args (4) := new String'("--target=" & Target_Name); Args (4) := new String'("--target=" & Selected_Target.all);
end if; end if;
Arg_Last := 4; Arg_Last := 4;
@ -1348,6 +1361,7 @@ package body Prj.Conf is
Free (Config_File_Path); Free (Config_File_Path);
Config := No_Project; Config := No_Project;
Get_Project_Target;
Check_Builder_Switches; Check_Builder_Switches;
if Conf_File_Name'Length > 0 then if Conf_File_Name'Length > 0 then
@ -1448,7 +1462,8 @@ package body Prj.Conf is
if not Automatically_Generated if not Automatically_Generated
and then not and then not
Check_Target (Config, Autoconf_Specified, Project_Tree, Target_Name) Check_Target
(Config, Autoconf_Specified, Project_Tree, Selected_Target.all)
then then
Automatically_Generated := True; Automatically_Generated := True;
goto Process_Config_File; goto Process_Config_File;

24
gcc/ada/sem_ch6.adb
View File

@ -9754,6 +9754,30 @@ package body Sem_Ch6 is
Next_Formal (Formal); Next_Formal (Formal);
end loop; end loop;
-- Special case: An equality function can be redefined for a type
-- occurring in a declarative part, and won't otherwise be treated as
-- a primitive because it doesn't occur in a package spec and doesn't
-- override an inherited subprogram. It's important that we mark it
-- primitive so it can be returned by Collect_Primitive_Operations
-- and be used in composing the equality operation of later types
-- that have a component of the type.
elsif Chars (S) = Name_Op_Eq
and then Etype (S) = Standard_Boolean
then
B_Typ := Base_Type (Etype (First_Formal (S)));
if Scope (B_Typ) = Current_Scope
and then
Base_Type (Etype (Next_Formal (First_Formal (S)))) = B_Typ
and then not Is_Limited_Type (B_Typ)
then
Is_Primitive := True;
Set_Is_Primitive (S);
Set_Has_Primitive_Operations (B_Typ);
Check_Private_Overriding (B_Typ);
end if;
end if; end if;
end Check_For_Primitive_Subprogram; end Check_For_Primitive_Subprogram;

16
gcc/ada/sem_prag.adb
View File

@ -16017,9 +16017,23 @@ package body Sem_Prag is
if OK then if OK then
Chr := Get_Character (C); Chr := Get_Character (C);
-- Dash case: only -Wxxx is accepted
if J = 1
and then J < Len
and then Chr = '-'
then
J := J + 1;
C := Get_String_Char (Str, J);
Chr := Get_Character (C);
if Chr = 'W' then
exit;
end if;
OK := False;
-- Dot case -- Dot case
if J < Len and then Chr = '.' then elsif J < Len and then Chr = '.' then
J := J + 1; J := J + 1;
C := Get_String_Char (Str, J); C := Get_String_Char (Str, J);
Chr := Get_Character (C); Chr := Get_Character (C);

39
gcc/ada/sem_util.adb
View File

@ -2577,6 +2577,7 @@ package body Sem_Util is
Op_List : Elist_Id; Op_List : Elist_Id;
Formal : Entity_Id; Formal : Entity_Id;
Is_Prim : Boolean; Is_Prim : Boolean;
Is_Type_In_Pkg : Boolean;
Formal_Derived : Boolean := False; Formal_Derived : Boolean := False;
Id : Entity_Id; Id : Entity_Id;
@ -2636,12 +2637,9 @@ package body Sem_Util is
null; null;
end if; end if;
elsif (Is_Package_Or_Generic_Package (B_Scope) -- Locate the primitive subprograms of the type
and then
Nkind (Parent (Declaration_Node (First_Subtype (T)))) /= else
N_Package_Body)
or else Is_Derived_Type (B_Type)
then
-- The primitive operations appear after the base type, except -- The primitive operations appear after the base type, except
-- if the derivation happens within the private part of B_Scope -- if the derivation happens within the private part of B_Scope
-- and the type is a private type, in which case both the type -- and the type is a private type, in which case both the type
@ -2657,13 +2655,30 @@ package body Sem_Util is
Id := Next_Entity (B_Type); Id := Next_Entity (B_Type);
end if; end if;
-- Set flag if this is a type in a package spec
Is_Type_In_Pkg :=
Is_Package_Or_Generic_Package (B_Scope)
and then
Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
N_Package_Body;
while Present (Id) loop while Present (Id) loop
-- Note that generic formal subprograms are not -- Test whether the result type or any of the parameter types of
-- considered to be primitive operations and thus -- each subprogram following the type match that type when the
-- are never inherited. -- type is declared in a package spec, is a derived type, or the
-- subprogram is marked as primitive. (The Is_Primitive test is
-- needed to find primitives of nonderived types in declarative
-- parts that happen to override the predefined "=" operator.)
-- Note that generic formal subprograms are not considered to be
-- primitive operations and thus are never inherited.
if Is_Overloadable (Id) if Is_Overloadable (Id)
and then (Is_Type_In_Pkg
or else Is_Derived_Type (B_Type)
or else Is_Primitive (Id))
and then Nkind (Parent (Parent (Id))) and then Nkind (Parent (Parent (Id)))
not in N_Formal_Subprogram_Declaration not in N_Formal_Subprogram_Declaration
then then
@ -2684,9 +2699,9 @@ package body Sem_Util is
end loop; end loop;
end if; end if;
-- For a formal derived type, the only primitives are the -- For a formal derived type, the only primitives are the ones
-- ones inherited from the parent type. Operations appearing -- inherited from the parent type. Operations appearing in the
-- in the package declaration are not primitive for it. -- package declaration are not primitive for it.
if Is_Prim if Is_Prim
and then (not Formal_Derived and then (not Formal_Derived