OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2010-10-05  Eric Botcazou  <ebotcazou@adacore.com>

	* exp_ch5.adb (Make_Field_Expr): Revert previous change (removed).

2010-10-05  Emmanuel Briot  <briot@adacore.com>

	* prj-dect.adb, prj-nmsc.adb, prj-attr.adb, snames.ads-tmpl
	(Aggregate projects): added support for parsing aggregate projects.
	In particular, check the presence and value of the new attributes
	related to aggregate projects, ie Project_Files, Project_Path
	and External.
	(Check_Attribute_Allowed, Check_Package_Allowed,
	Rename_Obsolescent_Attributes): new subprogram, extracting code
	from existing subprogram to keep their sizes smaller.
	(Check_Aggregate_Project, Check_Abstract_Project,
	Check_Missing_Sources): new subprograms
	(Check): remove comments that duplicated either the name of the
	following subprogram call, or the comment on that subprogram.
	* prj-part.adb (Check_Extending_All_Imports): New subprogram, extracted
	from Parse_Single_Project.
	(Check_Aggregate_Imports): new subprogram.

From-SVN: r164968
This commit is contained in:
Arnaud Charlet 2010-10-05 11:22:21 +02:00
parent 98ee5fc477
commit 9d9f5f49ae
7 changed files with 642 additions and 351 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
gcc/ada/ChangeLog
View File

@ -1,3 +1,25 @@
2010-10-05 Eric Botcazou <ebotcazou@adacore.com>
* exp_ch5.adb (Make_Field_Expr): Revert previous change (removed).
2010-10-05 Emmanuel Briot <briot@adacore.com>
* prj-dect.adb, prj-nmsc.adb, prj-attr.adb, snames.ads-tmpl
(Aggregate projects): added support for parsing aggregate projects.
In particular, check the presence and value of the new attributes
related to aggregate projects, ie Project_Files, Project_Path
and External.
(Check_Attribute_Allowed, Check_Package_Allowed,
Rename_Obsolescent_Attributes): new subprogram, extracting code
from existing subprogram to keep their sizes smaller.
(Check_Aggregate_Project, Check_Abstract_Project,
Check_Missing_Sources): new subprograms
(Check): remove comments that duplicated either the name of the
following subprogram call, or the comment on that subprogram.
* prj-part.adb (Check_Extending_All_Imports): New subprogram, extracted
from Parse_Single_Project.
(Check_Aggregate_Imports): new subprogram.
2010-10-05 Vincent Celier <celier@adacore.com>
* make.adb (Check): When compiling with -gnatc, recompile if the ALI

77
gcc/ada/exp_ch5.adb
View File

@ -1223,13 +1223,6 @@ package body Exp_Ch5 is
-- declaration for Typ. We need to use the actual entity because the
-- type may be private and resolution by identifier alone would fail.
function Make_Field_Expr
(Comp_Ent : Entity_Id;
U_U : Boolean) return Node_Id;
-- Common processing for one component for Make_Component_List_Assign
-- and Make_Field_Assign. Return the expression to be assigned for
-- component Comp_Ent.
function Make_Component_List_Assign
(CL : Node_Id;
U_U : Boolean := False) return List_Id;
@ -1289,6 +1282,7 @@ package body Exp_Ch5 is
Alts : List_Id;
DC : Node_Id;
DCH : List_Id;
Expr : Node_Id;
Result : List_Id;
V : Node_Id;
@ -1314,9 +1308,28 @@ package body Exp_Ch5 is
Next_Non_Pragma (V);
end loop;
-- If we have an Unchecked_Union, use the value of the inferred
-- discriminant of the variant part expression as the switch
-- for the case statement. The case statement may later be
-- folded.
if U_U then
Expr :=
New_Copy (Get_Discriminant_Value (
Entity (Name (VP)),
Etype (Rhs),
Discriminant_Constraint (Etype (Rhs))));
else
Expr :=
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Rhs),
Selector_Name =>
Make_Identifier (Loc, Chars (Name (VP))));
end if;
Append_To (Result,
Make_Case_Statement (Loc,
Expression => Make_Field_Expr (Entity (Name (VP)), U_U),
Expression => Expr,
Alternatives => Alts));
end if;
@ -1332,19 +1345,32 @@ package body Exp_Ch5 is
U_U : Boolean := False) return Node_Id
is
A : Node_Id;
Expr : Node_Id;
begin
-- In the case of an Unchecked_Union, use the discriminant
-- constraint value as on the right hand side of the assignment.
if U_U then
Expr :=
New_Copy (Get_Discriminant_Value (C,
Etype (Rhs),
Discriminant_Constraint (Etype (Rhs))));
else
Expr :=
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Rhs),
Selector_Name => New_Occurrence_Of (C, Loc));
end if;
A :=
Make_Assignment_Statement (Loc,
Name =>
Name =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Lhs),
Prefix => Duplicate_Subexpr (Lhs),
Selector_Name =>
New_Occurrence_Of (Find_Component (L_Typ, C), Loc)),
Expression => Make_Field_Expr (C, U_U));
Expression => Expr);
-- Set Assignment_OK, so discriminants can be assigned
@ -1369,8 +1395,9 @@ package body Exp_Ch5 is
Result : List_Id;
begin
Result := New_List;
Item := First (CI);
Result := New_List;
while Present (Item) loop
-- Look for components, but exclude _tag field assignment if
@ -1390,32 +1417,6 @@ package body Exp_Ch5 is
return Result;
end Make_Field_Assigns;
---------------------
-- Make_Field_Expr --
---------------------
function Make_Field_Expr
(Comp_Ent : Entity_Id;
U_U : Boolean) return Node_Id
is
begin
-- If we have an Unchecked_Union, use the value of the inferred
-- discriminant of the variant part expression.
if U_U then
return
New_Copy (Get_Discriminant_Value
(Comp_Ent,
Etype (Rhs),
Discriminant_Constraint (Etype (Rhs))));
else
return
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Rhs),
Selector_Name => New_Occurrence_Of (Comp_Ent, Loc));
end if;
end Make_Field_Expr;
-- Start of processing for Expand_Assign_Record
begin

16
gcc/ada/prj-attr.adb
View File

@ -91,6 +91,12 @@ package body Prj.Attr is
"SVexcluded_source_list_file#" &
"LVinterfaces#" &
-- Projects (in aggregate projects)
"LVproject_files#" &
"LVproject_path#" &
"SAexternal#" &
-- Libraries
"SVlibrary_dir#" &
@ -147,18 +153,20 @@ package body Prj.Attr is
"Saruntime_source_dir#" &
-- package Naming
-- Some attributes are obsolescent, and renamed in the tree (see
-- Prj.Dect.Rename_Obsolescent_Attributes).
"Pnaming#" &
"Saspecification_suffix#" &
"Saspecification_suffix#" & -- Always renamed to "spec_suffix" in tree
"Saspec_suffix#" &
"Saimplementation_suffix#" &
"Saimplementation_suffix#" & -- Always renamed to "body_suffix" in tree
"Sabody_suffix#" &
"SVseparate_suffix#" &
"SVcasing#" &
"SVdot_replacement#" &
"sAspecification#" &
"sAspecification#" & -- Always renamed to "spec" in project tree
"sAspec#" &
"sAimplementation#" &
"sAimplementation#" & -- Always renamed to "body" in project tree
"sAbody#" &
"Laspecification_exceptions#" &
"Laimplementation_exceptions#" &

245
gcc/ada/prj-dect.adb
View File

@ -48,6 +48,31 @@ package body Prj.Dect is
-- a case construction (In_Case_Construction) or none of those two
-- (In_Project).
procedure Rename_Obsolescent_Attributes
(In_Tree : Project_Node_Tree_Ref;
Attribute : Project_Node_Id;
Current_Package : Project_Node_Id);
-- Rename obsolescent attributes in the tree.
-- When the attribute has been renamed since its initial introduction in
-- the design of projects, we replace the old name in the tree with the
-- new name, so that the code does not have to check both names forever.
procedure Check_Attribute_Allowed
(In_Tree : Project_Node_Tree_Ref;
Project : Project_Node_Id;
Attribute : Project_Node_Id;
Flags : Processing_Flags);
-- Chech whether the attribute is valid in this project.
-- In particular, depending on the type of project (qualifier), some
-- attributes might be disabled.
procedure Check_Package_Allowed
(In_Tree : Project_Node_Tree_Ref;
Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Flags : Processing_Flags);
-- Check whether the package is valid in this project
procedure Parse_Attribute_Declaration
(In_Tree : Project_Node_Tree_Ref;
Attribute : out Project_Node_Id;
@ -147,6 +172,111 @@ package body Prj.Dect is
(Declarations, In_Tree, To => First_Declarative_Item);
end Parse;
-----------------------------------
-- Rename_Obsolescent_Attributes --
-----------------------------------
procedure Rename_Obsolescent_Attributes
(In_Tree : Project_Node_Tree_Ref;
Attribute : Project_Node_Id;
Current_Package : Project_Node_Id) is
begin
if Present (Current_Package)
and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored
then
case Name_Of (Attribute, In_Tree) is
when Snames.Name_Specification =>
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec);
when Snames.Name_Specification_Suffix =>
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix);
when Snames.Name_Implementation =>
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body);
when Snames.Name_Implementation_Suffix =>
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix);
when others =>
null;
end case;
end if;
end Rename_Obsolescent_Attributes;
---------------------------
-- Check_Package_Allowed --
---------------------------
procedure Check_Package_Allowed
(In_Tree : Project_Node_Tree_Ref;
Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Flags : Processing_Flags)
is
Qualif : constant Project_Qualifier :=
Project_Qualifier_Of (Project, In_Tree);
Name : constant Name_Id := Name_Of (Current_Package, In_Tree);
begin
if Qualif = Aggregate
and then Name /= Snames.Name_Builder
then
Error_Msg_Name_1 := Name;
Error_Msg
(Flags,
"package %% is forbidden in aggregate projects",
Location_Of (Current_Package, In_Tree));
end if;
end Check_Package_Allowed;
-----------------------------
-- Check_Attribute_Allowed --
-----------------------------
procedure Check_Attribute_Allowed
(In_Tree : Project_Node_Tree_Ref;
Project : Project_Node_Id;
Attribute : Project_Node_Id;
Flags : Processing_Flags)
is
Qualif : constant Project_Qualifier :=
Project_Qualifier_Of (Project, In_Tree);
Name : constant Name_Id := Name_Of (Attribute, In_Tree);
begin
case Qualif is
when Aggregate =>
if Name = Snames.Name_Languages
or else Name = Snames.Name_Source_Files
or else Name = Snames.Name_Source_List_File
or else Name = Snames.Name_Locally_Removed_Files
or else Name = Snames.Name_Excluded_Source_Files
or else Name = Snames.Name_Excluded_Source_List_File
or else Name = Snames.Name_Interfaces
or else Name = Snames.Name_Object_Dir
or else Name = Snames.Name_Exec_Dir
or else Name = Snames.Name_Source_Dirs
or else Name = Snames.Name_Inherit_Source_Path
then
Error_Msg_Name_1 := Name;
Error_Msg
(Flags,
"%% is not valid in aggregate projects",
Location_Of (Attribute, In_Tree));
end if;
when others =>
if Name = Snames.Name_Project_Files
or else Name = Snames.Name_Project_Path
or else Name = Snames.Name_External
then
Error_Msg_Name_1 := Name;
Error_Msg
(Flags,
"%% is only valid in aggregate projects",
Location_Of (Attribute, In_Tree));
end if;
end case;
end Check_Attribute_Allowed;
---------------------------------
-- Parse_Attribute_Declaration --
---------------------------------
@ -165,37 +295,28 @@ package body Prj.Dect is
Attribute_Name : Name_Id := No_Name;
Optional_Index : Boolean := False;
Pkg_Id : Package_Node_Id := Empty_Package;
Ignore : Boolean := False;
begin
Attribute :=
Default_Project_Node
(Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree);
Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
Set_Previous_Line_Node (Attribute);
procedure Process_Attribute_Name;
-- Read the name of the attribute, and check its type
-- Scan past "for"
procedure Process_Associative_Array_Index;
-- Read the index of the associative array and check its validity
Scan (In_Tree);
----------------------------
-- Process_Attribute_Name --
----------------------------
-- Body may be an attribute name
if Token = Tok_Body then
Token := Tok_Identifier;
Token_Name := Snames.Name_Body;
end if;
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
procedure Process_Attribute_Name is
Ignore : Boolean;
begin
Attribute_Name := Token_Name;
Set_Name_Of (Attribute, In_Tree, To => Token_Name);
Set_Name_Of (Attribute, In_Tree, To => Attribute_Name);
Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
-- Find the attribute
Current_Attribute :=
Attribute_Node_Id_Of (Token_Name, First_Attribute);
Attribute_Node_Id_Of (Attribute_Name, First_Attribute);
-- If the attribute cannot be found, create the attribute if inside
-- an unknown package.
@ -254,35 +375,22 @@ package body Prj.Dect is
end if;
Scan (In_Tree); -- past the attribute name
end if;
-- Change obsolete names of attributes to the new names
-- Set the expression kind of the attribute
if Present (Current_Package)
and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored
then
case Name_Of (Attribute, In_Tree) is
when Snames.Name_Specification =>
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec);
if Current_Attribute /= Empty_Attribute then
Set_Expression_Kind_Of
(Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute));
Optional_Index := Optional_Index_Of (Current_Attribute);
end if;
end Process_Attribute_Name;
when Snames.Name_Specification_Suffix =>
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix);
when Snames.Name_Implementation =>
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body);
when Snames.Name_Implementation_Suffix =>
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix);
when others =>
null;
end case;
end if;
-- Associative array attributes
if Token = Tok_Left_Paren then
-------------------------------------
-- Process_Associative_Array_Index --
-------------------------------------
procedure Process_Associative_Array_Index is
begin
-- If the attribute is not an associative array attribute, report
-- an error. If this information is still unknown, set the kind
-- to Associative_Array.
@ -292,9 +400,8 @@ package body Prj.Dect is
then
Error_Msg (Flags,
"the attribute """ &
Get_Name_String
(Attribute_Name_Of (Current_Attribute)) &
""" cannot be an associative array",
Get_Name_String (Attribute_Name_Of (Current_Attribute))
& """ cannot be an associative array",
Location_Of (Attribute, In_Tree));
elsif Attribute_Kind_Of (Current_Attribute) = Unknown then
@ -371,6 +478,35 @@ package body Prj.Dect is
if Token = Tok_Right_Paren then
Scan (In_Tree); -- past the right parenthesis
end if;
end Process_Associative_Array_Index;
begin
Attribute :=
Default_Project_Node
(Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree);
Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
Set_Previous_Line_Node (Attribute);
-- Scan past "for"
Scan (In_Tree);
-- Body may be an attribute name
if Token = Tok_Body then
Token := Tok_Identifier;
Token_Name := Snames.Name_Body;
end if;
Expect (Tok_Identifier, "identifier");
Process_Attribute_Name;
Rename_Obsolescent_Attributes (In_Tree, Attribute, Current_Package);
Check_Attribute_Allowed (In_Tree, Current_Project, Attribute, Flags);
-- Associative array attributes
if Token = Tok_Left_Paren then
Process_Associative_Array_Index;
else
-- If it is an associative array attribute and there are no left
@ -390,14 +526,6 @@ package body Prj.Dect is
end if;
end if;
-- Set the expression kind of the attribute
if Current_Attribute /= Empty_Attribute then
Set_Expression_Kind_Of
(Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute));
Optional_Index := Optional_Index_Of (Current_Attribute);
end if;
Expect (Tok_Use, "USE");
if Token = Tok_Use then
@ -1149,6 +1277,9 @@ package body Prj.Dect is
Scan (In_Tree);
end if;
Check_Package_Allowed
(In_Tree, Current_Project, Package_Declaration, Flags);
if Token = Tok_Renames then
Renaming := True;
elsif Token = Tok_Extends then

282
gcc/ada/prj-nmsc.adb
View File

@ -282,6 +282,16 @@ package body Prj.Nmsc is
-- Check the library attributes of project Project in project tree
-- and modify its data Data accordingly.
procedure Check_Aggregate_Project
(Project : Project_Id;
Data : in out Tree_Processing_Data);
-- Check aggregate projects attributes
procedure Check_Abstract_Project
(Project : Project_Id;
Data : in out Tree_Processing_Data);
-- Check abstract projects attributes
procedure Check_Programming_Languages
(Project : Project_Id;
Data : in out Tree_Processing_Data);
@ -432,9 +442,8 @@ package body Prj.Nmsc is
(Project : in out Project_Processing_Data;
Data : in out Tree_Processing_Data);
-- Find all the sources of project Project in project tree Data.Tree and
-- update its Data accordingly. This assumes that Data.First_Source has
-- been initialized with the list of excluded sources and special naming
-- exceptions.
-- update its Data accordingly. This assumes that the special naming
-- exceptions have already been processed.
function Path_Name_Of
(File_Name : File_Name_Type;
@ -854,6 +863,73 @@ package body Prj.Nmsc is
end if;
end Canonical_Case_File_Name;
-----------------------------
-- Check_Aggregate_Project --
-----------------------------
procedure Check_Aggregate_Project
(Project : Project_Id;
Data : in out Tree_Processing_Data)
is
Project_Files : constant Prj.Variable_Value :=
Prj.Util.Value_Of
(Snames.Name_Project_Files,
Project.Decl.Attributes,
Data.Tree);
begin
if Project_Files.Default then
Error_Msg_Name_1 := Snames.Name_Project_Files;
Error_Msg
(Data.Flags,
"Attribute %% must be specified in aggregate project",
Project.Location, Project);
end if;
end Check_Aggregate_Project;
----------------------------
-- Check_Abstract_Project --
----------------------------
procedure Check_Abstract_Project
(Project : Project_Id;
Data : in out Tree_Processing_Data)
is
Source_Dirs : constant Variable_Value :=
Util.Value_Of
(Name_Source_Dirs,
Project.Decl.Attributes, Data.Tree);
Source_Files : constant Variable_Value :=
Util.Value_Of
(Name_Source_Files,
Project.Decl.Attributes, Data.Tree);
Source_List_File : constant Variable_Value :=
Util.Value_Of
(Name_Source_List_File,
Project.Decl.Attributes, Data.Tree);
Languages : constant Variable_Value :=
Util.Value_Of
(Name_Languages,
Project.Decl.Attributes, Data.Tree);
begin
if Project.Source_Dirs /= Nil_String then
if Source_Dirs.Values = Nil_String
and then Source_Files.Values = Nil_String
and then Languages.Values = Nil_String
and then Source_List_File.Default
then
Project.Source_Dirs := Nil_String;
else
Error_Msg
(Data.Flags,
"at least one of Source_Files, Source_Dirs or Languages "
& "must be declared empty for an abstract project",
Project.Location, Project);
end if;
end if;
end Check_Abstract_Project;
-----------
-- Check --
-----------
@ -862,60 +938,20 @@ package body Prj.Nmsc is
(Project : Project_Id;
Data : in out Tree_Processing_Data)
is
Extending : Boolean := False;
Prj_Data : Project_Processing_Data;
begin
Initialize (Prj_Data, Project);
Check_If_Externally_Built (Project, Data);
-- Object, exec and source directories
Get_Directories (Project, Data);
-- Get the programming languages
Check_If_Externally_Built (Project, Data);
Get_Directories (Project, Data);
Check_Programming_Languages (Project, Data);
if Project.Qualifier = Dry
and then Project.Source_Dirs /= Nil_String
then
declare
Source_Dirs : constant Variable_Value :=
Util.Value_Of
(Name_Source_Dirs,
Project.Decl.Attributes, Data.Tree);
Source_Files : constant Variable_Value :=
Util.Value_Of
(Name_Source_Files,
Project.Decl.Attributes, Data.Tree);
Source_List_File : constant Variable_Value :=
Util.Value_Of
(Name_Source_List_File,
Project.Decl.Attributes, Data.Tree);
Languages : constant Variable_Value :=
Util.Value_Of
(Name_Languages,
Project.Decl.Attributes, Data.Tree);
begin
if Source_Dirs.Values = Nil_String
and then Source_Files.Values = Nil_String
and then Languages.Values = Nil_String
and then Source_List_File.Default
then
Project.Source_Dirs := Nil_String;
else
Error_Msg
(Data.Flags,
"at least one of Source_Files, Source_Dirs or Languages "
& "must be declared empty for an abstract project",
Project.Location, Project);
end if;
end;
end if;
case Project.Qualifier is
when Aggregate => Check_Aggregate_Project (Project, Data);
when Dry => Check_Abstract_Project (Project, Data);
when others => null;
end case;
-- Check configuration. This must be done even for gnatmake (even though
-- no user configuration file was provided) since the default config we
@ -923,91 +959,24 @@ package body Prj.Nmsc is
Check_Configuration (Project, Data);
-- Library attributes
Check_Library_Attributes (Project, Data);
if Current_Verbosity = High then
Show_Source_Dirs (Project, Data.Tree);
end if;
Extending := Project.Extends /= No_Project;
Check_Package_Naming (Project, Data);
-- Find the sources
if Project.Source_Dirs /= Nil_String then
if Project.Qualifier /= Aggregate then
Look_For_Sources (Prj_Data, Data);
if not Project.Externally_Built
and then not Extending
then
declare
Language : Language_Ptr;
Source : Source_Id;
Alt_Lang : Language_List;
Continuation : Boolean := False;
Iter : Source_Iterator;
begin
Language := Project.Languages;
while Language /= No_Language_Index loop
-- If there are no sources for this language, check if there
-- are sources for which this is an alternate language.
if Language.First_Source = No_Source
and then (Data.Flags.Require_Sources_Other_Lang
or else Language.Name = Name_Ada)
then
Iter := For_Each_Source (In_Tree => Data.Tree,
Project => Project);
Source_Loop : loop
Source := Element (Iter);
exit Source_Loop when Source = No_Source
or else Source.Language = Language;
Alt_Lang := Source.Alternate_Languages;
while Alt_Lang /= null loop
exit Source_Loop when Alt_Lang.Language = Language;
Alt_Lang := Alt_Lang.Next;
end loop;
Next (Iter);
end loop Source_Loop;
if Source = No_Source then
Report_No_Sources
(Project,
Get_Name_String (Language.Display_Name),
Data,
Prj_Data.Source_List_File_Location,
Continuation);
Continuation := True;
end if;
end if;
Language := Language.Next;
end loop;
end;
end if;
end if;
-- If a list of sources is specified in attribute Interfaces, set
-- In_Interfaces only for the sources specified in the list.
Check_Interfaces (Project, Data);
-- If it is a library project file, check if it is a standalone library
if Project.Library then
Check_Stand_Alone_Library (Project, Data);
end if;
-- Put the list of Mains, if any, in the project data
Get_Mains (Project, Data);
Free (Prj_Data);
@ -7242,6 +7211,68 @@ package body Prj.Nmsc is
procedure Mark_Excluded_Sources;
-- Mark as such the sources that are declared as excluded
procedure Check_Missing_Sources;
-- Check whether one of the languages has no sources, and report an
-- error when appropriate
---------------------------
-- Check_Missing_Sources --
---------------------------
procedure Check_Missing_Sources is
Extending : constant Boolean :=
Project.Project.Extends /= No_Project;
Language : Language_Ptr;
Source : Source_Id;
Alt_Lang : Language_List;
Continuation : Boolean := False;
Iter : Source_Iterator;
begin
if not Project.Project.Externally_Built
and then not Extending
then
Language := Project.Project.Languages;
while Language /= No_Language_Index loop
-- If there are no sources for this language, check if there
-- are sources for which this is an alternate language.
if Language.First_Source = No_Source
and then (Data.Flags.Require_Sources_Other_Lang
or else Language.Name = Name_Ada)
then
Iter := For_Each_Source (In_Tree => Data.Tree,
Project => Project.Project);
Source_Loop : loop
Source := Element (Iter);
exit Source_Loop when Source = No_Source
or else Source.Language = Language;
Alt_Lang := Source.Alternate_Languages;
while Alt_Lang /= null loop
exit Source_Loop when Alt_Lang.Language = Language;
Alt_Lang := Alt_Lang.Next;
end loop;
Next (Iter);
end loop Source_Loop;
if Source = No_Source then
Report_No_Sources
(Project.Project,
Get_Name_String (Language.Display_Name),
Data,
Project.Source_List_File_Location,
Continuation);
Continuation := True;
end if;
end if;
Language := Language.Next;
end loop;
end if;
end Check_Missing_Sources;
------------------
-- Check_Object --
------------------
@ -7416,13 +7447,16 @@ package body Prj.Nmsc is
-- Start of processing for Look_For_Sources
begin
Find_Excluded_Sources (Project, Data);
if Project.Project.Source_Dirs /= Nil_String then
Find_Excluded_Sources (Project, Data);
if Project.Project.Languages /= No_Language_Index then
Load_Naming_Exceptions (Project, Data);
Find_Sources (Project, Data);
Mark_Excluded_Sources;
Check_Object_Files;
if Project.Project.Languages /= No_Language_Index then
Load_Naming_Exceptions (Project, Data);
Find_Sources (Project, Data);
Mark_Excluded_Sources;
Check_Object_Files;
Check_Missing_Sources;
end if;
end if;
Object_File_Names_Htable.Reset (Object_Files);

349
gcc/ada/prj-part.adb
View File

@ -125,8 +125,37 @@ package body Prj.Part is
Key => Name_Id,
Hash => Hash,
Equal => "=");
function Has_Circular_Dependencies
(Flags : Processing_Flags;
Normed_Path_Name : Path_Name_Type;
Canonical_Path_Name : Path_Name_Type) return Boolean;
-- Check for a circular dependency in the loaded project.
-- Generates an error message in such a case.
procedure Read_Project_Qualifier
(Flags : Processing_Flags;
In_Tree : Project_Node_Tree_Ref;
Is_Config_File : Boolean;
Qualifier_Location : out Source_Ptr;
Project : Project_Node_Id);
-- Check if there is a qualifier before the reserved word "project"
-- Hash table to cache project path to avoid looking for them on the path
procedure Check_Extending_All_Imports
(Flags : Processing_Flags;
In_Tree : Project_Node_Tree_Ref;
Project : Project_Node_Id);
-- Check that a non extending-all project does not import an
-- extending-all project.
procedure Check_Aggregate_Imports
(Flags : Processing_Flags;
In_Tree : Project_Node_Tree_Ref;
Project : Project_Node_Id);
-- Check that an aggregate project only imports abstract projects
procedure Create_Virtual_Extending_Project
(For_Project : Project_Node_Id;
Main_Project : Project_Node_Id;
@ -916,6 +945,185 @@ package body Prj.Part is
end loop;
end Post_Parse_Context_Clause;
---------------------------------
-- Check_Extending_All_Imports --
---------------------------------
procedure Check_Extending_All_Imports
(Flags : Processing_Flags;
In_Tree : Project_Node_Tree_Ref;
Project : Project_Node_Id)
is
With_Clause, Imported : Project_Node_Id;
begin
if not Is_Extending_All (Project, In_Tree) then
With_Clause := First_With_Clause_Of (Project, In_Tree);
while Present (With_Clause) loop
Imported := Project_Node_Of (With_Clause, In_Tree);
if Is_Extending_All (With_Clause, In_Tree) then
Error_Msg_Name_1 := Name_Of (Imported, In_Tree);
Error_Msg (Flags, "cannot import extending-all project %%",
Token_Ptr);
exit;
end if;
With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
end loop;
end if;
end Check_Extending_All_Imports;
-----------------------------
-- Check_Aggregate_Imports --
-----------------------------
procedure Check_Aggregate_Imports
(Flags : Processing_Flags;
In_Tree : Project_Node_Tree_Ref;
Project : Project_Node_Id)
is
With_Clause, Imported : Project_Node_Id;
begin
if Project_Qualifier_Of (Project, In_Tree) = Aggregate then
With_Clause := First_With_Clause_Of (Project, In_Tree);
while Present (With_Clause) loop
Imported := Project_Node_Of (With_Clause, In_Tree);
if Project_Qualifier_Of (Imported, In_Tree) /= Dry then
Error_Msg_Name_1 := Name_Id (Path_Name_Of (Imported, In_Tree));
Error_Msg (Flags, "can only import abstract projects, not %%",
Token_Ptr);
exit;
end if;
With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
end loop;
end if;
end Check_Aggregate_Imports;
----------------------------
-- Read_Project_Qualifier --
----------------------------
procedure Read_Project_Qualifier
(Flags : Processing_Flags;
In_Tree : Project_Node_Tree_Ref;
Is_Config_File : Boolean;
Qualifier_Location : out Source_Ptr;
Project : Project_Node_Id)
is
Proj_Qualifier : Project_Qualifier := Unspecified;
begin
Qualifier_Location := Token_Ptr;
if Token = Tok_Abstract then
Proj_Qualifier := Dry;
Scan (In_Tree);
elsif Token = Tok_Identifier then
case Token_Name is
when Snames.Name_Standard =>
Proj_Qualifier := Standard;
Scan (In_Tree);
when Snames.Name_Aggregate =>
Proj_Qualifier := Aggregate;
Scan (In_Tree);
if Token = Tok_Identifier and then
Token_Name = Snames.Name_Library
then
Proj_Qualifier := Aggregate_Library;
Scan (In_Tree);
end if;
when Snames.Name_Library =>
Proj_Qualifier := Library;
Scan (In_Tree);
when Snames.Name_Configuration =>
if not Is_Config_File then
Error_Msg
(Flags,
"configuration projects cannot belong to a user" &
" project tree",
Token_Ptr);
end if;
Proj_Qualifier := Configuration;
Scan (In_Tree);
when others =>
null;
end case;
end if;
if Is_Config_File and then Proj_Qualifier = Unspecified then
-- Set the qualifier to Configuration, even if the token doesn't
-- exist in the source file itself, so that we can differentiate
-- project files and configuration files later on.
Proj_Qualifier := Configuration;
end if;
if Proj_Qualifier /= Unspecified then
if Is_Config_File
and then Proj_Qualifier /= Configuration
then
Error_Msg (Flags,
"a configuration project cannot be qualified except " &
"as configuration project",
Qualifier_Location);
end if;
Set_Project_Qualifier_Of (Project, In_Tree, Proj_Qualifier);
end if;
end Read_Project_Qualifier;
-------------------------------
-- Has_Circular_Dependencies --
-------------------------------
function Has_Circular_Dependencies
(Flags : Processing_Flags;
Normed_Path_Name : Path_Name_Type;
Canonical_Path_Name : Path_Name_Type) return Boolean is
begin
for Index in reverse 1 .. Project_Stack.Last loop
exit when Project_Stack.Table (Index).Limited_With;
if Canonical_Path_Name =
Project_Stack.Table (Index).Canonical_Path_Name
then
Error_Msg (Flags, "circular dependency detected", Token_Ptr);
Error_Msg_Name_1 := Name_Id (Normed_Path_Name);
Error_Msg (Flags, "\ %% is imported by", Token_Ptr);
for Current in reverse 1 .. Project_Stack.Last loop
Error_Msg_Name_1 :=
Name_Id (Project_Stack.Table (Current).Path_Name);
if Project_Stack.Table (Current).Canonical_Path_Name /=
Canonical_Path_Name
then
Error_Msg
(Flags, "\ %% which itself is imported by", Token_Ptr);
else
Error_Msg (Flags, "\ %%", Token_Ptr);
exit;
end if;
end loop;
return True;
end if;
end loop;
return False;
end Has_Circular_Dependencies;
--------------------------
-- Parse_Single_Project --
--------------------------
@ -962,7 +1170,6 @@ package body Prj.Part is
Project_Comment_State : Tree.Comment_State;
Proj_Qualifier : Project_Qualifier := Unspecified;
Qualifier_Location : Source_Ptr;
begin
@ -988,38 +1195,12 @@ package body Prj.Part is
Canonical_Path_Name := Name_Find;
end;
-- Check for a circular dependency
for Index in reverse 1 .. Project_Stack.Last loop
exit when Project_Stack.Table (Index).Limited_With;
if Canonical_Path_Name =
Project_Stack.Table (Index).Canonical_Path_Name
then
Error_Msg (Flags, "circular dependency detected", Token_Ptr);
Error_Msg_Name_1 := Name_Id (Normed_Path_Name);
Error_Msg (Flags, "\ %% is imported by", Token_Ptr);
for Current in reverse 1 .. Project_Stack.Last loop
Error_Msg_Name_1 :=
Name_Id (Project_Stack.Table (Current).Path_Name);
if Project_Stack.Table (Current).Canonical_Path_Name /=
Canonical_Path_Name
then
Error_Msg
(Flags, "\ %% which itself is imported by", Token_Ptr);
else
Error_Msg (Flags, "\ %%", Token_Ptr);
exit;
end if;
end loop;
Project := Empty_Node;
return;
end if;
end loop;
if Has_Circular_Dependencies
(Flags, Normed_Path_Name, Canonical_Path_Name)
then
Project := Empty_Node;
return;
end if;
-- Put the new path name on the stack
@ -1156,73 +1337,8 @@ package body Prj.Part is
Set_Directory_Of (Project, In_Tree, Project_Directory);
Set_Path_Name_Of (Project, In_Tree, Normed_Path_Name);
-- Check if there is a qualifier before the reserved word "project"
Qualifier_Location := Token_Ptr;
if Token = Tok_Abstract then
Proj_Qualifier := Dry;
Scan (In_Tree);
elsif Token = Tok_Identifier then
case Token_Name is
when Snames.Name_Standard =>
Proj_Qualifier := Standard;
Scan (In_Tree);
when Snames.Name_Aggregate =>
Proj_Qualifier := Aggregate;
Scan (In_Tree);
if Token = Tok_Identifier and then
Token_Name = Snames.Name_Library
then
Proj_Qualifier := Aggregate_Library;
Scan (In_Tree);
end if;
when Snames.Name_Library =>
Proj_Qualifier := Library;
Scan (In_Tree);
when Snames.Name_Configuration =>
if not Is_Config_File then
Error_Msg
(Flags,
"configuration projects cannot belong to a user" &
" project tree",
Token_Ptr);
end if;
Proj_Qualifier := Configuration;
Scan (In_Tree);
when others =>
null;
end case;
end if;
if Is_Config_File and then Proj_Qualifier = Unspecified then
-- Set the qualifier to Configuration, even if the token doesn't
-- exist in the source file itself, so that we can differentiate
-- project files and configuration files later on.
Proj_Qualifier := Configuration;
end if;
if Proj_Qualifier /= Unspecified then
if Is_Config_File
and then Proj_Qualifier /= Configuration
then
Error_Msg (Flags,
"a configuration project cannot be qualified except " &
"as configuration project",
Qualifier_Location);
end if;
Set_Project_Qualifier_Of (Project, In_Tree, Proj_Qualifier);
end if;
Read_Project_Qualifier
(Flags, In_Tree, Is_Config_File, Qualifier_Location, Project);
Set_Location_Of (Project, In_Tree, Token_Ptr);
@ -1513,7 +1629,7 @@ package body Prj.Part is
-- with sources, if it inherits sources from the project
-- it extends.
if Proj_Qualifier = Dry and then
if Project_Qualifier_Of (Project, In_Tree) = Dry and then
Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry
then
Error_Msg
@ -1529,31 +1645,8 @@ package body Prj.Part is
end if;
end if;
-- Check that a non extending-all project does not import an
-- extending-all project.
if not Is_Extending_All (Project, In_Tree) then
declare
With_Clause : Project_Node_Id :=
First_With_Clause_Of (Project, In_Tree);
Imported : Project_Node_Id := Empty_Node;
begin
With_Clause_Loop :
while Present (With_Clause) loop
Imported := Project_Node_Of (With_Clause, In_Tree);
if Is_Extending_All (With_Clause, In_Tree) then
Error_Msg_Name_1 := Name_Of (Imported, In_Tree);
Error_Msg (Flags, "cannot import extending-all project %%",
Token_Ptr);
exit With_Clause_Loop;
end if;
With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
end loop With_Clause_Loop;
end;
end if;
Check_Extending_All_Imports (Flags, In_Tree, Project);
Check_Aggregate_Imports (Flags, In_Tree, Project);
-- Check that a project with a name including a dot either imports
-- or extends the project whose name precedes the last dot.
@ -1571,7 +1664,7 @@ package body Prj.Part is
Name_Len := Name_Len - 1;
end loop;
-- If a dot was find, check if the parent project is imported
-- If a dot was found, check if the parent project is imported
-- or extended.
if Name_Len > 0 then
@ -1728,7 +1821,7 @@ package body Prj.Part is
Node => Project,
Canonical_Path => Canonical_Path_Name,
Extended => Extended,
Proj_Qualifier => Proj_Qualifier));
Proj_Qualifier => Project_Qualifier_Of (Project, In_Tree)));
end if;
declare

2
gcc/ada/snames.ads-tmpl
View File

@ -1133,6 +1133,8 @@ package Snames is
Name_Prefix : constant Name_Id := N + $;
Name_Project : constant Name_Id := N + $;
Name_Project_Dir : constant Name_Id := N + $;
Name_Project_Files : constant Name_Id := N + $;
Name_Project_Path : constant Name_Id := N + $;
Name_Response_File_Format : constant Name_Id := N + $;
Name_Response_File_Switches : constant Name_Id := N + $;
Name_Roots : constant Name_Id := N + $; -- GPR