From 1aee1fb38d2776cb3fb336138e77da61aef8aab1 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 6 Feb 2013 11:00:38 +0100 Subject: [PATCH] [multiple changes] 2013-02-06 Gary Dismukes * 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 * 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 * erroutc.adb (Validate_Specific_Warning): Do not issue the warning about an ineffective Pragma Warnings for -Wxxx warnings. * sem_prag.adb (Analyze_Pragma) : 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 8748d8c..708e807 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,34 @@ +2013-02-06 Gary Dismukes + + * 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 + + * 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 + + * erroutc.adb (Validate_Specific_Warning): Do not issue the + warning about an ineffective Pragma Warnings for -Wxxx warnings. + * sem_prag.adb (Analyze_Pragma) : Accept -Wxxx warnings. + * gnat_rm.texi (Pragma Warnings): Document coordination with + warnings of the GCC back-end. + 2013-02-06 Javier Miranda * 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 35f71a4..bb4995d 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 bdad3f6..6cd4b7b 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -6154,6 +6154,14 @@ 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 cumulative. Initially the set of warnings is the standard default set @@ -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 766ce8e..89e1831 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 5e365db..e75b00d 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 5a935a5..935a26d 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 336ce67..aa58560 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 -- 2.7.4