From 1aee1fb38d2776cb3fb336138e77da61aef8aab1 Mon Sep 17 00:00:00 2001
From: Arnaud Charlet <charlet@gcc.gnu.org>
Date: Wed, 6 Feb 2013 11:00:38 +0100
Subject: [PATCH] [multiple changes]
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
---
gcc/ada/ChangeLog | 31 +++++++++++
gcc/ada/erroutc.adb | 11 +++-
gcc/ada/gnat_rm.texi | 14 +++++
gcc/ada/prj-conf.adb | 121 ++++++++++++++++++++++++-------------------
gcc/ada/sem_ch6.adb | 24 +++++++++
gcc/ada/sem_prag.adb | 16 +++++-
gcc/ada/sem_util.adb | 39 +++++++++-----
7 files changed, 188 insertions(+), 68 deletions(-)
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 8748d8cfc02e..708e807d93ce 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -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>
* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Do not build the body
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
index 35f71a4a7cfa..bb4995da9ee1 100644
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -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- --
@@ -1282,7 +1282,14 @@ package body Erroutc is
Eproc.all
("?pragma Warnings Off with no matching Warnings On",
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
("?no warning suppressed by this pragma", SWE.Start);
end if;
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index bdad3f62a81f..6cd4b7bff37e 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -6153,6 +6153,14 @@ the list of warnings switches supported. For
full details see @ref{Warning Message Control,,, gnat_ugn, @value{EDITION}
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
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
@@ -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
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
configuration pragma. The effect is to suppress all warnings (if any)
that match the pattern string throughout the compilation.
diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb
index 766ce8e09c7c..89e1831959bd 100644
--- a/gcc/ada/prj-conf.adb
+++ b/gcc/ada/prj-conf.adb
@@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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;
end if;
- if Target = "" then
- OK := Autoconf_Specified or else Tgt_Name = No_Name;
- else
- OK := Tgt_Name /= No_Name
- and then Target = Get_Name_String (Tgt_Name);
- end if;
+ OK :=
+ Target = ""
+ or else
+ (Tgt_Name /= No_Name
+ and then Target = Get_Name_String (Tgt_Name));
if not OK 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
-- switches --config= in the Builder package of the main project.
+ Selected_Target : String_Access := new String'(Target_Name);
+
function Default_File_Name return String;
-- 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;
-- 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;
-- Return the --config switches to use for gprconfig
@@ -766,6 +771,47 @@ package body Prj.Conf is
end if;
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 --
-----------------------
@@ -775,13 +821,14 @@ package body Prj.Conf is
Tmp : String_Access;
begin
- if Target_Name /= "" then
+ if Selected_Target'Length /= 0 then
if Ada_RTS /= "" then
return
- Target_Name & '-' & Ada_RTS & Config_Project_File_Extension;
+ Selected_Target.all & '-' &
+ Ada_RTS & Config_Project_File_Extension;
else
return
- Target_Name & Config_Project_File_Extension;
+ Selected_Target.all & Config_Project_File_Extension;
end if;
elsif Ada_RTS /= "" then
@@ -972,51 +1019,17 @@ package body Prj.Conf is
if Normalized_Hostname = "" then
Arg_Last := 3;
else
- if Target_Name = "" 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;
+ if Selected_Target'Length = 0 then
+ if At_Least_One_Compiler_Command then
+ Args (4) := new String'("--target=all");
- 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");
-
- else
- Args (4) :=
- new String'("--target=" & Normalized_Hostname);
- end if;
- end;
+ else
+ Args (4) :=
+ new String'("--target=" & Normalized_Hostname);
+ end if;
else
- Args (4) := new String'("--target=" & Target_Name);
+ Args (4) := new String'("--target=" & Selected_Target.all);
end if;
Arg_Last := 4;
@@ -1348,6 +1361,7 @@ package body Prj.Conf is
Free (Config_File_Path);
Config := No_Project;
+ Get_Project_Target;
Check_Builder_Switches;
if Conf_File_Name'Length > 0 then
@@ -1448,7 +1462,8 @@ package body Prj.Conf is
if not Automatically_Generated
and then not
- Check_Target (Config, Autoconf_Specified, Project_Tree, Target_Name)
+ Check_Target
+ (Config, Autoconf_Specified, Project_Tree, Selected_Target.all)
then
Automatically_Generated := True;
goto Process_Config_File;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 5e365dbdbb3c..e75b00da2795 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -9754,6 +9754,30 @@ package body Sem_Ch6 is
Next_Formal (Formal);
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 Check_For_Primitive_Subprogram;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 5a935a55c337..935a26d3bf98 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -16017,9 +16017,23 @@ package body Sem_Prag is
if OK then
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
- if J < Len and then Chr = '.' then
+ elsif J < Len and then Chr = '.' then
J := J + 1;
C := Get_String_Char (Str, J);
Chr := Get_Character (C);
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 336ce67c49a7..aa585605843a 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -2577,6 +2577,7 @@ package body Sem_Util is
Op_List : Elist_Id;
Formal : Entity_Id;
Is_Prim : Boolean;
+ Is_Type_In_Pkg : Boolean;
Formal_Derived : Boolean := False;
Id : Entity_Id;
@@ -2636,12 +2637,9 @@ package body Sem_Util is
null;
end if;
- elsif (Is_Package_Or_Generic_Package (B_Scope)
- and then
- Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
- N_Package_Body)
- or else Is_Derived_Type (B_Type)
- then
+ -- Locate the primitive subprograms of the type
+
+ else
-- The primitive operations appear after the base type, except
-- if the derivation happens within the private part of B_Scope
-- 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);
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
- -- Note that generic formal subprograms are not
- -- considered to be primitive operations and thus
- -- are never inherited.
+ -- Test whether the result type or any of the parameter types of
+ -- each subprogram following the type match that type when the
+ -- 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)
+ and then (Is_Type_In_Pkg
+ or else Is_Derived_Type (B_Type)
+ or else Is_Primitive (Id))
and then Nkind (Parent (Parent (Id)))
not in N_Formal_Subprogram_Declaration
then
@@ -2684,9 +2699,9 @@ package body Sem_Util is
end loop;
end if;
- -- For a formal derived type, the only primitives are the
- -- ones inherited from the parent type. Operations appearing
- -- in the package declaration are not primitive for it.
+ -- For a formal derived type, the only primitives are the ones
+ -- inherited from the parent type. Operations appearing in the
+ -- package declaration are not primitive for it.
if Is_Prim
and then (not Formal_Derived
--
GitLab