MatCat.OpenSource/8sa1-gcc
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
cb4af25a80
8sa1-gcc/gcc/ada/prj-proc.adb
Vincent Celier ddd6e5ae32 prj-nmsc.adb (Check_Ada_Name): For children of package A... 
2006-10-31  Vincent Celier  <celier@adacore.com>

	* prj-nmsc.adb (Check_Ada_Name): For children of package A, G, I and S
	on VMS, change "__" to '.' before checking the name.
	(Record_Ada_Source): Always add the source file name in the list of
	of sources, even if it is not the first time, as it is for another
	source index.
	(Get_Unit): Replace both '_' (after 'a', 'g', 'i' or 's') with a single
	dot, instead of replacing only the first '_'.

	* prj-part.adb (Parse): Convert project file path to canonical form

	* prj-proc.adb (Recursive_Process): Make sure that, when a project is
	extended, the project id of the project extending it is recorded in its
	data, even when it has already been processed as an imported project.

From-SVN: r118293
2006-10-31 19:04:45 +01:00

2609 lines
102 KiB
Ada
Raw Blame History

------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . P R O C --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2006, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Err_Vars; use Err_Vars;
with Namet; use Namet;
with Opt;
with Osint; use Osint;
with Output; use Output;
with Prj.Attr; use Prj.Attr;
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;
with GNAT.HTable;
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,
No_Element => No_Project,
Key => Name_Id,
Hash => Hash,
Equal => "=");
-- This hash table contains all processed projects
procedure Add (To_Exp : in out Name_Id; Str : Name_Id);
-- Concatenate two strings and returns another string if both
-- arguments are not null string.
procedure Add_Attributes
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Decl : in out Declarations;
First : Attribute_Node_Id);
-- Add all attributes, starting with First, with their default
-- values to the package or project with declarations Decl.
procedure Check
(In_Tree : Project_Tree_Ref;
Project : in out Project_Id;
Follow_Links : Boolean;
When_No_Sources : Error_Warning);
-- Set all projects to not checked, then call Recursive_Check for the
-- main project Project. Project is set to No_Project if errors occurred.
procedure Copy_Package_Declarations
(From : Declarations;
To : in out Declarations;
New_Loc : Source_Ptr;
In_Tree : Project_Tree_Ref);
-- Copy a package declaration From to To for a renamed package. Change the
-- locations of all the attributes to New_Loc.
function Expression
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
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;
-- From N_Expression project node From_Project_Node, compute the value
-- of an expression and return it as a Variable_Value.
function Imported_Or_Extended_Project_From
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
With_Name : Name_Id) return Project_Id;
-- Find an imported or extended project of Project whose name is With_Name
function Package_From
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
With_Name : Name_Id) return Package_Id;
-- Find the package of Project whose name is With_Name
procedure Process_Declarative_Items
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Pkg : Package_Id;
Item : Project_Node_Id);
-- Process declarative items starting with From_Project_Node, and put them
-- in declarations Decl. This is a recursive procedure; it calls itself for
-- a package declaration or a case construction.
procedure Recursive_Process
(In_Tree : Project_Tree_Ref;
Project : out Project_Id;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Extended_By : Project_Id);
-- Process project with node From_Project_Node in the tree.
-- Do nothing if From_Project_Node is Empty_Node.
-- If project has already been processed, simply return its project id.
-- Otherwise create a new project id, mark it as processed, call itself
-- recursively for all imported projects and a extended project, if any.
-- Then process the declarative items of the project.
procedure Recursive_Check
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Follow_Links : Boolean;
When_No_Sources : Error_Warning);
-- If Project is not marked as checked, mark it as checked, call
-- Check_Naming_Scheme for the project, then call itself for a
-- possible extended project and all the imported projects of Project.
---------
-- Add --
---------
procedure Add (To_Exp : in out Name_Id; Str : Name_Id) is
begin
if To_Exp = Types.No_Name or else To_Exp = Empty_String then
-- To_Exp is nil or empty. The result is Str
To_Exp := Str;
-- If Str is nil, then do not change To_Ext
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);
To_Exp := Name_Find;
end;
end if;
end Add;
--------------------
-- Add_Attributes --
--------------------
procedure Add_Attributes
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Decl : in out Declarations;
First : Attribute_Node_Id)
is
The_Attribute : Attribute_Node_Id := First;
begin
while The_Attribute /= Empty_Attribute loop
if Attribute_Kind_Of (The_Attribute) = Single then
declare
New_Attribute : Variable_Value;
begin
case Variable_Kind_Of (The_Attribute) is
-- Undefined should not happen
when Undefined =>
pragma Assert
(False, "attribute with an undefined kind");
raise Program_Error;
-- Single attributes have a default value of empty string
when Single =>
New_Attribute :=
(Project => Project,
Kind => Single,
Location => No_Location,
Default => True,
Value => Empty_String,
Index => 0);
-- List attributes have a default value of nil list
when List =>
New_Attribute :=
(Project => Project,
Kind => List,
Location => No_Location,
Default => True,
Values => Nil_String);
end case;
Variable_Element_Table.Increment_Last
(In_Tree.Variable_Elements);
In_Tree.Variable_Elements.Table
(Variable_Element_Table.Last
(In_Tree.Variable_Elements)) :=
(Next => Decl.Attributes,
Name => Attribute_Name_Of (The_Attribute),
Value => New_Attribute);
Decl.Attributes := Variable_Element_Table.Last
(In_Tree.Variable_Elements);
end;
end if;
The_Attribute := Next_Attribute (After => The_Attribute);
end loop;
end Add_Attributes;
-----------
-- Check --
-----------
procedure Check
(In_Tree : Project_Tree_Ref;
Project : in out Project_Id;
Follow_Links : Boolean;
When_No_Sources : Error_Warning)
is
begin
-- Make sure that all projects are marked as not checked
for Index in Project_Table.First ..
Project_Table.Last (In_Tree.Projects)
loop
In_Tree.Projects.Table (Index).Checked := False;
end loop;
Recursive_Check (Project, In_Tree, Follow_Links, When_No_Sources);
end Check;
-------------------------------
-- Copy_Package_Declarations --
-------------------------------
procedure Copy_Package_Declarations
(From : Declarations;
To : in out Declarations;
New_Loc : Source_Ptr;
In_Tree : Project_Tree_Ref)
is
V1 : Variable_Id := From.Attributes;
V2 : Variable_Id := No_Variable;
Var : Variable;
A1 : Array_Id := From.Arrays;
A2 : Array_Id := No_Array;
Arr : Array_Data;
E1 : Array_Element_Id;
E2 : Array_Element_Id := No_Array_Element;
Elm : Array_Element;
begin
-- To avoid references in error messages to attribute declarations in
-- an original package that has been renamed, copy all the attribute
-- declarations of the package and change all locations to New_Loc,
-- the location of the renamed package.
-- First single attributes
while V1 /= No_Variable loop
-- Copy the attribute
Var := In_Tree.Variable_Elements.Table (V1);
V1 := Var.Next;
-- Remove the Next component
Var.Next := No_Variable;
-- Change the location to New_Loc
Var.Value.Location := New_Loc;
Variable_Element_Table.Increment_Last (In_Tree.Variable_Elements);
-- Put in new declaration
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);
end if;
V2 := Variable_Element_Table.Last (In_Tree.Variable_Elements);
In_Tree.Variable_Elements.Table (V2) := Var;
end loop;
-- Then the associated array attributes
while A1 /= No_Array loop
-- Copy the array
Arr := In_Tree.Arrays.Table (A1);
A1 := Arr.Next;
-- Remove the Next component
Arr.Next := No_Array;
Array_Table.Increment_Last (In_Tree.Arrays);
-- Create new Array declaration
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 if;
A2 := Array_Table.Last (In_Tree.Arrays);
-- Don't store the array, as its first element has not been set yet
-- Copy the array elements of the array
E1 := Arr.Value;
Arr.Value := No_Array_Element;
while E1 /= No_Array_Element loop
-- Copy the array element
Elm := In_Tree.Array_Elements.Table (E1);
E1 := Elm.Next;
-- Remove the Next component
Elm.Next := No_Array_Element;
-- Change the location
Elm.Value.Location := New_Loc;
Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
-- Create new array element
if Arr.Value = No_Array_Element then
Arr.Value := Array_Element_Table.Last (In_Tree.Array_Elements);
else
In_Tree.Array_Elements.Table (E2).Next :=
Array_Element_Table.Last (In_Tree.Array_Elements);
end if;
E2 := Array_Element_Table.Last (In_Tree.Array_Elements);
In_Tree.Array_Elements.Table (E2) := Elm;
end loop;
-- Finally, store the new array
In_Tree.Arrays.Table (A2) := Arr;
end loop;
end Copy_Package_Declarations;
----------------
-- Expression --
----------------
function Expression
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
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 in the expression list
The_Current_Term : Project_Node_Id := Empty_Node;
-- The current term node id
Result : Variable_Value (Kind => Kind);
-- The returned result
Last : String_List_Id := Nil_String;
-- Reference to the last string elements in Result, when Kind is List
begin
Result.Project := Project;
Result.Location := Location_Of (First_Term, From_Project_Node_Tree);
-- Process each term of the expression, starting with First_Term
while The_Term /= Empty_Node loop
The_Current_Term := Current_Term (The_Term, From_Project_Node_Tree);
case Kind_Of (The_Current_Term, From_Project_Node_Tree) is
when N_Literal_String =>
case Kind is
when Undefined =>
-- Should never happen
pragma Assert (False, "Undefined expression kind");
raise Program_Error;
when Single =>
Add (Result.Value,
String_Value_Of
(The_Current_Term, From_Project_Node_Tree));
Result.Index :=
Source_Index_Of
(The_Current_Term, From_Project_Node_Tree);
when List =>
String_Element_Table.Increment_Last
(In_Tree.String_Elements);
if Last = Nil_String then
-- This can happen in an expression like () & "toto"
Result.Values := String_Element_Table.Last
(In_Tree.String_Elements);
else
In_Tree.String_Elements.Table
(Last).Next := String_Element_Table.Last
(In_Tree.String_Elements);
end if;
Last := String_Element_Table.Last
(In_Tree.String_Elements);
In_Tree.String_Elements.Table (Last) :=
(Value =>
String_Value_Of
(The_Current_Term,
From_Project_Node_Tree),
Index =>
Source_Index_Of
(The_Current_Term, From_Project_Node_Tree),
Display_Value => No_Name,
Location =>
Location_Of
(The_Current_Term,
From_Project_Node_Tree),
Flag => False,
Next => Nil_String);
end case;
when N_Literal_String_List =>
declare
String_Node : Project_Node_Id :=
First_Expression_In_List
(The_Current_Term,
From_Project_Node_Tree);
Value : Variable_Value;
begin
if String_Node /= Empty_Node then
-- If String_Node is nil, it is an empty list,
-- there is nothing to do
Value := Expression
(Project => Project,
In_Tree => In_Tree,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => Pkg,
First_Term =>
Tree.First_Term
(String_Node, From_Project_Node_Tree),
Kind => Single);
String_Element_Table.Increment_Last
(In_Tree.String_Elements);
if Result.Values = Nil_String then
-- This literal string list is the first term
-- in a string list expression
Result.Values :=
String_Element_Table.Last (In_Tree.String_Elements);
else
In_Tree.String_Elements.Table
(Last).Next :=
String_Element_Table.Last (In_Tree.String_Elements);
end if;
Last :=
String_Element_Table.Last (In_Tree.String_Elements);
In_Tree.String_Elements.Table (Last) :=
(Value => Value.Value,
Display_Value => No_Name,
Location => Value.Location,
Flag => False,
Next => Nil_String,
Index => Value.Index);
loop
-- Add the other element of the literal string list
-- one after the other
String_Node :=
Next_Expression_In_List
(String_Node, From_Project_Node_Tree);
exit when String_Node = Empty_Node;
Value :=
Expression
(Project => Project,
In_Tree => In_Tree,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => Pkg,
First_Term =>
Tree.First_Term
(String_Node, From_Project_Node_Tree),
Kind => Single);
String_Element_Table.Increment_Last
(In_Tree.String_Elements);
In_Tree.String_Elements.Table
(Last).Next := String_Element_Table.Last
(In_Tree.String_Elements);
Last := String_Element_Table.Last
(In_Tree.String_Elements);
In_Tree.String_Elements.Table (Last) :=
(Value => Value.Value,
Display_Value => No_Name,
Location => Value.Location,
Flag => False,
Next => Nil_String,
Index => Value.Index);
end loop;
end if;
end;
when N_Variable_Reference | N_Attribute_Reference =>
declare
The_Project : Project_Id := Project;
The_Package : Package_Id := Pkg;
The_Name : Name_Id := No_Name;
The_Variable_Id : Variable_Id := No_Variable;
The_Variable : Variable_Value;
Term_Project : constant Project_Node_Id :=
Project_Node_Of
(The_Current_Term, From_Project_Node_Tree);
Term_Package : constant Project_Node_Id :=
Package_Node_Of
(The_Current_Term, From_Project_Node_Tree);
Index : Name_Id := No_Name;
begin
if Term_Project /= Empty_Node and then
Term_Project /= From_Project_Node
then
-- This variable or attribute comes from another project
The_Name :=
Name_Of (Term_Project, From_Project_Node_Tree);
The_Project := Imported_Or_Extended_Project_From
(Project => Project,
In_Tree => In_Tree,
With_Name => The_Name);
end if;
if Term_Package /= Empty_Node then
-- This is an attribute of a package
The_Name :=
Name_Of (Term_Package, From_Project_Node_Tree);
The_Package := In_Tree.Projects.Table
(The_Project).Decl.Packages;
while The_Package /= No_Package
and then In_Tree.Packages.Table
(The_Package).Name /= The_Name
loop
The_Package :=
In_Tree.Packages.Table
(The_Package).Next;
end loop;
pragma Assert
(The_Package /= No_Package,
"package not found.");
elsif Kind_Of (The_Current_Term, From_Project_Node_Tree) =
N_Attribute_Reference
then
The_Package := No_Package;
end if;
The_Name :=
Name_Of (The_Current_Term, From_Project_Node_Tree);
if Kind_Of (The_Current_Term, From_Project_Node_Tree) =
N_Attribute_Reference
then
Index :=
Associative_Array_Index_Of
(The_Current_Term, From_Project_Node_Tree);
end if;
-- If it is not an associative array attribute
if Index = No_Name then
-- It is not an associative array attribute
if The_Package /= No_Package then
-- First, if there is a package, look into the package
if Kind_Of (The_Current_Term, From_Project_Node_Tree) =
N_Variable_Reference
then
The_Variable_Id :=
In_Tree.Packages.Table
(The_Package).Decl.Variables;
else
The_Variable_Id :=
In_Tree.Packages.Table
(The_Package).Decl.Attributes;
end if;
while The_Variable_Id /= No_Variable
and then
In_Tree.Variable_Elements.Table
(The_Variable_Id).Name /= The_Name
loop
The_Variable_Id :=
In_Tree.Variable_Elements.Table
(The_Variable_Id).Next;
end loop;
end if;
if The_Variable_Id = No_Variable then
-- If we have not found it, look into the project
if Kind_Of (The_Current_Term, From_Project_Node_Tree) =
N_Variable_Reference
then
The_Variable_Id :=
In_Tree.Projects.Table
(The_Project).Decl.Variables;
else
The_Variable_Id :=
In_Tree.Projects.Table
(The_Project).Decl.Attributes;
end if;
while The_Variable_Id /= No_Variable
and then
In_Tree.Variable_Elements.Table
(The_Variable_Id).Name /= The_Name
loop
The_Variable_Id :=
In_Tree.Variable_Elements.Table
(The_Variable_Id).Next;
end loop;
end if;
pragma Assert (The_Variable_Id /= No_Variable,
"variable or attribute not found");
The_Variable :=
In_Tree.Variable_Elements.Table
(The_Variable_Id).Value;
else
-- It is an associative array attribute
declare
The_Array : Array_Id := No_Array;
The_Element : Array_Element_Id := No_Array_Element;
Array_Index : Name_Id := No_Name;
begin
if The_Package /= No_Package then
The_Array :=
In_Tree.Packages.Table
(The_Package).Decl.Arrays;
else
The_Array :=
In_Tree.Projects.Table
(The_Project).Decl.Arrays;
end if;
while The_Array /= No_Array
and then In_Tree.Arrays.Table
(The_Array).Name /= The_Name
loop
The_Array := In_Tree.Arrays.Table
(The_Array).Next;
end loop;
if The_Array /= No_Array then
The_Element := In_Tree.Arrays.Table
(The_Array).Value;
Get_Name_String (Index);
if Case_Insensitive
(The_Current_Term, From_Project_Node_Tree)
then
To_Lower (Name_Buffer (1 .. Name_Len));
end if;
Array_Index := Name_Find;
while The_Element /= No_Array_Element
and then
In_Tree.Array_Elements.Table
(The_Element).Index /= Array_Index
loop
The_Element :=
In_Tree.Array_Elements.Table
(The_Element).Next;
end loop;
end if;
if The_Element /= No_Array_Element then
The_Variable :=
In_Tree.Array_Elements.Table
(The_Element).Value;
else
if Expression_Kind_Of
(The_Current_Term, From_Project_Node_Tree) =
List
then
The_Variable :=
(Project => Project,
Kind => List,
Location => No_Location,
Default => True,
Values => Nil_String);
else
The_Variable :=
(Project => Project,
Kind => Single,
Location => No_Location,
Default => True,
Value => Empty_String,
Index => 0);
end if;
end if;
end;
end if;
case Kind is
when Undefined =>
-- Should never happen
pragma Assert (False, "undefined expression kind");
null;
when Single =>
case The_Variable.Kind is
when Undefined =>
null;
when Single =>
Add (Result.Value, The_Variable.Value);
when List =>
-- Should never happen
pragma Assert
(False,
"list cannot appear in single " &
"string expression");
null;
end case;
when List =>
case The_Variable.Kind is
when Undefined =>
null;
when Single =>
String_Element_Table.Increment_Last
(In_Tree.String_Elements);
if Last = Nil_String then
-- This can happen in an expression such as
-- () & Var
Result.Values :=
String_Element_Table.Last
(In_Tree.String_Elements);
else
In_Tree.String_Elements.Table
(Last).Next :=
String_Element_Table.Last
(In_Tree.String_Elements);
end if;
Last :=
String_Element_Table.Last
(In_Tree.String_Elements);
In_Tree.String_Elements.Table (Last) :=
(Value => The_Variable.Value,
Display_Value => No_Name,
Location => Location_Of
(The_Current_Term,
From_Project_Node_Tree),
Flag => False,
Next => Nil_String,
Index => 0);
when List =>
declare
The_List : String_List_Id :=
The_Variable.Values;
begin
while The_List /= Nil_String loop
String_Element_Table.Increment_Last
(In_Tree.String_Elements);
if Last = Nil_String then
Result.Values :=
String_Element_Table.Last
(In_Tree.
String_Elements);
else
In_Tree.
String_Elements.Table (Last).Next :=
String_Element_Table.Last
(In_Tree.
String_Elements);
end if;
Last :=
String_Element_Table.Last
(In_Tree.String_Elements);
In_Tree.String_Elements.Table (Last) :=
(Value =>
In_Tree.String_Elements.Table
(The_List).Value,
Display_Value => No_Name,
Location =>
Location_Of
(The_Current_Term,
From_Project_Node_Tree),
Flag => False,
Next => Nil_String,
Index => 0);
The_List :=
In_Tree. String_Elements.Table
(The_List).Next;
end loop;
end;
end case;
end case;
end;
when N_External_Value =>
Get_Name_String
(String_Value_Of
(External_Reference_Of
(The_Current_Term, From_Project_Node_Tree),
From_Project_Node_Tree));
declare
Name : constant Name_Id := Name_Find;
Default : Name_Id := No_Name;
Value : Name_Id := No_Name;
Def_Var : Variable_Value;
Default_Node : constant Project_Node_Id :=
External_Default_Of
(The_Current_Term, From_Project_Node_Tree);
begin
-- If there is a default value for the external reference,
-- get its value.
if Default_Node /= Empty_Node then
Def_Var := Expression
(Project => Project,
In_Tree => In_Tree,
From_Project_Node => Default_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => Pkg,
First_Term =>
Tree.First_Term
(Default_Node, From_Project_Node_Tree),
Kind => Single);
if Def_Var /= Nil_Variable_Value then
Default := Def_Var.Value;
end if;
end if;
Value := Prj.Ext.Value_Of (Name, Default);
if Value = No_Name then
if not Opt.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;
end if;
Value := Empty_String;
end if;
case Kind is
when Undefined =>
null;
when Single =>
Add (Result.Value, Value);
when List =>
String_Element_Table.Increment_Last
(In_Tree.String_Elements);
if Last = Nil_String then
Result.Values := String_Element_Table.Last
(In_Tree.String_Elements);
else
In_Tree.String_Elements.Table
(Last).Next := String_Element_Table.Last
(In_Tree.String_Elements);
end if;
Last := String_Element_Table.Last
(In_Tree.String_Elements);
In_Tree.String_Elements.Table (Last) :=
(Value => Value,
Display_Value => No_Name,
Location =>
Location_Of
(The_Current_Term, From_Project_Node_Tree),
Flag => False,
Next => Nil_String,
Index => 0);
end case;
end;
when others =>
-- Should never happen
pragma Assert
(False,
"illegal node kind in an expression");
raise Program_Error;
end case;
The_Term := Next_Term (The_Term, From_Project_Node_Tree);
end loop;
return Result;
end Expression;
---------------------------------------
-- Imported_Or_Extended_Project_From --
---------------------------------------
function Imported_Or_Extended_Project_From
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
With_Name : Name_Id) return Project_Id
is
Data : constant Project_Data :=
In_Tree.Projects.Table (Project);
List : Project_List := Data.Imported_Projects;
Result : Project_Id := No_Project;
Temp_Result : Project_Id := No_Project;
begin
-- First check if it is the name of an extended project
if Data.Extends /= No_Project
and then In_Tree.Projects.Table (Data.Extends).Name =
With_Name
then
return Data.Extends;
else
-- Then check the name of each imported project
while List /= Empty_Project_List loop
Result := In_Tree.Project_Lists.Table (List).Project;
-- If the project is directly imported, then returns its ID
if
In_Tree.Projects.Table (Result).Name = With_Name
then
return Result;
end if;
-- If a project extending the project is imported, then keep
-- this extending project as a possibility. It will be the
-- returned ID if the project is not imported directly.
declare
Proj : Project_Id :=
In_Tree.Projects.Table (Result).Extends;
begin
while Proj /= No_Project loop
if In_Tree.Projects.Table (Proj).Name =
With_Name
then
Temp_Result := Result;
exit;
end if;
Proj := In_Tree.Projects.Table (Proj).Extends;
end loop;
end;
List := In_Tree.Project_Lists.Table (List).Next;
end loop;
pragma Assert
(Temp_Result /= No_Project,
"project not found");
return Temp_Result;
end if;
end Imported_Or_Extended_Project_From;
------------------
-- Package_From --
------------------
function Package_From
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
With_Name : Name_Id) return Package_Id
is
Data : constant Project_Data :=
In_Tree.Projects.Table (Project);
Result : Package_Id := Data.Decl.Packages;
begin
-- Check the name of each existing package of Project
while Result /= No_Package
and then In_Tree.Packages.Table (Result).Name /= With_Name
loop
Result := In_Tree.Packages.Table (Result).Next;
end loop;
if Result = No_Package then
-- Should never happen
Write_Line ("package """ & Get_Name_String (With_Name) &
""" not found");
raise Program_Error;
else
return Result;
end if;
end Package_From;
-------------
-- Process --
-------------
procedure Process
(In_Tree : Project_Tree_Ref;
Project : out Project_Id;
Success : out Boolean;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Report_Error : Put_Line_Access;
Follow_Links : Boolean := True;
When_No_Sources : Error_Warning := Error)
is
Obj_Dir : Name_Id;
Extending : Project_Id;
Extending2 : Project_Id;
begin
Error_Report := Report_Error;
Success := True;
-- Make sure there is no projects in the data structure
Project_Table.Set_Last (In_Tree.Projects, No_Project);
Processed_Projects.Reset;
-- And process the main project and all of the projects it depends on,
-- recursively
Recursive_Process
(Project => Project,
In_Tree => In_Tree,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Extended_By => No_Project);
if Project /= No_Project then
Check (In_Tree, Project, Follow_Links, When_No_Sources);
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 Project /= No_Project
and then Is_Extending_All (From_Project_Node, From_Project_Node_Tree)
then
declare
Object_Dir : constant Name_Id :=
In_Tree.Projects.Table (Project).Object_Directory;
begin
for Index in
Project_Table.First .. Project_Table.Last (In_Tree.Projects)
loop
if In_Tree.Projects.Table (Index).Virtual then
In_Tree.Projects.Table (Index).Object_Directory :=
Object_Dir;
end if;
end loop;
end;
end if;
-- Check that no extending project shares its object directory with
-- the project(s) it extends.
if Project /= No_Project then
for Proj in
Project_Table.First .. Project_Table.Last (In_Tree.Projects)
loop
Extending := In_Tree.Projects.Table (Proj).Extended_By;
if Extending /= No_Project then
Obj_Dir := In_Tree.Projects.Table (Proj).Object_Directory;
-- Check that a project being extended does not share its
-- object directory with any project that extends it, directly
-- or indirectly, including a virtual extending project.
-- Start with the project directly extending it
Extending2 := Extending;
while Extending2 /= No_Project loop
if In_Tree.Projects.Table (Extending2).Ada_Sources_Present
and then
In_Tree.Projects.Table (Extending2).Object_Directory =
Obj_Dir
then
if In_Tree.Projects.Table (Extending2).Virtual then
Error_Msg_Name_1 :=
In_Tree.Projects.Table (Proj).Display_Name;
if Error_Report = null then
Error_Msg
("project { cannot be extended by a virtual " &
"project with the same object directory",
In_Tree.Projects.Table (Proj).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;
else
Error_Msg_Name_1 :=
In_Tree.Projects.Table (Extending2).Display_Name;
Error_Msg_Name_2 :=
In_Tree.Projects.Table (Proj).Display_Name;
if Error_Report = null then
Error_Msg
("project { cannot extend project {",
In_Tree.Projects.Table (Extending2).Location);
Error_Msg
("\they share the same object directory",
In_Tree.Projects.Table (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;
end if;
end if;
-- Continue with the next extending project, if any
Extending2 :=
In_Tree.Projects.Table (Extending2).Extended_By;
end loop;
end if;
end loop;
end if;
Success := Total_Errors_Detected = 0;
end Process;
-------------------------------
-- Process_Declarative_Items --
-------------------------------
procedure Process_Declarative_Items
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Pkg : Package_Id;
Item : Project_Node_Id)
is
Current_Declarative_Item : Project_Node_Id := Item;
Current_Item : Project_Node_Id := Empty_Node;
begin
-- For each declarative item
while Current_Declarative_Item /= Empty_Node loop
-- Get its data
Current_Item :=
Current_Item_Node
(Current_Declarative_Item, From_Project_Node_Tree);
-- And set Current_Declarative_Item to the next declarative item
-- ready for the next iteration.
Current_Declarative_Item :=
Next_Declarative_Item
(Current_Declarative_Item, From_Project_Node_Tree);
case Kind_Of (Current_Item, From_Project_Node_Tree) is
when N_Package_Declaration =>
-- Do not process a package declaration that should be ignored
if Expression_Kind_Of
(Current_Item, From_Project_Node_Tree) /= Ignored
then
-- Create the new package
Package_Table.Increment_Last (In_Tree.Packages);
declare
New_Pkg : constant Package_Id :=
Package_Table.Last (In_Tree.Packages);
The_New_Package : Package_Element;
Project_Of_Renamed_Package :
constant Project_Node_Id :=
Project_Of_Renamed_Package_Of
(Current_Item, From_Project_Node_Tree);
begin
-- Set the name of the new package
The_New_Package.Name :=
Name_Of (Current_Item, From_Project_Node_Tree);
-- Insert the new package in the appropriate list
if Pkg /= No_Package then
The_New_Package.Next :=
In_Tree.Packages.Table (Pkg).Decl.Packages;
In_Tree.Packages.Table (Pkg).Decl.Packages :=
New_Pkg;
else
The_New_Package.Next :=
In_Tree.Projects.Table (Project).Decl.Packages;
In_Tree.Projects.Table (Project).Decl.Packages :=
New_Pkg;
end if;
In_Tree.Packages.Table (New_Pkg) :=
The_New_Package;
if Project_Of_Renamed_Package /= Empty_Node then
-- Renamed package
declare
Project_Name : constant Name_Id :=
Name_Of
(Project_Of_Renamed_Package,
From_Project_Node_Tree);
Renamed_Project :
constant Project_Id :=
Imported_Or_Extended_Project_From
(Project, In_Tree, Project_Name);
Renamed_Package : constant Package_Id :=
Package_From
(Renamed_Project, In_Tree,
Name_Of
(Current_Item,
From_Project_Node_Tree));
begin
-- For a renamed package, copy the declarations of
-- the renamed package, but set all the locations
-- to the location of the package name in the
-- renaming declaration.
Copy_Package_Declarations
(From =>
In_Tree.Packages.Table (Renamed_Package).Decl,
To =>
In_Tree.Packages.Table (New_Pkg).Decl,
New_Loc =>
Location_Of
(Current_Item, From_Project_Node_Tree),
In_Tree => In_Tree);
end;
-- Standard package declaration, not renaming
else
-- Set the default values of the attributes
Add_Attributes
(Project, In_Tree,
In_Tree.Packages.Table (New_Pkg).Decl,
First_Attribute_Of
(Package_Id_Of
(Current_Item, From_Project_Node_Tree)));
-- And process declarative items of the new package
Process_Declarative_Items
(Project => Project,
In_Tree => In_Tree,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => New_Pkg,
Item =>
First_Declarative_Item_Of
(Current_Item, From_Project_Node_Tree));
end if;
end;
end if;
when N_String_Type_Declaration =>
-- There is nothing to process
null;
when N_Attribute_Declaration |
N_Typed_Variable_Declaration |
N_Variable_Declaration =>
if Expression_Of (Current_Item, From_Project_Node_Tree) =
Empty_Node
then
-- It must be a full associative array attribute declaration
declare
Current_Item_Name : constant Name_Id :=
Name_Of (Current_Item, From_Project_Node_Tree);
-- The name of the attribute
New_Array : Array_Id;
-- The new associative array created
Orig_Array : Array_Id;
-- The associative array value
Orig_Project_Name : Name_Id := No_Name;
-- The name of the project where the associative array
-- value is.
Orig_Project : Project_Id := No_Project;
-- The id of the project where the associative array
-- value is.
Orig_Package_Name : Name_Id := No_Name;
-- The name of the package, if any, where the associative
-- array value is.
Orig_Package : Package_Id := No_Package;
-- The id of the package, if any, where the associative
-- array value is.
New_Element : Array_Element_Id := No_Array_Element;
-- Id of a new array element created
Prev_Element : Array_Element_Id := No_Array_Element;
-- Last new element id created
Orig_Element : Array_Element_Id := No_Array_Element;
-- Current array element in the original associative
-- array.
Next_Element : Array_Element_Id := No_Array_Element;
-- Id of the array element that follows the new element.
-- This is not always nil, because values for the
-- associative array attribute may already have been
-- declared, and the array elements declared are reused.
begin
-- First, find if the associative array attribute already
-- has elements declared.
if Pkg /= No_Package then
New_Array := In_Tree.Packages.Table
(Pkg).Decl.Arrays;
else
New_Array := In_Tree.Projects.Table
(Project).Decl.Arrays;
end if;
while New_Array /= No_Array
and then In_Tree.Arrays.Table (New_Array).Name /=
Current_Item_Name
loop
New_Array := In_Tree.Arrays.Table (New_Array).Next;
end loop;
-- If the attribute has never been declared add new entry
-- in the arrays of the project/package and link it.
if New_Array = No_Array then
Array_Table.Increment_Last (In_Tree.Arrays);
New_Array := Array_Table.Last (In_Tree.Arrays);
if Pkg /= No_Package then
In_Tree.Arrays.Table (New_Array) :=
(Name => Current_Item_Name,
Value => No_Array_Element,
Next =>
In_Tree.Packages.Table (Pkg).Decl.Arrays);
In_Tree.Packages.Table (Pkg).Decl.Arrays :=
New_Array;
else
In_Tree.Arrays.Table (New_Array) :=
(Name => Current_Item_Name,
Value => No_Array_Element,
Next =>
In_Tree.Projects.Table (Project).Decl.Arrays);
In_Tree.Projects.Table (Project).Decl.Arrays :=
New_Array;
end if;
end if;
-- Find the project where the value is declared
Orig_Project_Name :=
Name_Of
(Associative_Project_Of
(Current_Item, From_Project_Node_Tree),
From_Project_Node_Tree);
for Index in Project_Table.First ..
Project_Table.Last
(In_Tree.Projects)
loop
if In_Tree.Projects.Table (Index).Name =
Orig_Project_Name
then
Orig_Project := Index;
exit;
end if;
end loop;
pragma Assert (Orig_Project /= No_Project,
"original project not found");
if Associative_Package_Of
(Current_Item, From_Project_Node_Tree) = Empty_Node
then
Orig_Array :=
In_Tree.Projects.Table
(Orig_Project).Decl.Arrays;
else
-- If in a package, find the package where the
-- value is declared.
Orig_Package_Name :=
Name_Of
(Associative_Package_Of
(Current_Item, From_Project_Node_Tree),
From_Project_Node_Tree);
Orig_Package :=
In_Tree.Projects.Table
(Orig_Project).Decl.Packages;
pragma Assert (Orig_Package /= No_Package,
"original package not found");
while In_Tree.Packages.Table
(Orig_Package).Name /= Orig_Package_Name
loop
Orig_Package := In_Tree.Packages.Table
(Orig_Package).Next;
pragma Assert (Orig_Package /= No_Package,
"original package not found");
end loop;
Orig_Array :=
In_Tree.Packages.Table
(Orig_Package).Decl.Arrays;
end if;
-- Now look for the array
while Orig_Array /= No_Array and then
In_Tree.Arrays.Table (Orig_Array).Name /=
Current_Item_Name
loop
Orig_Array := In_Tree.Arrays.Table
(Orig_Array).Next;
end loop;
if Orig_Array = No_Array then
if Error_Report = null then
Error_Msg
("associative array value cannot be found",
Location_Of
(Current_Item, From_Project_Node_Tree));
else
Error_Report
("associative array value cannot be found",
Project, In_Tree);
end if;
else
Orig_Element :=
In_Tree.Arrays.Table (Orig_Array).Value;
-- Copy each array element
while Orig_Element /= No_Array_Element loop
-- Case of first element
if Prev_Element = No_Array_Element then
-- And there is no array element declared yet,
-- create a new first array element.
if In_Tree.Arrays.Table (New_Array).Value =
No_Array_Element
then
Array_Element_Table.Increment_Last
(In_Tree.Array_Elements);
New_Element := Array_Element_Table.Last
(In_Tree.Array_Elements);
In_Tree.Arrays.Table
(New_Array).Value := New_Element;
Next_Element := No_Array_Element;
-- Otherwise, the new element is the first
else
New_Element := In_Tree.Arrays.
Table (New_Array).Value;
Next_Element :=
In_Tree.Array_Elements.Table
(New_Element).Next;
end if;
-- Otherwise, reuse an existing element, or create
-- one if necessary.
else
Next_Element :=
In_Tree.Array_Elements.Table
(Prev_Element).Next;
if Next_Element = No_Array_Element then
Array_Element_Table.Increment_Last
(In_Tree.Array_Elements);
New_Element := Array_Element_Table.Last
(In_Tree.Array_Elements);
else
New_Element := Next_Element;
Next_Element :=
In_Tree.Array_Elements.Table
(New_Element).Next;
end if;
end if;
-- Copy the value of the element
In_Tree.Array_Elements.Table
(New_Element) :=
In_Tree.Array_Elements.Table
(Orig_Element);
In_Tree.Array_Elements.Table
(New_Element).Value.Project := Project;
-- Adjust the Next link
In_Tree.Array_Elements.Table
(New_Element).Next := Next_Element;
-- Adjust the previous id for the next element
Prev_Element := New_Element;
-- Go to the next element in the original array
Orig_Element :=
In_Tree.Array_Elements.Table
(Orig_Element).Next;
end loop;
-- Make sure that the array ends here, in case there
-- previously a greater number of elements.
In_Tree.Array_Elements.Table
(New_Element).Next := No_Array_Element;
end if;
end;
-- Declarations other that full associative arrays
else
declare
New_Value : constant Variable_Value :=
Expression
(Project => Project,
In_Tree => In_Tree,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => Pkg,
First_Term =>
Tree.First_Term
(Expression_Of
(Current_Item, From_Project_Node_Tree),
From_Project_Node_Tree),
Kind =>
Expression_Kind_Of
(Current_Item, From_Project_Node_Tree));
-- The expression value
The_Variable : Variable_Id := No_Variable;
Current_Item_Name : constant Name_Id :=
Name_Of (Current_Item, From_Project_Node_Tree);
begin
-- Process a typed variable declaration
if Kind_Of (Current_Item, From_Project_Node_Tree) =
N_Typed_Variable_Declaration
then
-- Report an error for an empty string
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;
else
declare
Current_String : Project_Node_Id :=
First_Literal_String
(String_Type_Of
(Current_Item,
From_Project_Node_Tree),
From_Project_Node_Tree);
begin
-- Loop through all the valid strings for the
-- string type and compare to the string value.
while Current_String /= Empty_Node
and then
String_Value_Of
(Current_String, From_Project_Node_Tree) /=
New_Value.Value
loop
Current_String :=
Next_Literal_String
(Current_String, From_Project_Node_Tree);
end loop;
-- Report an error if the string value is not
-- one for the string type.
if Current_String = Empty_Node then
Error_Msg_Name_1 := New_Value.Value;
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;
end if;
end;
end if;
end if;
if Kind_Of (Current_Item, From_Project_Node_Tree) /=
N_Attribute_Declaration
or else
Associative_Array_Index_Of
(Current_Item, From_Project_Node_Tree) = No_Name
then
-- Case of a variable declaration or of a not
-- associative array attribute.
-- First, find the list where to find the variable
-- or attribute.
if Kind_Of (Current_Item, From_Project_Node_Tree) =
N_Attribute_Declaration
then
if Pkg /= No_Package then
The_Variable :=
In_Tree.Packages.Table
(Pkg).Decl.Attributes;
else
The_Variable :=
In_Tree.Projects.Table
(Project).Decl.Attributes;
end if;
else
if Pkg /= No_Package then
The_Variable :=
In_Tree.Packages.Table
(Pkg).Decl.Variables;
else
The_Variable :=
In_Tree.Projects.Table
(Project).Decl.Variables;
end if;
end if;
-- Loop through the list, to find if it has already
-- been declared.
while The_Variable /= No_Variable
and then
In_Tree.Variable_Elements.Table
(The_Variable).Name /= Current_Item_Name
loop
The_Variable :=
In_Tree.Variable_Elements.Table
(The_Variable).Next;
end loop;
-- If it has not been declared, create a new entry
-- in the list.
if The_Variable = No_Variable then
-- All single string attribute should already have
-- been declared with a default empty string value.
pragma Assert
(Kind_Of (Current_Item, From_Project_Node_Tree) /=
N_Attribute_Declaration,
"illegal attribute declaration");
Variable_Element_Table.Increment_Last
(In_Tree.Variable_Elements);
The_Variable := Variable_Element_Table.Last
(In_Tree.Variable_Elements);
-- Put the new variable in the appropriate list
if Pkg /= No_Package then
In_Tree.Variable_Elements.Table (The_Variable) :=
(Next =>
In_Tree.Packages.Table
(Pkg).Decl.Variables,
Name => Current_Item_Name,
Value => New_Value);
In_Tree.Packages.Table
(Pkg).Decl.Variables := The_Variable;
else
In_Tree.Variable_Elements.Table (The_Variable) :=
(Next =>
In_Tree.Projects.Table
(Project).Decl.Variables,
Name => Current_Item_Name,
Value => New_Value);
In_Tree.Projects.Table
(Project).Decl.Variables :=
The_Variable;
end if;
-- If the variable/attribute has already been
-- declared, just change the value.
else
In_Tree.Variable_Elements.Table
(The_Variable).Value :=
New_Value;
end if;
else
-- Associative array attribute
-- Get the string index
Get_Name_String
(Associative_Array_Index_Of
(Current_Item, From_Project_Node_Tree));
-- Put in lower case, if necessary
if Case_Insensitive
(Current_Item, From_Project_Node_Tree)
then
GNAT.Case_Util.To_Lower
(Name_Buffer (1 .. Name_Len));
end if;
declare
The_Array : Array_Id;
The_Array_Element : Array_Element_Id :=
No_Array_Element;
Index_Name : constant Name_Id := Name_Find;
-- The name id of the index
begin
-- 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 := In_Tree.Projects.Table
(Project).Decl.Arrays;
end if;
while
The_Array /= No_Array
and then In_Tree.Arrays.Table
(The_Array).Name /= Current_Item_Name
loop
The_Array := In_Tree.Arrays.Table
(The_Array).Next;
end loop;
-- If the array cannot be found, create a new
-- entry in the list. As The_Array_Element is
-- initialized to No_Array_Element, a new element
-- will be created automatically later.
if The_Array = No_Array then
Array_Table.Increment_Last
(In_Tree.Arrays);
The_Array := Array_Table.Last
(In_Tree.Arrays);
if Pkg /= No_Package then
In_Tree.Arrays.Table
(The_Array) :=
(Name => Current_Item_Name,
Value => No_Array_Element,
Next =>
In_Tree.Packages.Table
(Pkg).Decl.Arrays);
In_Tree.Packages.Table
(Pkg).Decl.Arrays :=
The_Array;
else
In_Tree.Arrays.Table
(The_Array) :=
(Name => Current_Item_Name,
Value => No_Array_Element,
Next =>
In_Tree.Projects.Table
(Project).Decl.Arrays);
In_Tree.Projects.Table
(Project).Decl.Arrays :=
The_Array;
end if;
-- Otherwise, initialize The_Array_Element as the
-- head of the element list.
else
The_Array_Element :=
In_Tree.Arrays.Table
(The_Array).Value;
end if;
-- Look in the list, if any, to find an element
-- with the same index.
while The_Array_Element /= No_Array_Element
and then
In_Tree.Array_Elements.Table
(The_Array_Element).Index /= Index_Name
loop
The_Array_Element :=
In_Tree.Array_Elements.Table
(The_Array_Element).Next;
end loop;
-- If no such element were found, create a new
-- one and insert it in the element list, with
-- the propoer value.
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);
In_Tree.Array_Elements.Table
(The_Array_Element) :=
(Index => Index_Name,
Src_Index =>
Source_Index_Of
(Current_Item, From_Project_Node_Tree),
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;
-- An element with the same index already exists,
-- just replace its value with the new one.
else
In_Tree.Array_Elements.Table
(The_Array_Element).Value := New_Value;
end if;
end;
end if;
end;
end if;
when N_Case_Construction =>
declare
The_Project : Project_Id := Project;
-- The id of the project of the case variable
The_Package : Package_Id := Pkg;
-- The id of the package, if any, of the case variable
The_Variable : Variable_Value := Nil_Variable_Value;
-- The case variable
Case_Value : Name_Id := No_Name;
-- The case variable value
Case_Item : Project_Node_Id := Empty_Node;
Choice_String : Project_Node_Id := Empty_Node;
Decl_Item : Project_Node_Id := Empty_Node;
begin
declare
Variable_Node : constant Project_Node_Id :=
Case_Variable_Reference_Of
(Current_Item,
From_Project_Node_Tree);
Var_Id : Variable_Id := No_Variable;
Name : Name_Id := No_Name;
begin
-- If a project were specified for the case variable,
-- get its id.
if Project_Node_Of
(Variable_Node, From_Project_Node_Tree) /= Empty_Node
then
Name :=
Name_Of
(Project_Node_Of
(Variable_Node, From_Project_Node_Tree),
From_Project_Node_Tree);
The_Project :=
Imported_Or_Extended_Project_From
(Project, In_Tree, Name);
end if;
-- If a package were specified for the case variable,
-- get its id.
if Package_Node_Of
(Variable_Node, From_Project_Node_Tree) /= Empty_Node
then
Name :=
Name_Of
(Package_Node_Of
(Variable_Node, From_Project_Node_Tree),
From_Project_Node_Tree);
The_Package :=
Package_From (The_Project, In_Tree, Name);
end if;
Name := Name_Of (Variable_Node, From_Project_Node_Tree);
-- First, look for the case variable into the package,
-- if any.
if The_Package /= No_Package then
Var_Id := In_Tree.Packages.Table
(The_Package).Decl.Variables;
Name :=
Name_Of (Variable_Node, From_Project_Node_Tree);
while Var_Id /= No_Variable
and then
In_Tree.Variable_Elements.Table
(Var_Id).Name /= Name
loop
Var_Id := In_Tree.Variable_Elements.
Table (Var_Id).Next;
end loop;
end if;
-- If not found in the package, or if there is no
-- package, look at the project level.
if Var_Id = No_Variable
and then
Package_Node_Of
(Variable_Node, From_Project_Node_Tree) = Empty_Node
then
Var_Id := In_Tree.Projects.Table
(The_Project).Decl.Variables;
while Var_Id /= No_Variable
and then
In_Tree.Variable_Elements.Table
(Var_Id).Name /= Name
loop
Var_Id := In_Tree.Variable_Elements.
Table (Var_Id).Next;
end loop;
end if;
if Var_Id = No_Variable then
-- Should never happen, because this has already been
-- checked during parsing.
Write_Line ("variable """ &
Get_Name_String (Name) &
""" not found");
raise Program_Error;
end if;
-- Get the case variable
The_Variable := In_Tree.Variable_Elements.
Table (Var_Id).Value;
if The_Variable.Kind /= Single then
-- Should never happen, because this has already been
-- checked during parsing.
Write_Line ("variable""" &
Get_Name_String (Name) &
""" is not a single string variable");
raise Program_Error;
end if;
-- Get the case variable value
Case_Value := The_Variable.Value;
end;
-- Now look into all the case items of the case construction
Case_Item :=
First_Case_Item_Of (Current_Item, From_Project_Node_Tree);
Case_Item_Loop :
while Case_Item /= Empty_Node loop
Choice_String :=
First_Choice_Of (Case_Item, From_Project_Node_Tree);
-- When Choice_String is nil, it means that it is
-- the "when others =>" alternative.
if Choice_String = Empty_Node then
Decl_Item :=
First_Declarative_Item_Of
(Case_Item, From_Project_Node_Tree);
exit Case_Item_Loop;
end if;
-- Look into all the alternative of this case item
Choice_Loop :
while Choice_String /= Empty_Node loop
if Case_Value =
String_Value_Of
(Choice_String, From_Project_Node_Tree)
then
Decl_Item :=
First_Declarative_Item_Of
(Case_Item, From_Project_Node_Tree);
exit Case_Item_Loop;
end if;
Choice_String :=
Next_Literal_String
(Choice_String, From_Project_Node_Tree);
end loop Choice_Loop;
Case_Item :=
Next_Case_Item (Case_Item, From_Project_Node_Tree);
end loop Case_Item_Loop;
-- If there is an alternative, then we process it
if Decl_Item /= Empty_Node then
Process_Declarative_Items
(Project => Project,
In_Tree => In_Tree,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => Pkg,
Item => Decl_Item);
end if;
end;
when others =>
-- Should never happen
Write_Line ("Illegal declarative item: " &
Project_Node_Kind'Image
(Kind_Of
(Current_Item, From_Project_Node_Tree)));
raise Program_Error;
end case;
end loop;
end Process_Declarative_Items;
---------------------
-- Recursive_Check --
---------------------
procedure Recursive_Check
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Follow_Links : Boolean;
When_No_Sources : Error_Warning)
is
Data : Project_Data;
Imported_Project_List : Project_List := Empty_Project_List;
begin
-- Do nothing if Project is No_Project, or Project has already
-- been marked as checked.
if Project /= No_Project
and then not In_Tree.Projects.Table (Project).Checked
then
-- Mark project as checked, to avoid infinite recursion in
-- ill-formed trees, where a project imports itself.
In_Tree.Projects.Table (Project).Checked := True;
Data := In_Tree.Projects.Table (Project);
-- Call itself for a possible extended project.
-- (if there is no extended project, then nothing happens).
Recursive_Check
(Data.Extends, In_Tree, Follow_Links, When_No_Sources);
-- Call itself for all imported projects
Imported_Project_List := Data.Imported_Projects;
while Imported_Project_List /= Empty_Project_List loop
Recursive_Check
(In_Tree.Project_Lists.Table
(Imported_Project_List).Project,
In_Tree, Follow_Links, When_No_Sources);
Imported_Project_List :=
In_Tree.Project_Lists.Table
(Imported_Project_List).Next;
end loop;
if Opt.Verbose_Mode then
Write_Str ("Checking project file """);
Write_Str (Get_Name_String (Data.Name));
Write_Line ("""");
end if;
Prj.Nmsc.Check
(Project, In_Tree, Error_Report, Follow_Links, When_No_Sources);
end if;
end Recursive_Check;
-----------------------
-- Recursive_Process --
-----------------------
procedure Recursive_Process
(In_Tree : Project_Tree_Ref;
Project : out Project_Id;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Extended_By : Project_Id)
is
With_Clause : Project_Node_Id;
begin
if From_Project_Node = Empty_Node then
Project := No_Project;
else
declare
Processed_Data : Project_Data := Empty_Project (In_Tree);
Imported : Project_List := Empty_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);
begin
Project := Processed_Projects.Get (Name);
if Project /= No_Project then
-- Make sure that, when a project is extended, the project id
-- of the project extending it is recorded in its data, even
-- when it has already been processed as an imported project.
-- This is for virtually extended projects.
if Extended_By /= No_Project then
In_Tree.Projects.Table (Project).Extended_By := Extended_By;
end if;
return;
end if;
Project_Table.Increment_Last (In_Tree.Projects);
Project := Project_Table.Last (In_Tree.Projects);
Processed_Projects.Set (Name, Project);
Processed_Data.Name := Name;
Get_Name_String (Name);
-- If name starts with the virtual prefix, flag the project as
-- being a virtual extending project.
if Name_Len > Virtual_Prefix'Length
and then Name_Buffer (1 .. Virtual_Prefix'Length) =
Virtual_Prefix
then
Processed_Data.Virtual := True;
Processed_Data.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
Processed_Data.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;
Processed_Data.Display_Name := Name_Find;
end if;
Processed_Data.Display_Path_Name :=
Path_Name_Of (From_Project_Node, From_Project_Node_Tree);
Get_Name_String (Processed_Data.Display_Path_Name);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
Processed_Data.Path_Name := Name_Find;
Processed_Data.Location :=
Location_Of (From_Project_Node, From_Project_Node_Tree);
Processed_Data.Display_Directory :=
Directory_Of (From_Project_Node, From_Project_Node_Tree);
Get_Name_String (Processed_Data.Display_Directory);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
Processed_Data.Directory := Name_Find;
Processed_Data.Extended_By := Extended_By;
Add_Attributes
(Project, In_Tree, Processed_Data.Decl, Attribute_First);
With_Clause :=
First_With_Clause_Of (From_Project_Node, From_Project_Node_Tree);
while With_Clause /= Empty_Node loop
declare
New_Project : Project_Id;
New_Data : Project_Data;
begin
Recursive_Process
(In_Tree => In_Tree,
Project => New_Project,
From_Project_Node =>
Project_Node_Of (With_Clause, From_Project_Node_Tree),
From_Project_Node_Tree => From_Project_Node_Tree,
Extended_By => No_Project);
New_Data :=
In_Tree.Projects.Table (New_Project);
-- If we were the first project to import it,
-- set First_Referred_By to us.
if New_Data.First_Referred_By = No_Project then
New_Data.First_Referred_By := Project;
In_Tree.Projects.Table (New_Project) :=
New_Data;
end if;
-- Add this project to our list of imported projects
Project_List_Table.Increment_Last
(In_Tree.Project_Lists);
In_Tree.Project_Lists.Table
(Project_List_Table.Last
(In_Tree.Project_Lists)) :=
(Project => New_Project, Next => Empty_Project_List);
-- Imported is the id of the last imported project.
-- If it is nil, then this imported project is our first.
if Imported = Empty_Project_List then
Processed_Data.Imported_Projects :=
Project_List_Table.Last
(In_Tree.Project_Lists);
else
In_Tree.Project_Lists.Table
(Imported).Next := Project_List_Table.Last
(In_Tree.Project_Lists);
end if;
Imported := Project_List_Table.Last
(In_Tree.Project_Lists);
With_Clause :=
Next_With_Clause_Of (With_Clause, From_Project_Node_Tree);
end;
end loop;
Declaration_Node :=
Project_Declaration_Of
(From_Project_Node, From_Project_Node_Tree);
Recursive_Process
(In_Tree => In_Tree,
Project => Processed_Data.Extends,
From_Project_Node =>
Extended_Project_Of
(Declaration_Node, From_Project_Node_Tree),
From_Project_Node_Tree => From_Project_Node_Tree,
Extended_By => Project);
In_Tree.Projects.Table (Project) := Processed_Data;
Process_Declarative_Items
(Project => Project,
In_Tree => In_Tree,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => No_Package,
Item =>
First_Declarative_Item_Of
(Declaration_Node, From_Project_Node_Tree));
-- If it is an extending project, inherit all packages
-- from the extended project that are not explicitely defined
-- or renamed. Also inherit the languages, if attribute Languages
-- is not explicitely defined.
if Processed_Data.Extends /= No_Project then
Processed_Data := In_Tree.Projects.Table (Project);
declare
Extended_Pkg : Package_Id :=
In_Tree.Projects.Table
(Processed_Data.Extends).Decl.Packages;
Current_Pkg : Package_Id;
Element : Package_Element;
First : constant Package_Id :=
Processed_Data.Decl.Packages;
Attribute1 : Variable_Id;
Attribute2 : Variable_Id;
Attr_Value1 : Variable;
Attr_Value2 : Variable;
begin
while Extended_Pkg /= No_Package loop
Element :=
In_Tree.Packages.Table (Extended_Pkg);
Current_Pkg := First;
loop
exit when Current_Pkg = No_Package
or else In_Tree.Packages.Table
(Current_Pkg).Name = Element.Name;
Current_Pkg := In_Tree.Packages.Table
(Current_Pkg).Next;
end loop;
if Current_Pkg = No_Package then
Package_Table.Increment_Last
(In_Tree.Packages);
Current_Pkg := Package_Table.Last
(In_Tree.Packages);
In_Tree.Packages.Table (Current_Pkg) :=
(Name => Element.Name,
Decl => Element.Decl,
Parent => No_Package,
Next => Processed_Data.Decl.Packages);
Processed_Data.Decl.Packages := Current_Pkg;
end if;
Extended_Pkg := Element.Next;
end loop;
-- Check if attribute Languages is declared in the
-- extending project.
Attribute1 := Processed_Data.Decl.Attributes;
while Attribute1 /= No_Variable loop
Attr_Value1 := In_Tree.Variable_Elements.
Table (Attribute1);
exit when Attr_Value1.Name = Snames.Name_Languages;
Attribute1 := Attr_Value1.Next;
end loop;
if Attribute1 = No_Variable or else
Attr_Value1.Value.Default
then
-- Attribute Languages is not declared in the extending
-- project. Check if it is declared in the project being
-- extended.
Attribute2 :=
In_Tree.Projects.Table
(Processed_Data.Extends).Decl.Attributes;
while Attribute2 /= No_Variable loop
Attr_Value2 := In_Tree.Variable_Elements.
Table (Attribute2);
exit when Attr_Value2.Name = Snames.Name_Languages;
Attribute2 := Attr_Value2.Next;
end loop;
if Attribute2 /= No_Variable and then
not Attr_Value2.Value.Default
then
-- As attribute Languages is declared in the project
-- being extended, copy its value for the extending
-- project.
if Attribute1 = No_Variable then
Variable_Element_Table.Increment_Last
(In_Tree.Variable_Elements);
Attribute1 := Variable_Element_Table.Last
(In_Tree.Variable_Elements);
Attr_Value1.Next := Processed_Data.Decl.Attributes;
Processed_Data.Decl.Attributes := Attribute1;
end if;
Attr_Value1.Name := Snames.Name_Languages;
Attr_Value1.Value := Attr_Value2.Value;
In_Tree.Variable_Elements.Table
(Attribute1) := Attr_Value1;
end if;
end if;
end;
In_Tree.Projects.Table (Project) := Processed_Data;
end if;
end;
end if;
end Recursive_Process;
end Prj.Proc;
Reference in New Issue View Git Blame Copy Permalink