+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
-- --
-- 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- --
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;
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
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.
-- --
-- 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- --
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
-- 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
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
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 --
-----------------------
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
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;
Free (Config_File_Path);
Config := No_Project;
+ Get_Project_Target;
Check_Builder_Switches;
if Conf_File_Name'Length > 0 then
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;
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;
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);
Op_List : Elist_Id;
Formal : Entity_Id;
Is_Prim : Boolean;
+ Is_Type_In_Pkg : Boolean;
Formal_Derived : Boolean := False;
Id : Entity_Id;
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
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
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
projects / platform / upstream / gcc.git / commitdiff