+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
-- 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;
Alts : List_Id;
DC : Node_Id;
DCH : List_Id;
+ Expr : Node_Id;
Result : List_Id;
V : Node_Id;
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;
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
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
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
"SVexcluded_source_list_file#" &
"LVinterfaces#" &
+ -- Projects (in aggregate projects)
+
+ "LVproject_files#" &
+ "LVproject_path#" &
+ "SAexternal#" &
+
-- Libraries
"SVlibrary_dir#" &
"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#" &
-- 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;
(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 --
---------------------------------
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);
- -- Scan past "for"
+ procedure Process_Attribute_Name;
+ -- Read the name of the attribute, and check its type
- Scan (In_Tree);
-
- -- Body may be an attribute name
+ procedure Process_Associative_Array_Index;
+ -- Read the index of the associative array and check its validity
- if Token = Tok_Body then
- Token := Tok_Identifier;
- Token_Name := Snames.Name_Body;
- end if;
+ ----------------------------
+ -- Process_Attribute_Name --
+ ----------------------------
- 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.
end if;
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_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;
+ -- Set the expression kind of the attribute
- -- 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
-- an error. If this information is still unknown, set the kind
-- to Associative_Array.
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
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
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
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
-- 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);
(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;
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 --
-----------
(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
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);
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 --
------------------
-- Start of processing for Look_For_Sources
begin
- 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.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;
+ Check_Missing_Sources;
+ end if;
end if;
Object_File_Names_Htable.Reset (Object_Files);
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;
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 --
--------------------------
Project_Comment_State : Tree.Comment_State;
- Proj_Qualifier : Project_Qualifier := Unspecified;
Qualifier_Location : Source_Ptr;
begin
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
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);
-- 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
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.
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
Node => Project,
Canonical_Path => Canonical_Path_Name,
Extended => Extended,
- Proj_Qualifier => Proj_Qualifier));
+ Proj_Qualifier => Project_Qualifier_Of (Project, In_Tree)));
end if;
declare
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
OSDN Git Service
