Skip to content

R
riscv-gcc-1
Commit 9d9f5f49 by Arnaud Charlet
Options

[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
parent 98ee5fc4
Showing with 643 additions and 352 deletions
gcc/ada/ChangeLog
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> 2010-10-05 Vincent Celier <celier@adacore.com>
* make.adb (Check): When compiling with -gnatc, recompile if the ALI * make.adb (Check): When compiling with -gnatc, recompile if the ALI
......
gcc/ada/exp_ch5.adb
...@@ -1223,13 +1223,6 @@ package body Exp_Ch5 is ...@@ -1223,13 +1223,6 @@ package body Exp_Ch5 is
-- declaration for Typ. We need to use the actual entity because the -- declaration for Typ. We need to use the actual entity because the
-- type may be private and resolution by identifier alone would fail. -- 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 function Make_Component_List_Assign
(CL : Node_Id; (CL : Node_Id;
U_U : Boolean := False) return List_Id; U_U : Boolean := False) return List_Id;
...@@ -1289,6 +1282,7 @@ package body Exp_Ch5 is ...@@ -1289,6 +1282,7 @@ package body Exp_Ch5 is
Alts : List_Id; Alts : List_Id;
DC : Node_Id; DC : Node_Id;
DCH : List_Id; DCH : List_Id;
Expr : Node_Id;
Result : List_Id; Result : List_Id;
V : Node_Id; V : Node_Id;
...@@ -1314,9 +1308,28 @@ package body Exp_Ch5 is ...@@ -1314,9 +1308,28 @@ package body Exp_Ch5 is
Next_Non_Pragma (V); Next_Non_Pragma (V);
end loop; 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, Append_To (Result,
Make_Case_Statement (Loc, Make_Case_Statement (Loc,
Expression => Make_Field_Expr (Entity (Name (VP)), U_U), Expression => Expr,
Alternatives => Alts)); Alternatives => Alts));
end if; end if;
...@@ -1332,19 +1345,32 @@ package body Exp_Ch5 is ...@@ -1332,19 +1345,32 @@ package body Exp_Ch5 is
U_U : Boolean := False) return Node_Id U_U : Boolean := False) return Node_Id
is is
A : Node_Id; A : Node_Id;
Expr : Node_Id;
begin begin
-- In the case of an Unchecked_Union, use the discriminant -- In the case of an Unchecked_Union, use the discriminant
-- constraint value as on the right hand side of the assignment. -- 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 := A :=
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => Name =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Lhs), Prefix => Duplicate_Subexpr (Lhs),
Selector_Name => Selector_Name =>
New_Occurrence_Of (Find_Component (L_Typ, C), Loc)), 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 -- Set Assignment_OK, so discriminants can be assigned
...@@ -1369,8 +1395,9 @@ package body Exp_Ch5 is ...@@ -1369,8 +1395,9 @@ package body Exp_Ch5 is
Result : List_Id; Result : List_Id;
begin begin
Result := New_List;
Item := First (CI); Item := First (CI);
Result := New_List;
while Present (Item) loop while Present (Item) loop
-- Look for components, but exclude _tag field assignment if -- Look for components, but exclude _tag field assignment if
...@@ -1390,32 +1417,6 @@ package body Exp_Ch5 is ...@@ -1390,32 +1417,6 @@ package body Exp_Ch5 is
return Result; return Result;
end Make_Field_Assigns; 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 -- Start of processing for Expand_Assign_Record
begin begin
......
gcc/ada/prj-attr.adb
...@@ -91,6 +91,12 @@ package body Prj.Attr is ...@@ -91,6 +91,12 @@ package body Prj.Attr is
"SVexcluded_source_list_file#" & "SVexcluded_source_list_file#" &
"LVinterfaces#" & "LVinterfaces#" &
-- Projects (in aggregate projects)
"LVproject_files#" &
"LVproject_path#" &
"SAexternal#" &
-- Libraries -- Libraries
"SVlibrary_dir#" & "SVlibrary_dir#" &
...@@ -147,18 +153,20 @@ package body Prj.Attr is ...@@ -147,18 +153,20 @@ package body Prj.Attr is
"Saruntime_source_dir#" & "Saruntime_source_dir#" &
-- package Naming -- package Naming
-- Some attributes are obsolescent, and renamed in the tree (see
-- Prj.Dect.Rename_Obsolescent_Attributes).
"Pnaming#" & "Pnaming#" &
"Saspecification_suffix#" & "Saspecification_suffix#" & -- Always renamed to "spec_suffix" in tree
"Saspec_suffix#" & "Saspec_suffix#" &
"Saimplementation_suffix#" & "Saimplementation_suffix#" & -- Always renamed to "body_suffix" in tree
"Sabody_suffix#" & "Sabody_suffix#" &
"SVseparate_suffix#" & "SVseparate_suffix#" &
"SVcasing#" & "SVcasing#" &
"SVdot_replacement#" & "SVdot_replacement#" &
"sAspecification#" & "sAspecification#" & -- Always renamed to "spec" in project tree
"sAspec#" & "sAspec#" &
"sAimplementation#" & "sAimplementation#" & -- Always renamed to "body" in project tree
"sAbody#" & "sAbody#" &
"Laspecification_exceptions#" & "Laspecification_exceptions#" &
"Laimplementation_exceptions#" & "Laimplementation_exceptions#" &
......
gcc/ada/prj-dect.adb
...@@ -48,6 +48,31 @@ package body Prj.Dect is ...@@ -48,6 +48,31 @@ package body Prj.Dect is
-- a case construction (In_Case_Construction) or none of those two -- a case construction (In_Case_Construction) or none of those two
-- (In_Project). -- (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 procedure Parse_Attribute_Declaration
(In_Tree : Project_Node_Tree_Ref; (In_Tree : Project_Node_Tree_Ref;
Attribute : out Project_Node_Id; Attribute : out Project_Node_Id;
...@@ -147,6 +172,111 @@ package body Prj.Dect is ...@@ -147,6 +172,111 @@ package body Prj.Dect is
(Declarations, In_Tree, To => First_Declarative_Item); (Declarations, In_Tree, To => First_Declarative_Item);
end Parse; 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 -- -- Parse_Attribute_Declaration --
--------------------------------- ---------------------------------
...@@ -165,37 +295,28 @@ package body Prj.Dect is ...@@ -165,37 +295,28 @@ package body Prj.Dect is
Attribute_Name : Name_Id := No_Name; Attribute_Name : Name_Id := No_Name;
Optional_Index : Boolean := False; Optional_Index : Boolean := False;
Pkg_Id : Package_Node_Id := Empty_Package; 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);
-- Scan past "for" procedure Process_Attribute_Name;
-- Read the name of the attribute, and check its type
Scan (In_Tree); procedure Process_Associative_Array_Index;
-- Read the index of the associative array and check its validity
-- Body may be an attribute name
if Token = Tok_Body then ----------------------------
Token := Tok_Identifier; -- Process_Attribute_Name --
Token_Name := Snames.Name_Body; ----------------------------
end if;
Expect (Tok_Identifier, "identifier"); procedure Process_Attribute_Name is
Ignore : Boolean;
if Token = Tok_Identifier then begin
Attribute_Name := Token_Name; 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); Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
-- Find the attribute -- Find the attribute
Current_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 -- If the attribute cannot be found, create the attribute if inside
-- an unknown package. -- an unknown package.
...@@ -254,35 +375,22 @@ package body Prj.Dect is ...@@ -254,35 +375,22 @@ package body Prj.Dect is
end if; end if;
Scan (In_Tree); -- past the attribute name Scan (In_Tree); -- past the attribute name
end if;
-- Change obsolete names of attributes to the new names
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 the expression kind of the attribute
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 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;
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 -- If the attribute is not an associative array attribute, report
-- an error. If this information is still unknown, set the kind -- an error. If this information is still unknown, set the kind
-- to Associative_Array. -- to Associative_Array.
...@@ -292,9 +400,8 @@ package body Prj.Dect is ...@@ -292,9 +400,8 @@ package body Prj.Dect is
then then
Error_Msg (Flags, Error_Msg (Flags,
"the attribute """ & "the attribute """ &
Get_Name_String Get_Name_String (Attribute_Name_Of (Current_Attribute))
(Attribute_Name_Of (Current_Attribute)) & & """ cannot be an associative array",
""" cannot be an associative array",
Location_Of (Attribute, In_Tree)); Location_Of (Attribute, In_Tree));
elsif Attribute_Kind_Of (Current_Attribute) = Unknown then elsif Attribute_Kind_Of (Current_Attribute) = Unknown then
...@@ -371,6 +478,35 @@ package body Prj.Dect is ...@@ -371,6 +478,35 @@ package body Prj.Dect is
if Token = Tok_Right_Paren then if Token = Tok_Right_Paren then
Scan (In_Tree); -- past the right parenthesis Scan (In_Tree); -- past the right parenthesis
end if; 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 else
-- If it is an associative array attribute and there are no left -- If it is an associative array attribute and there are no left
...@@ -390,14 +526,6 @@ package body Prj.Dect is ...@@ -390,14 +526,6 @@ package body Prj.Dect is
end if; end if;
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"); Expect (Tok_Use, "USE");
if Token = Tok_Use then if Token = Tok_Use then
...@@ -1149,6 +1277,9 @@ package body Prj.Dect is ...@@ -1149,6 +1277,9 @@ package body Prj.Dect is
Scan (In_Tree); Scan (In_Tree);
end if; end if;
Check_Package_Allowed
(In_Tree, Current_Project, Package_Declaration, Flags);
if Token = Tok_Renames then if Token = Tok_Renames then
Renaming := True; Renaming := True;
elsif Token = Tok_Extends then elsif Token = Tok_Extends then
......
gcc/ada/prj-nmsc.adb
...@@ -282,6 +282,16 @@ package body Prj.Nmsc is ...@@ -282,6 +282,16 @@ package body Prj.Nmsc is
-- Check the library attributes of project Project in project tree -- Check the library attributes of project Project in project tree
-- and modify its data Data accordingly. -- 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 procedure Check_Programming_Languages
(Project : Project_Id; (Project : Project_Id;
Data : in out Tree_Processing_Data); Data : in out Tree_Processing_Data);
...@@ -432,9 +442,8 @@ package body Prj.Nmsc is ...@@ -432,9 +442,8 @@ package body Prj.Nmsc is
(Project : in out Project_Processing_Data; (Project : in out Project_Processing_Data;
Data : in out Tree_Processing_Data); Data : in out Tree_Processing_Data);
-- Find all the sources of project Project in project tree Data.Tree and -- Find all the sources of project Project in project tree Data.Tree and
-- update its Data accordingly. This assumes that Data.First_Source has -- update its Data accordingly. This assumes that the special naming
-- been initialized with the list of excluded sources and special naming -- exceptions have already been processed.
-- exceptions.
function Path_Name_Of function Path_Name_Of
(File_Name : File_Name_Type; (File_Name : File_Name_Type;
...@@ -854,6 +863,73 @@ package body Prj.Nmsc is ...@@ -854,6 +863,73 @@ package body Prj.Nmsc is
end if; end if;
end Canonical_Case_File_Name; 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 -- -- Check --
----------- -----------
...@@ -862,60 +938,20 @@ package body Prj.Nmsc is ...@@ -862,60 +938,20 @@ package body Prj.Nmsc is
(Project : Project_Id; (Project : Project_Id;
Data : in out Tree_Processing_Data) Data : in out Tree_Processing_Data)
is is
Extending : Boolean := False;
Prj_Data : Project_Processing_Data; Prj_Data : Project_Processing_Data;
begin begin
Initialize (Prj_Data, Project); Initialize (Prj_Data, Project);
Check_If_Externally_Built (Project, Data); Check_If_Externally_Built (Project, Data);
Get_Directories (Project, Data);
-- Object, exec and source directories
Get_Directories (Project, Data);
-- Get the programming languages
Check_Programming_Languages (Project, Data); Check_Programming_Languages (Project, Data);
if Project.Qualifier = Dry case Project.Qualifier is
and then Project.Source_Dirs /= Nil_String when Aggregate => Check_Aggregate_Project (Project, Data);
then when Dry => Check_Abstract_Project (Project, Data);
declare when others => null;
Source_Dirs : constant Variable_Value := end case;
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;
-- Check configuration. This must be done even for gnatmake (even though -- Check configuration. This must be done even for gnatmake (even though
-- no user configuration file was provided) since the default config we -- no user configuration file was provided) since the default config we
...@@ -923,91 +959,24 @@ package body Prj.Nmsc is ...@@ -923,91 +959,24 @@ package body Prj.Nmsc is
Check_Configuration (Project, Data); Check_Configuration (Project, Data);
-- Library attributes
Check_Library_Attributes (Project, Data); Check_Library_Attributes (Project, Data);
if Current_Verbosity = High then if Current_Verbosity = High then
Show_Source_Dirs (Project, Data.Tree); Show_Source_Dirs (Project, Data.Tree);
end if; end if;
Extending := Project.Extends /= No_Project;
Check_Package_Naming (Project, Data); Check_Package_Naming (Project, Data);
-- Find the sources if Project.Qualifier /= Aggregate then
if Project.Source_Dirs /= Nil_String then
Look_For_Sources (Prj_Data, Data); 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; 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); Check_Interfaces (Project, Data);
-- If it is a library project file, check if it is a standalone library
if Project.Library then if Project.Library then
Check_Stand_Alone_Library (Project, Data); Check_Stand_Alone_Library (Project, Data);
end if; end if;
-- Put the list of Mains, if any, in the project data
Get_Mains (Project, Data); Get_Mains (Project, Data);
Free (Prj_Data); Free (Prj_Data);
...@@ -7242,6 +7211,68 @@ package body Prj.Nmsc is ...@@ -7242,6 +7211,68 @@ package body Prj.Nmsc is
procedure Mark_Excluded_Sources; procedure Mark_Excluded_Sources;
-- Mark as such the sources that are declared as excluded -- 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 -- -- Check_Object --
------------------ ------------------
...@@ -7416,13 +7447,16 @@ package body Prj.Nmsc is ...@@ -7416,13 +7447,16 @@ package body Prj.Nmsc is
-- Start of processing for Look_For_Sources -- Start of processing for Look_For_Sources
begin 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); if Project.Project.Languages /= No_Language_Index then
Find_Sources (Project, Data); Load_Naming_Exceptions (Project, Data);
Mark_Excluded_Sources; Find_Sources (Project, Data);
Check_Object_Files; Mark_Excluded_Sources;
Check_Object_Files;
Check_Missing_Sources;
end if;
end if; end if;
Object_File_Names_Htable.Reset (Object_Files); Object_File_Names_Htable.Reset (Object_Files);
......
gcc/ada/prj-part.adb
...@@ -125,8 +125,37 @@ package body Prj.Part is ...@@ -125,8 +125,37 @@ package body Prj.Part is
Key => Name_Id, Key => Name_Id,
Hash => Hash, Hash => Hash,
Equal => "="); 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 -- 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 procedure Create_Virtual_Extending_Project
(For_Project : Project_Node_Id; (For_Project : Project_Node_Id;
Main_Project : Project_Node_Id; Main_Project : Project_Node_Id;
...@@ -916,6 +945,185 @@ package body Prj.Part is ...@@ -916,6 +945,185 @@ package body Prj.Part is
end loop; end loop;
end Post_Parse_Context_Clause; 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 -- -- Parse_Single_Project --
-------------------------- --------------------------
...@@ -962,7 +1170,6 @@ package body Prj.Part is ...@@ -962,7 +1170,6 @@ package body Prj.Part is
Project_Comment_State : Tree.Comment_State; Project_Comment_State : Tree.Comment_State;
Proj_Qualifier : Project_Qualifier := Unspecified;
Qualifier_Location : Source_Ptr; Qualifier_Location : Source_Ptr;
begin begin
...@@ -988,38 +1195,12 @@ package body Prj.Part is ...@@ -988,38 +1195,12 @@ package body Prj.Part is
Canonical_Path_Name := Name_Find; Canonical_Path_Name := Name_Find;
end; end;
-- Check for a circular dependency if Has_Circular_Dependencies
(Flags, Normed_Path_Name, Canonical_Path_Name)
for Index in reverse 1 .. Project_Stack.Last loop then
exit when Project_Stack.Table (Index).Limited_With; Project := Empty_Node;
return;
if Canonical_Path_Name = end if;
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;
-- Put the new path name on the stack -- Put the new path name on the stack
...@@ -1156,73 +1337,8 @@ package body Prj.Part is ...@@ -1156,73 +1337,8 @@ package body Prj.Part is
Set_Directory_Of (Project, In_Tree, Project_Directory); Set_Directory_Of (Project, In_Tree, Project_Directory);
Set_Path_Name_Of (Project, In_Tree, Normed_Path_Name); Set_Path_Name_Of (Project, In_Tree, Normed_Path_Name);
-- Check if there is a qualifier before the reserved word "project" Read_Project_Qualifier
(Flags, In_Tree, Is_Config_File, Qualifier_Location, 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;
Set_Location_Of (Project, In_Tree, Token_Ptr); Set_Location_Of (Project, In_Tree, Token_Ptr);
...@@ -1513,7 +1629,7 @@ package body Prj.Part is ...@@ -1513,7 +1629,7 @@ package body Prj.Part is
-- with sources, if it inherits sources from the project -- with sources, if it inherits sources from the project
-- it extends. -- 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 Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry
then then
Error_Msg Error_Msg
...@@ -1529,31 +1645,8 @@ package body Prj.Part is ...@@ -1529,31 +1645,8 @@ package body Prj.Part is
end if; end if;
end if; end if;
-- Check that a non extending-all project does not import an Check_Extending_All_Imports (Flags, In_Tree, Project);
-- extending-all project. Check_Aggregate_Imports (Flags, In_Tree, 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 that a project with a name including a dot either imports -- Check that a project with a name including a dot either imports
-- or extends the project whose name precedes the last dot. -- or extends the project whose name precedes the last dot.
...@@ -1571,7 +1664,7 @@ package body Prj.Part is ...@@ -1571,7 +1664,7 @@ package body Prj.Part is
Name_Len := Name_Len - 1; Name_Len := Name_Len - 1;
end loop; 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. -- or extended.
if Name_Len > 0 then if Name_Len > 0 then
...@@ -1728,7 +1821,7 @@ package body Prj.Part is ...@@ -1728,7 +1821,7 @@ package body Prj.Part is
Node => Project, Node => Project,
Canonical_Path => Canonical_Path_Name, Canonical_Path => Canonical_Path_Name,
Extended => Extended, Extended => Extended,
Proj_Qualifier => Proj_Qualifier)); Proj_Qualifier => Project_Qualifier_Of (Project, In_Tree)));
end if; end if;
declare declare
......
gcc/ada/snames.ads-tmpl
...@@ -1133,6 +1133,8 @@ package Snames is ...@@ -1133,6 +1133,8 @@ package Snames is
Name_Prefix : constant Name_Id := N + $; Name_Prefix : constant Name_Id := N + $;
Name_Project : constant Name_Id := N + $; Name_Project : constant Name_Id := N + $;
Name_Project_Dir : 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_Format : constant Name_Id := N + $;
Name_Response_File_Switches : constant Name_Id := N + $; Name_Response_File_Switches : constant Name_Id := N + $;
Name_Roots : constant Name_Id := N + $; -- GPR Name_Roots : constant Name_Id := N + $; -- GPR
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment