with Prj.Err; use Prj.Err;
with Prj.Ext; use Prj.Ext;
with Prj.Nmsc; use Prj.Nmsc;
-with Sinput; use Sinput;
with Snames;
with GNAT.Case_Util; use GNAT.Case_Util;
package body Prj.Proc is
- Error_Report : Put_Line_Access := null;
-
package Processed_Projects is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num,
Element => Project_Id,
-- the package or project with declarations Decl.
procedure Check
- (In_Tree : Project_Tree_Ref;
- Project : Project_Id;
- Current_Dir : String;
- When_No_Sources : Error_Warning);
+ (In_Tree : Project_Tree_Ref;
+ Project : Project_Id;
+ Flags : Processing_Flags);
-- Set all projects to not checked, then call Recursive_Check for the
-- main project Project. Project is set to No_Project if errors occurred.
-- Current_Dir is for optimization purposes, avoiding extra system calls.
+ -- If Allow_Duplicate_Basenames, then files with the same base names are
+ -- authorized within a project for source-based languages (never for unit
+ -- based languages)
procedure Copy_Package_Declarations
(From : Declarations;
function Expression
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
+ Flags : Processing_Flags;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Pkg : Package_Id;
procedure Process_Declarative_Items
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
+ Flags : Processing_Flags;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Pkg : Package_Id;
procedure Recursive_Process
(In_Tree : Project_Tree_Ref;
Project : out Project_Id;
+ Flags : Processing_Flags;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Extended_By : Project_Id);
-- extended project, if any. Then process the declarative items of the
-- project.
- type Recursive_Check_Data is record
- In_Tree : Project_Tree_Ref;
- Current_Dir : String_Access;
- When_No_Sources : Error_Warning;
- Proc_Data : Processing_Data;
- end record;
- -- Data passed to Recursive_Check
- -- Current_Dir is for optimization purposes, avoiding extra system calls.
-
- procedure Recursive_Check
- (Project : Project_Id;
- Data : in out Recursive_Check_Data);
- -- Check_Naming_Scheme for the project
+ function Get_Attribute_Index
+ (Tree : Project_Node_Tree_Ref;
+ Attr : Project_Node_Id;
+ Index : Name_Id) return Name_Id;
+ -- Copy the index of the attribute into Name_Buffer, converting to lower
+ -- case if the attribute is case-insensitive.
---------
-- Add --
elsif Str /= No_Name and then Str /= Empty_String then
declare
S : constant String := Get_Name_String (Str);
-
begin
Get_Name_String (To_Exp);
Add_Str_To_Name_Buffer (S);
-----------
procedure Check
- (In_Tree : Project_Tree_Ref;
- Project : Project_Id;
- Current_Dir : String;
- When_No_Sources : Error_Warning)
+ (In_Tree : Project_Tree_Ref;
+ Project : Project_Id;
+ Flags : Processing_Flags)
is
- Dir : aliased String := Current_Dir;
-
- procedure Check_All_Projects is new
- For_Every_Project_Imported (Recursive_Check_Data, Recursive_Check);
-
- Data : Recursive_Check_Data;
-
begin
- Data.In_Tree := In_Tree;
- Data.Current_Dir := Dir'Unchecked_Access;
- Data.When_No_Sources := When_No_Sources;
- Initialize (Data.Proc_Data);
-
- Check_All_Projects (Project, Data, Imported_First => True);
+ Process_Naming_Scheme (In_Tree, Project, Flags);
-- Set the Other_Part field for the units
Source1 := Prj.Element (Iter);
exit when Source1 = No_Source;
- Name := Source1.Unit;
-
- if Name /= No_Name then
+ if Source1.Unit /= No_Unit_Index then
+ Name := Source1.Unit.Name;
Source2 := Unit_Htable.Get (Name);
if Source2 = No_Source then
Unit_Htable.Set (K => Name, E => Source1);
-
else
Unit_Htable.Remove (Name);
- Source1.Other_Part := Source2;
- Source2.Other_Part := Source1;
end if;
end if;
Next (Iter);
end loop;
end;
-
- Free (Data.Proc_Data);
end Check;
-------------------------------
if To.Attributes = No_Variable then
To.Attributes :=
Variable_Element_Table.Last (In_Tree.Variable_Elements);
-
else
In_Tree.Variable_Elements.Table (V2).Next :=
Variable_Element_Table.Last (In_Tree.Variable_Elements);
if To.Arrays = No_Array then
To.Arrays := Array_Table.Last (In_Tree.Arrays);
-
else
In_Tree.Arrays.Table (A2).Next :=
Array_Table.Last (In_Tree.Arrays);
end loop;
end Copy_Package_Declarations;
+ -------------------------
+ -- Get_Attribute_Index --
+ -------------------------
+
+ function Get_Attribute_Index
+ (Tree : Project_Node_Tree_Ref;
+ Attr : Project_Node_Id;
+ Index : Name_Id) return Name_Id
+ is
+ Lower : Boolean;
+
+ begin
+ Get_Name_String (Index);
+ Lower := Case_Insensitive (Attr, Tree);
+
+ -- The index is always case insensitive if it does not include any dot.
+ -- ??? Why not use the properties from prj-attr, simply, maybe because
+ -- we don't know whether we have a file as an index?
+
+ if not Lower then
+ Lower := True;
+
+ for J in 1 .. Name_Len loop
+ if Name_Buffer (J) = '.' then
+ Lower := False;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ if Lower then
+ To_Lower (Name_Buffer (1 .. Name_Len));
+ return Name_Find;
+ else
+ return Index;
+ end if;
+ end Get_Attribute_Index;
+
----------------
-- Expression --
----------------
function Expression
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
+ Flags : Processing_Flags;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Pkg : Package_Id;
First_Term : Project_Node_Id;
Kind : Variable_Kind) return Variable_Value
is
- The_Term : Project_Node_Id := First_Term;
+ The_Term : Project_Node_Id;
-- The term in the expression list
The_Current_Term : Project_Node_Id := Empty_Node;
-- Process each term of the expression, starting with First_Term
+ The_Term := First_Term;
while Present (The_Term) loop
The_Current_Term := Current_Term (The_Term, From_Project_Node_Tree);
Value := Expression
(Project => Project,
In_Tree => In_Tree,
+ Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => Pkg,
Expression
(Project => Project,
In_Tree => In_Tree,
+ Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => Pkg,
The_Array : Array_Id := No_Array;
The_Element : Array_Element_Id := No_Array_Element;
Array_Index : Name_Id := No_Name;
- Lower : Boolean;
begin
if The_Package /= No_Package then
if The_Array /= No_Array then
The_Element := In_Tree.Arrays.Table
(The_Array).Value;
-
- Get_Name_String (Index);
-
- Lower :=
- Case_Insensitive
- (The_Current_Term, From_Project_Node_Tree);
-
- -- In multi-language mode (gprbuild), the index is
- -- always case insensitive if it does not include
- -- any dot.
-
- if Get_Mode = Multi_Language and then not Lower then
- Lower := True;
-
- for J in 1 .. Name_Len loop
- if Name_Buffer (J) = '.' then
- Lower := False;
- exit;
- end if;
- end loop;
- end if;
-
- if Lower then
- To_Lower (Name_Buffer (1 .. Name_Len));
- end if;
-
- Array_Index := Name_Find;
+ Array_Index :=
+ Get_Attribute_Index
+ (From_Project_Node_Tree,
+ The_Current_Term,
+ Index);
while The_Element /= No_Array_Element
and then
Def_Var := Expression
(Project => Project,
In_Tree => In_Tree,
+ Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => Pkg,
end if;
end if;
- Value := Prj.Ext.Value_Of (Name, Default);
+ Value :=
+ Prj.Ext.Value_Of (From_Project_Node_Tree, Name, Default);
if Value = No_Name then
if not Quiet_Output then
- if Error_Report = null then
- Error_Msg
- ("?undefined external reference",
- Location_Of
- (The_Current_Term, From_Project_Node_Tree));
- else
- Error_Report
- ("warning: """ & Get_Name_String (Name) &
- """ is an undefined external reference",
- Project, In_Tree);
- end if;
+ Error_Msg
+ (Flags, "?undefined external reference",
+ Location_Of
+ (The_Current_Term, From_Project_Node_Tree),
+ Project);
end if;
Value := Empty_String;
Success : out Boolean;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
- Report_Error : Put_Line_Access;
- When_No_Sources : Error_Warning := Error;
- Reset_Tree : Boolean := True;
- Current_Dir : String := "")
+ Flags : Processing_Flags;
+ Reset_Tree : Boolean := True)
is
begin
Process_Project_Tree_Phase_1
Success => Success,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
- Report_Error => Report_Error,
+ Flags => Flags,
Reset_Tree => Reset_Tree);
- if not In_Configuration then
+ if Project_Qualifier_Of (From_Project_Node, From_Project_Node_Tree) /=
+ Configuration
+ then
Process_Project_Tree_Phase_2
(In_Tree => In_Tree,
Project => Project,
Success => Success,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
- Report_Error => Report_Error,
- When_No_Sources => When_No_Sources,
- Current_Dir => Current_Dir);
+ Flags => Flags);
end if;
end Process;
procedure Process_Declarative_Items
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
+ Flags : Processing_Flags;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Pkg : Package_Id;
Process_Declarative_Items
(Project => Project,
In_Tree => In_Tree,
+ Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => New_Pkg,
end loop;
if Orig_Array = No_Array then
- if Error_Report = null then
- Error_Msg
- ("associative array value not found",
- Location_Of
- (Current_Item, From_Project_Node_Tree));
- else
- Error_Report
- ("associative array value not found",
- Project, In_Tree);
- end if;
+ Error_Msg
+ (Flags,
+ "associative array value not found",
+ Location_Of (Current_Item, From_Project_Node_Tree),
+ Project);
else
Orig_Element :=
Expression
(Project => Project,
In_Tree => In_Tree,
+ Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => Pkg,
if New_Value.Value = Empty_String then
Error_Msg_Name_1 :=
Name_Of (Current_Item, From_Project_Node_Tree);
-
- if Error_Report = null then
- Error_Msg
- ("no value defined for %%",
- Location_Of
- (Current_Item, From_Project_Node_Tree));
- else
- Error_Report
- ("no value defined for " &
- Get_Name_String (Error_Msg_Name_1),
- Project, In_Tree);
- end if;
+ Error_Msg
+ (Flags,
+ "no value defined for %%",
+ Location_Of
+ (Current_Item, From_Project_Node_Tree),
+ Project);
else
declare
Error_Msg_Name_2 :=
Name_Of
(Current_Item, From_Project_Node_Tree);
-
- if Error_Report = null then
- Error_Msg
- ("value %% is illegal " &
- "for typed string %%",
- Location_Of
- (Current_Item,
- From_Project_Node_Tree));
-
- else
- Error_Report
- ("value """ &
- Get_Name_String (Error_Msg_Name_1) &
- """ is illegal for typed string """ &
- Get_Name_String (Error_Msg_Name_2) &
- """",
- Project, In_Tree);
- end if;
+ Error_Msg
+ (Flags,
+ "value %% is illegal for typed string %%",
+ Location_Of
+ (Current_Item, From_Project_Node_Tree),
+ Project);
end if;
end;
end if;
pragma Assert
(Kind_Of (Current_Item, From_Project_Node_Tree) /=
N_Attribute_Declaration,
- "illegal attribute declaration");
+ "illegal attribute declaration for "
+ & Get_Name_String (Current_Item_Name));
Variable_Element_Table.Increment_Last
(In_Tree.Variable_Elements);
else
declare
Index_Name : Name_Id :=
- Associative_Array_Index_Of
- (Current_Item, From_Project_Node_Tree);
- Lower : Boolean;
- The_Array : Array_Id;
+ Associative_Array_Index_Of
+ (Current_Item,
+ From_Project_Node_Tree);
+ Source_Index : constant Int :=
+ Source_Index_Of
+ (Current_Item,
+ From_Project_Node_Tree);
+
+ The_Array : Array_Id;
The_Array_Element : Array_Element_Id :=
No_Array_Element;
begin
if Index_Name /= All_Other_Names then
- -- Get the string index
-
- Get_Name_String
- (Associative_Array_Index_Of
+ Index_Name := Get_Attribute_Index
+ (From_Project_Node_Tree,
+ Current_Item,
+ Associative_Array_Index_Of
(Current_Item, From_Project_Node_Tree));
-
- -- Put in lower case, if necessary
-
- Lower :=
- Case_Insensitive
- (Current_Item, From_Project_Node_Tree);
-
- -- In multi-language mode (gprbuild), the index
- -- is always case insensitive if it does not
- -- include any dot.
-
- if Get_Mode = Multi_Language
- and then not Lower
- then
- for J in 1 .. Name_Len loop
- if Name_Buffer (J) = '.' then
- Lower := False;
- exit;
- end if;
- end loop;
- end if;
-
- if Lower then
- GNAT.Case_Util.To_Lower
- (Name_Buffer (1 .. Name_Len));
- end if;
-
- Index_Name := Name_Find;
end if;
-- Look for the array in the appropriate list
if Pkg /= No_Package then
The_Array :=
In_Tree.Packages.Table (Pkg).Decl.Arrays;
-
else
- The_Array := Project.Decl.Arrays;
+ The_Array :=
+ Project.Decl.Arrays;
end if;
while
In_Tree.Arrays.Table (The_Array).Name /=
Current_Item_Name
loop
- The_Array := In_Tree.Arrays.Table
- (The_Array).Next;
+ The_Array :=
+ In_Tree.Arrays.Table (The_Array).Next;
end loop;
-- If the array cannot be found, create a new entry
end if;
-- Look in the list, if any, to find an element
- -- with the same index.
+ -- with the same index and same source index.
while The_Array_Element /= No_Array_Element
and then
- In_Tree.Array_Elements.Table
+ (In_Tree.Array_Elements.Table
(The_Array_Element).Index /= Index_Name
+ or else
+ In_Tree.Array_Elements.Table
+ (The_Array_Element).Src_Index /= Source_Index)
loop
The_Array_Element :=
In_Tree.Array_Elements.Table
if The_Array_Element = No_Array_Element then
Array_Element_Table.Increment_Last
(In_Tree.Array_Elements);
- The_Array_Element := Array_Element_Table.Last
- (In_Tree.Array_Elements);
+ The_Array_Element :=
+ Array_Element_Table.Last
+ (In_Tree.Array_Elements);
In_Tree.Array_Elements.Table
(The_Array_Element) :=
- (Index => Index_Name,
- Src_Index =>
- Source_Index_Of
- (Current_Item, From_Project_Node_Tree),
+ (Index => Index_Name,
+ Src_Index => Source_Index,
Index_Case_Sensitive =>
not Case_Insensitive
(Current_Item, From_Project_Node_Tree),
- Value => New_Value,
- Next => In_Tree.Arrays.Table
- (The_Array).Value);
- In_Tree.Arrays.Table
- (The_Array).Value := The_Array_Element;
+ Value => New_Value,
+ Next =>
+ In_Tree.Arrays.Table (The_Array).Value);
+
+ In_Tree.Arrays.Table (The_Array).Value :=
+ The_Array_Element;
-- An element with the same index already exists,
-- just replace its value with the new one.
Process_Declarative_Items
(Project => Project,
In_Tree => In_Tree,
+ Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => Pkg,
Success : out Boolean;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
- Report_Error : Put_Line_Access;
+ Flags : Processing_Flags;
Reset_Tree : Boolean := True)
is
begin
- Error_Report := Report_Error;
-
if Reset_Tree then
-- Make sure there are no projects in the data structure
Recursive_Process
(Project => Project,
In_Tree => In_Tree,
+ Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Extended_By => No_Project);
Success : out Boolean;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
- Report_Error : Put_Line_Access;
- When_No_Sources : Error_Warning := Error;
- Current_Dir : String)
+ Flags : Processing_Flags)
is
Obj_Dir : Path_Name_Type;
Extending : Project_Id;
-- Start of processing for Process_Project_Tree_Phase_2
begin
- Error_Report := Report_Error;
Success := True;
if Project /= No_Project then
- Check (In_Tree, Project, Current_Dir, When_No_Sources);
+ Check (In_Tree, Project, Flags);
end if;
- -- If main project is an extending all project, set the object
- -- directory of all virtual extending projects to the object
- -- directory of the main project.
+ -- If main project is an extending all project, set object directory of
+ -- all virtual extending projects to object directory of main project.
if Project /= No_Project
and then
then
if Extending2.Virtual then
Error_Msg_Name_1 := Prj.Project.Display_Name;
-
- if Error_Report = null then
- Error_Msg
- ("project %% cannot be extended by a virtual" &
- " project with the same object directory",
- Prj.Project.Location);
- else
- Error_Report
- ("project """ &
- Get_Name_String (Error_Msg_Name_1) &
- """ cannot be extended by a virtual " &
- "project with the same object directory",
- Project, In_Tree);
- end if;
+ Error_Msg
+ (Flags,
+ "project %% cannot be extended by a virtual" &
+ " project with the same object directory",
+ Prj.Project.Location, Project);
else
Error_Msg_Name_1 := Extending2.Display_Name;
Error_Msg_Name_2 := Prj.Project.Display_Name;
-
- if Error_Report = null then
- Error_Msg
- ("project %% cannot extend project %%",
- Extending2.Location);
- Error_Msg
- ("\they share the same object directory",
- Extending2.Location);
-
- else
- Error_Report
- ("project """ &
- Get_Name_String (Error_Msg_Name_1) &
- """ cannot extend project """ &
- Get_Name_String (Error_Msg_Name_2) & """",
- Project, In_Tree);
- Error_Report
- ("they share the same object directory",
- Project, In_Tree);
- end if;
+ Error_Msg
+ (Flags,
+ "project %% cannot extend project %%",
+ Extending2.Location, Project);
+ Error_Msg
+ (Flags,
+ "\they share the same object directory",
+ Extending2.Location, Project);
end if;
end if;
(Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0);
end Process_Project_Tree_Phase_2;
- ---------------------
- -- Recursive_Check --
- ---------------------
-
- procedure Recursive_Check
- (Project : Project_Id;
- Data : in out Recursive_Check_Data)
- is
- begin
- if Verbose_Mode then
- Write_Str ("Checking project file """);
- Write_Str (Get_Name_String (Project.Name));
- Write_Line ("""");
- end if;
-
- Prj.Nmsc.Check
- (Project, Data.In_Tree, Error_Report, Data.When_No_Sources,
- Data.Current_Dir.all, Data.Proc_Data);
- end Recursive_Check;
-
-----------------------
-- Recursive_Process --
-----------------------
procedure Recursive_Process
(In_Tree : Project_Tree_Ref;
Project : out Project_Id;
+ Flags : Processing_Flags;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Extended_By : Project_Id)
(With_Clause, From_Project_Node_Tree);
New_Project := No_Project;
- if (Limited_With and No (Proj_Node))
- or (not Limited_With and Present (Proj_Node))
+ if (Limited_With and then No (Proj_Node))
+ or else (not Limited_With and then Present (Proj_Node))
then
Recursive_Process
(In_Tree => In_Tree,
Project => New_Project,
+ Flags => Flags,
From_Project_Node =>
Project_Node_Of
(With_Clause, From_Project_Node_Tree),
declare
Imported : Project_List;
Declaration_Node : Project_Node_Id := Empty_Node;
- Tref : Source_Buffer_Ptr;
- Name : constant Name_Id :=
- Name_Of
- (From_Project_Node, From_Project_Node_Tree);
- Location : Source_Ptr :=
- Location_Of
- (From_Project_Node, From_Project_Node_Tree);
+
+ Name : constant Name_Id :=
+ Name_Of (From_Project_Node, From_Project_Node_Tree);
+
+ Name_Node : constant Tree_Private_Part.Project_Name_And_Node :=
+ Tree_Private_Part.Projects_Htable.Get
+ (From_Project_Node_Tree.Projects_HT, Name);
begin
Project := Processed_Projects.Get (Name);
return;
end if;
- Project := new Project_Data'(Empty_Project (In_Tree));
+ Project := new Project_Data'(Empty_Project);
In_Tree.Projects := new Project_List_Element'
(Project => Project,
Next => In_Tree.Projects);
Processed_Projects.Set (Name, Project);
Project.Name := Name;
+ Project.Display_Name := Name_Node.Display_Name;
Project.Qualifier :=
Project_Qualifier_Of (From_Project_Node, From_Project_Node_Tree);
Virtual_Prefix
then
Project.Virtual := True;
- Project.Display_Name := Name;
-
- -- If there is no file, for example when the project node tree is
- -- built in memory by GPS, the Display_Name cannot be found in
- -- the source, so its value is the same as Name.
-
- elsif Location = No_Location then
- Project.Display_Name := Name;
-
- -- Get the spelling of the project name from the project file
-
- else
- Tref := Source_Text (Get_Source_File_Index (Location));
-
- for J in 1 .. Name_Len loop
- Name_Buffer (J) := Tref (Location);
- Location := Location + 1;
- end loop;
- Project.Display_Name := Name_Find;
end if;
Project.Path.Display_Name :=
Recursive_Process
(In_Tree => In_Tree,
Project => Project.Extends,
+ Flags => Flags,
From_Project_Node => Extended_Project_Of
(Declaration_Node,
From_Project_Node_Tree),
Process_Declarative_Items
(Project => Project,
In_Tree => In_Tree,
+ Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => No_Package,
OSDN Git Service
