diff options
Diffstat (limited to 'gcc-4.8.3/gcc/ada/prj-proc.adb')
| -rw-r--r-- | gcc-4.8.3/gcc/ada/prj-proc.adb | 2996 |
1 files changed, 2996 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/prj-proc.adb b/gcc-4.8.3/gcc/ada/prj-proc.adb new file mode 100644 index 000000000..fe4c252b0 --- /dev/null +++ b/gcc-4.8.3/gcc/ada/prj-proc.adb @@ -0,0 +1,2996 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . P R O C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2013, 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 3, 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 COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Err_Vars; use Err_Vars; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +with Prj.Attr; use Prj.Attr; +with Prj.Env; +with Prj.Err; use Prj.Err; +with Prj.Ext; use Prj.Ext; +with Prj.Nmsc; use Prj.Nmsc; +with Prj.Part; +with Prj.Util; +with Snames; + +with Ada.Containers.Vectors; +with Ada.Strings.Fixed; use Ada.Strings.Fixed; + +with GNAT.Case_Util; use GNAT.Case_Util; +with GNAT.HTable; + +package body Prj.Proc is + + 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 + + package Unit_Htable is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Source_Id, + No_Element => No_Source, + 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. + + -- In the following procedures, we are expected to guess the meaning of + -- the parameters from their names, this is never a good idea, comments + -- should be added precisely defining every formal ??? + + procedure Add_Attributes + (Project : Project_Id; + Project_Name : Name_Id; + Project_Dir : Name_Id; + Shared : Shared_Project_Tree_Data_Access; + Decl : in out Declarations; + First : Attribute_Node_Id; + Project_Level : Boolean); + -- 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 : Project_Id; + Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + 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; + To : in out Declarations; + New_Loc : Source_Ptr; + Restricted : Boolean; + Shared : Shared_Project_Tree_Data_Access); + -- Copy a package declaration From to To for a renamed package. Change the + -- locations of all the attributes to New_Loc. When Restricted is + -- True, do not copy attributes Body, Spec, Implementation, Specification + -- and Linker_Options. + + function Expression + (Project : Project_Id; + Shared : Shared_Project_Tree_Data_Access; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Env : Prj.Tree.Environment; + 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; + 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; + Shared : Shared_Project_Tree_Data_Access; + 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; + Node_Tree : Project_Node_Tree_Ref; + Env : Prj.Tree.Environment; + Pkg : Package_Id; + Item : Project_Node_Id; + Child_Env : in out Prj.Tree.Environment); + -- 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. + -- + -- Child_Env is the modified environment after seeing declarations like + -- "for External(...) use" or "for Project_Path use" in aggregate projects. + -- It should have been initialized first. + + procedure Recursive_Process + (In_Tree : Project_Tree_Ref; + Project : out Project_Id; + Packages_To_Check : String_List_Access; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Env : in out Prj.Tree.Environment; + Extended_By : Project_Id; + From_Encapsulated_Lib : Boolean); + -- 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. + -- + -- Is_Root_Project should be true only for the project that the user + -- explicitly loaded. In the context of aggregate projects, only that + -- project is allowed to modify the environment that will be used to load + -- projects (Child_Env). + -- + -- From_Encapsulated_Lib is true if we are parsing a project from + -- encapsulated library dependencies. + + 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 -- + --------- + + procedure Add (To_Exp : in out Name_Id; Str : Name_Id) is + begin + if To_Exp = 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; + Project_Name : Name_Id; + Project_Dir : Name_Id; + Shared : Shared_Project_Tree_Data_Access; + Decl : in out Declarations; + First : Attribute_Node_Id; + Project_Level : Boolean) + 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); + + -- Special cases of <project>'Name and + -- <project>'Project_Dir. + + if Project_Level then + if Attribute_Name_Of (The_Attribute) = + Snames.Name_Name + then + New_Attribute.Value := Project_Name; + + elsif Attribute_Name_Of (The_Attribute) = + Snames.Name_Project_Dir + then + New_Attribute.Value := Project_Dir; + end if; + end if; + + -- 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 + (Shared.Variable_Elements); + Shared.Variable_Elements.Table + (Variable_Element_Table.Last (Shared.Variable_Elements)) := + (Next => Decl.Attributes, + Name => Attribute_Name_Of (The_Attribute), + Value => New_Attribute); + Decl.Attributes := + Variable_Element_Table.Last + (Shared.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 : Project_Id; + Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Flags : Processing_Flags) + is + begin + Process_Naming_Scheme (In_Tree, Project, Node_Tree, Flags); + + -- Set the Other_Part field for the units + + declare + Source1 : Source_Id; + Name : Name_Id; + Source2 : Source_Id; + Iter : Source_Iterator; + + begin + Unit_Htable.Reset; + + Iter := For_Each_Source (In_Tree); + loop + Source1 := Prj.Element (Iter); + exit when Source1 = No_Source; + + 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); + end if; + end if; + + Next (Iter); + end loop; + end; + end Check; + + ------------------------------- + -- Copy_Package_Declarations -- + ------------------------------- + + procedure Copy_Package_Declarations + (From : Declarations; + To : in out Declarations; + New_Loc : Source_Ptr; + Restricted : Boolean; + Shared : Shared_Project_Tree_Data_Access) + is + V1 : Variable_Id; + V2 : Variable_Id := No_Variable; + Var : Variable; + A1 : Array_Id; + 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 + + V1 := From.Attributes; + while V1 /= No_Variable loop + + -- Copy the attribute + + Var := Shared.Variable_Elements.Table (V1); + V1 := Var.Next; + + -- Do not copy the value of attribute Linker_Options if Restricted + + if Restricted and then Var.Name = Snames.Name_Linker_Options then + Var.Value.Values := Nil_String; + end if; + + -- Remove the Next component + + Var.Next := No_Variable; + + -- Change the location to New_Loc + + Var.Value.Location := New_Loc; + Variable_Element_Table.Increment_Last (Shared.Variable_Elements); + + -- Put in new declaration + + if To.Attributes = No_Variable then + To.Attributes := + Variable_Element_Table.Last (Shared.Variable_Elements); + else + Shared.Variable_Elements.Table (V2).Next := + Variable_Element_Table.Last (Shared.Variable_Elements); + end if; + + V2 := Variable_Element_Table.Last (Shared.Variable_Elements); + Shared.Variable_Elements.Table (V2) := Var; + end loop; + + -- Then the associated array attributes + + A1 := From.Arrays; + while A1 /= No_Array loop + Arr := Shared.Arrays.Table (A1); + A1 := Arr.Next; + + -- Remove the Next component + + Arr.Next := No_Array; + Array_Table.Increment_Last (Shared.Arrays); + + -- Create new Array declaration + + if To.Arrays = No_Array then + To.Arrays := Array_Table.Last (Shared.Arrays); + else + Shared.Arrays.Table (A2).Next := + Array_Table.Last (Shared.Arrays); + end if; + + A2 := Array_Table.Last (Shared.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 := Shared.Array_Elements.Table (E1); + E1 := Elm.Next; + + -- Remove the Next component + + Elm.Next := No_Array_Element; + + Elm.Restricted := Restricted; + + -- Change the location + + Elm.Value.Location := New_Loc; + Array_Element_Table.Increment_Last (Shared.Array_Elements); + + -- Create new array element + + if Arr.Value = No_Array_Element then + Arr.Value := Array_Element_Table.Last (Shared.Array_Elements); + else + Shared.Array_Elements.Table (E2).Next := + Array_Element_Table.Last (Shared.Array_Elements); + end if; + + E2 := Array_Element_Table.Last (Shared.Array_Elements); + Shared.Array_Elements.Table (E2) := Elm; + end loop; + + -- Finally, store the new array + + Shared.Arrays.Table (A2) := Arr; + 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 + begin + if Index = All_Other_Names + or else not Case_Insensitive (Attr, Tree) + then + return Index; + end if; + + Get_Name_String (Index); + To_Lower (Name_Buffer (1 .. Name_Len)); + return Name_Find; + end Get_Attribute_Index; + + ---------------- + -- Expression -- + ---------------- + + function Expression + (Project : Project_Id; + Shared : Shared_Project_Tree_Data_Access; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Env : Prj.Tree.Environment; + Pkg : Package_Id; + First_Term : Project_Node_Id; + Kind : Variable_Kind) return Variable_Value + is + The_Term : Project_Node_Id; + -- 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 + + The_Term := First_Term; + while Present (The_Term) 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 + (Shared.String_Elements); + + if Last = Nil_String then + + -- This can happen in an expression like () & "toto" + + Result.Values := String_Element_Table.Last + (Shared.String_Elements); + + else + Shared.String_Elements.Table + (Last).Next := String_Element_Table.Last + (Shared.String_Elements); + end if; + + Last := String_Element_Table.Last + (Shared.String_Elements); + + Shared.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 Present (String_Node) then + + -- If String_Node is nil, it is an empty list, there is + -- nothing to do. + + Value := Expression + (Project => Project, + Shared => Shared, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => From_Project_Node_Tree, + Env => Env, + Pkg => Pkg, + First_Term => + Tree.First_Term + (String_Node, From_Project_Node_Tree), + Kind => Single); + String_Element_Table.Increment_Last + (Shared.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 + (Shared.String_Elements); + + else + Shared.String_Elements.Table (Last).Next := + String_Element_Table.Last (Shared.String_Elements); + end if; + + Last := + String_Element_Table.Last (Shared.String_Elements); + + Shared.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 No (String_Node); + + Value := + Expression + (Project => Project, + Shared => Shared, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => From_Project_Node_Tree, + Env => Env, + Pkg => Pkg, + First_Term => + Tree.First_Term + (String_Node, From_Project_Node_Tree), + Kind => Single); + + String_Element_Table.Increment_Last + (Shared.String_Elements); + Shared.String_Elements.Table (Last).Next := + String_Element_Table.Last (Shared.String_Elements); + Last := String_Element_Table.Last + (Shared.String_Elements); + Shared.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 Present (Term_Project) + 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, + With_Name => The_Name); + end if; + + if Present (Term_Package) then + + -- This is an attribute of a package + + The_Name := + Name_Of (Term_Package, From_Project_Node_Tree); + + The_Package := The_Project.Decl.Packages; + while The_Package /= No_Package + and then Shared.Packages.Table (The_Package).Name /= + The_Name + loop + The_Package := + Shared.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 := + Shared.Packages.Table + (The_Package).Decl.Variables; + else + The_Variable_Id := + Shared.Packages.Table + (The_Package).Decl.Attributes; + end if; + + while The_Variable_Id /= No_Variable + and then Shared.Variable_Elements.Table + (The_Variable_Id).Name /= The_Name + loop + The_Variable_Id := + Shared.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 := The_Project.Decl.Variables; + else + The_Variable_Id := The_Project.Decl.Attributes; + end if; + + while The_Variable_Id /= No_Variable + and then Shared.Variable_Elements.Table + (The_Variable_Id).Name /= The_Name + loop + The_Variable_Id := + Shared.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 := + Shared.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 := + Shared.Packages.Table (The_Package).Decl.Arrays; + else + The_Array := The_Project.Decl.Arrays; + end if; + + while The_Array /= No_Array + and then Shared.Arrays.Table (The_Array).Name /= + The_Name + loop + The_Array := Shared.Arrays.Table (The_Array).Next; + end loop; + + if The_Array /= No_Array then + The_Element := + Shared.Arrays.Table (The_Array).Value; + Array_Index := + Get_Attribute_Index + (From_Project_Node_Tree, + The_Current_Term, + Index); + + while The_Element /= No_Array_Element + and then Shared.Array_Elements.Table + (The_Element).Index /= Array_Index + loop + The_Element := + Shared.Array_Elements.Table (The_Element).Next; + end loop; + + end if; + + if The_Element /= No_Array_Element then + The_Variable := + Shared.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 + (Shared.String_Elements); + + if Last = Nil_String then + + -- This can happen in an expression such as + -- () & Var + + Result.Values := + String_Element_Table.Last + (Shared.String_Elements); + + else + Shared.String_Elements.Table (Last).Next := + String_Element_Table.Last + (Shared.String_Elements); + end if; + + Last := + String_Element_Table.Last + (Shared.String_Elements); + + Shared.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 + (Shared.String_Elements); + + if Last = Nil_String then + Result.Values := + String_Element_Table.Last + (Shared.String_Elements); + + else + Shared. + String_Elements.Table (Last).Next := + String_Element_Table.Last + (Shared.String_Elements); + + end if; + + Last := + String_Element_Table.Last + (Shared.String_Elements); + + Shared.String_Elements.Table + (Last) := + (Value => + Shared.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 := Shared.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; + Ext_List : Boolean := False; + Str_List : String_List_Access := null; + 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 Present (Default_Node) then + Def_Var := Expression + (Project => Project, + Shared => Shared, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => From_Project_Node_Tree, + Env => Env, + 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; + + Ext_List := Expression_Kind_Of + (The_Current_Term, + From_Project_Node_Tree) = List; + + if Ext_List then + Value := Prj.Ext.Value_Of (Env.External, Name, No_Name); + + if Value /= No_Name then + declare + Sep : constant String := + Get_Name_String (Default); + First : Positive := 1; + Lst : Natural; + Done : Boolean := False; + Nmb : Natural; + + begin + Get_Name_String (Value); + + if Name_Len = 0 + or else Sep'Length = 0 + or else Name_Buffer (1 .. Name_Len) = Sep + then + Done := True; + end if; + + if not Done and then Name_Len < Sep'Length then + Str_List := + new String_List' + (1 => new String' + (Name_Buffer (1 .. Name_Len))); + Done := True; + end if; + + if not Done then + if Name_Buffer (1 .. Sep'Length) = Sep then + First := Sep'Length + 1; + end if; + + if Name_Len - First + 1 >= Sep'Length + and then + Name_Buffer (Name_Len - Sep'Length + 1 .. + Name_Len) = Sep + then + Name_Len := Name_Len - Sep'Length; + end if; + + if Name_Len = 0 then + Str_List := + new String_List'(1 => new String'("")); + Done := True; + end if; + end if; + + if not Done then + + -- Count the number of strings + + declare + Saved : constant Positive := First; + + begin + Nmb := 1; + loop + Lst := + Index + (Source => + Name_Buffer (First .. Name_Len), + Pattern => Sep); + exit when Lst = 0; + Nmb := Nmb + 1; + First := Lst + Sep'Length; + end loop; + + First := Saved; + end; + + Str_List := new String_List (1 .. Nmb); + + -- Populate the string list + + Nmb := 1; + loop + Lst := + Index + (Source => + Name_Buffer (First .. Name_Len), + Pattern => Sep); + + if Lst = 0 then + Str_List (Nmb) := + new String' + (Name_Buffer (First .. Name_Len)); + exit; + + else + Str_List (Nmb) := + new String' + (Name_Buffer (First .. Lst - 1)); + Nmb := Nmb + 1; + First := Lst + Sep'Length; + end if; + end loop; + end if; + end; + end if; + + else + -- Get the value + + Value := Prj.Ext.Value_Of (Env.External, Name, Default); + + if Value = No_Name then + if not Quiet_Output then + Error_Msg + (Env.Flags, "?undefined external reference", + Location_Of + (The_Current_Term, From_Project_Node_Tree), + Project); + end if; + + Value := Empty_String; + end if; + end if; + + case Kind is + + when Undefined => + null; + + when Single => + if Ext_List then + null; -- error + + else + Add (Result.Value, Value); + end if; + + when List => + if not Ext_List or else Str_List /= null then + String_Element_Table.Increment_Last + (Shared.String_Elements); + + if Last = Nil_String then + Result.Values := + String_Element_Table.Last + (Shared.String_Elements); + + else + Shared.String_Elements.Table (Last).Next + := String_Element_Table.Last + (Shared.String_Elements); + end if; + + Last := String_Element_Table.Last + (Shared.String_Elements); + + if Ext_List then + for Ind in Str_List'Range loop + Name_Len := 0; + Add_Str_To_Name_Buffer (Str_List (Ind).all); + Value := Name_Find; + Shared.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); + + if Ind /= Str_List'Last then + String_Element_Table.Increment_Last + (Shared.String_Elements); + Shared.String_Elements.Table (Last).Next := + String_Element_Table.Last + (Shared.String_Elements); + Last := String_Element_Table.Last + (Shared.String_Elements); + end if; + end loop; + + else + Shared.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 if; + end if; + 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; + With_Name : Name_Id) return Project_Id + is + List : Project_List; + Result : Project_Id; + Temp_Result : Project_Id; + + begin + -- First check if it is the name of an extended project + + Result := Project.Extends; + while Result /= No_Project loop + if Result.Name = With_Name then + return Result; + else + Result := Result.Extends; + end if; + end loop; + + -- Then check the name of each imported project + + Temp_Result := No_Project; + List := Project.Imported_Projects; + while List /= null loop + Result := List.Project; + + -- If the project is directly imported, then returns its ID + + if 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; + + begin + Proj := Result.Extends; + while Proj /= No_Project loop + if Proj.Name = With_Name then + Temp_Result := Result; + exit; + end if; + + Proj := Proj.Extends; + end loop; + end; + + List := List.Next; + end loop; + + pragma Assert (Temp_Result /= No_Project, "project not found"); + return Temp_Result; + end Imported_Or_Extended_Project_From; + + ------------------ + -- Package_From -- + ------------------ + + function Package_From + (Project : Project_Id; + Shared : Shared_Project_Tree_Data_Access; + With_Name : Name_Id) return Package_Id + is + Result : Package_Id := Project.Decl.Packages; + + begin + -- Check the name of each existing package of Project + + while Result /= No_Package + and then Shared.Packages.Table (Result).Name /= With_Name + loop + Result := Shared.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; + Packages_To_Check : String_List_Access; + Success : out Boolean; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Env : in out Prj.Tree.Environment; + Reset_Tree : Boolean := True) + is + begin + Process_Project_Tree_Phase_1 + (In_Tree => In_Tree, + Project => Project, + Success => Success, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => From_Project_Node_Tree, + Env => Env, + Packages_To_Check => Packages_To_Check, + Reset_Tree => Reset_Tree); + + 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, + Env => Env); + end if; + end Process; + + ------------------------------- + -- Process_Declarative_Items -- + ------------------------------- + + procedure Process_Declarative_Items + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + From_Project_Node : Project_Node_Id; + Node_Tree : Project_Node_Tree_Ref; + Env : Prj.Tree.Environment; + Pkg : Package_Id; + Item : Project_Node_Id; + Child_Env : in out Prj.Tree.Environment) + is + Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared; + + procedure Check_Or_Set_Typed_Variable + (Value : in out Variable_Value; + Declaration : Project_Node_Id); + -- Check whether Value is valid for this typed variable declaration. If + -- it is an error, the behavior depends on the flags: either an error is + -- reported, or a warning, or nothing. In the last two cases, the value + -- of the variable is set to a valid value, replacing Value. + + procedure Process_Package_Declaration + (Current_Item : Project_Node_Id); + procedure Process_Attribute_Declaration + (Current : Project_Node_Id); + procedure Process_Case_Construction + (Current_Item : Project_Node_Id); + procedure Process_Associative_Array + (Current_Item : Project_Node_Id); + procedure Process_Expression + (Current : Project_Node_Id); + procedure Process_Expression_For_Associative_Array + (Current : Project_Node_Id; + New_Value : Variable_Value); + procedure Process_Expression_Variable_Decl + (Current_Item : Project_Node_Id; + New_Value : Variable_Value); + -- Process the various declarative items + + --------------------------------- + -- Check_Or_Set_Typed_Variable -- + --------------------------------- + + procedure Check_Or_Set_Typed_Variable + (Value : in out Variable_Value; + Declaration : Project_Node_Id) + is + Loc : constant Source_Ptr := Location_Of (Declaration, Node_Tree); + + Reset_Value : Boolean := False; + Current_String : Project_Node_Id; + + begin + -- Report an error for an empty string + + if Value.Value = Empty_String then + Error_Msg_Name_1 := Name_Of (Declaration, Node_Tree); + + case Env.Flags.Allow_Invalid_External is + when Error => + Error_Msg + (Env.Flags, "no value defined for %%", Loc, Project); + when Warning => + Reset_Value := True; + Error_Msg + (Env.Flags, "?no value defined for %%", Loc, Project); + when Silent => + Reset_Value := True; + end case; + + else + -- Loop through all the valid strings for the + -- string type and compare to the string value. + + Current_String := + First_Literal_String + (String_Type_Of (Declaration, Node_Tree), Node_Tree); + + while Present (Current_String) + and then + String_Value_Of (Current_String, Node_Tree) /= Value.Value + loop + Current_String := + Next_Literal_String (Current_String, Node_Tree); + end loop; + + -- Report error if string value is not one for the string type + + if No (Current_String) then + Error_Msg_Name_1 := Value.Value; + Error_Msg_Name_2 := Name_Of (Declaration, Node_Tree); + + case Env.Flags.Allow_Invalid_External is + when Error => + Error_Msg + (Env.Flags, "value %% is illegal for typed string %%", + Loc, Project); + + when Warning => + Error_Msg + (Env.Flags, "?value %% is illegal for typed string %%", + Loc, Project); + Reset_Value := True; + + when Silent => + Reset_Value := True; + end case; + end if; + end if; + + if Reset_Value then + Current_String := + First_Literal_String + (String_Type_Of (Declaration, Node_Tree), Node_Tree); + Value.Value := String_Value_Of (Current_String, Node_Tree); + end if; + end Check_Or_Set_Typed_Variable; + + --------------------------------- + -- Process_Package_Declaration -- + --------------------------------- + + procedure Process_Package_Declaration + (Current_Item : Project_Node_Id) + is + begin + -- Do not process a package declaration that should be ignored + + if Expression_Kind_Of (Current_Item, Node_Tree) /= Ignored then + + -- Create the new package + + Package_Table.Increment_Last (Shared.Packages); + + declare + New_Pkg : constant Package_Id := + Package_Table.Last (Shared.Packages); + The_New_Package : Package_Element; + + Project_Of_Renamed_Package : constant Project_Node_Id := + Project_Of_Renamed_Package_Of + (Current_Item, Node_Tree); + + begin + -- Set the name of the new package + + The_New_Package.Name := Name_Of (Current_Item, Node_Tree); + + -- Insert the new package in the appropriate list + + if Pkg /= No_Package then + The_New_Package.Next := + Shared.Packages.Table (Pkg).Decl.Packages; + Shared.Packages.Table (Pkg).Decl.Packages := New_Pkg; + + else + The_New_Package.Next := Project.Decl.Packages; + Project.Decl.Packages := New_Pkg; + end if; + + Shared.Packages.Table (New_Pkg) := The_New_Package; + + if Present (Project_Of_Renamed_Package) then + + -- Renamed or extending package + + declare + Project_Name : constant Name_Id := + Name_Of (Project_Of_Renamed_Package, + Node_Tree); + + Renamed_Project : constant Project_Id := + Imported_Or_Extended_Project_From + (Project, Project_Name); + + Renamed_Package : constant Package_Id := + Package_From + (Renamed_Project, Shared, + Name_Of (Current_Item, 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 => Shared.Packages.Table + (Renamed_Package).Decl, + To => Shared.Packages.Table (New_Pkg).Decl, + New_Loc => Location_Of (Current_Item, Node_Tree), + Restricted => False, + Shared => Shared); + end; + + else + -- Set the default values of the attributes + + Add_Attributes + (Project, + Project.Name, + Name_Id (Project.Directory.Display_Name), + Shared, + Shared.Packages.Table (New_Pkg).Decl, + First_Attribute_Of + (Package_Id_Of (Current_Item, Node_Tree)), + Project_Level => False); + end if; + + -- Process declarative items (nothing to do when the package is + -- renaming, as the first declarative item is null). + + Process_Declarative_Items + (Project => Project, + In_Tree => In_Tree, + From_Project_Node => From_Project_Node, + Node_Tree => Node_Tree, + Env => Env, + Pkg => New_Pkg, + Item => + First_Declarative_Item_Of (Current_Item, Node_Tree), + Child_Env => Child_Env); + end; + end if; + end Process_Package_Declaration; + + ------------------------------- + -- Process_Associative_Array -- + ------------------------------- + + procedure Process_Associative_Array + (Current_Item : Project_Node_Id) + is + Current_Item_Name : constant Name_Id := + Name_Of (Current_Item, Node_Tree); + -- The name of the attribute + + Current_Location : constant Source_Ptr := + Location_Of (Current_Item, Node_Tree); + + 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 located. + + Orig_Package : Package_Id := No_Package; + -- The id of the package, if any, where the associative array value + -- is located. + + 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 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. + + Prj : Project_List; + + begin + -- First find if the associative array attribute already has elements + -- declared. + + if Pkg /= No_Package then + New_Array := Shared.Packages.Table (Pkg).Decl.Arrays; + else + New_Array := Project.Decl.Arrays; + end if; + + while New_Array /= No_Array + and then Shared.Arrays.Table (New_Array).Name /= Current_Item_Name + loop + New_Array := Shared.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 (Shared.Arrays); + New_Array := Array_Table.Last (Shared.Arrays); + + if Pkg /= No_Package then + Shared.Arrays.Table (New_Array) := + (Name => Current_Item_Name, + Location => Current_Location, + Value => No_Array_Element, + Next => Shared.Packages.Table (Pkg).Decl.Arrays); + + Shared.Packages.Table (Pkg).Decl.Arrays := New_Array; + + else + Shared.Arrays.Table (New_Array) := + (Name => Current_Item_Name, + Location => Current_Location, + Value => No_Array_Element, + Next => Project.Decl.Arrays); + + 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, Node_Tree), Node_Tree); + + Prj := In_Tree.Projects; + while Prj /= null loop + if Prj.Project.Name = Orig_Project_Name then + Orig_Project := Prj.Project; + exit; + end if; + Prj := Prj.Next; + end loop; + + pragma Assert (Orig_Project /= No_Project, + "original project not found"); + + if No (Associative_Package_Of (Current_Item, Node_Tree)) then + Orig_Array := 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, Node_Tree), Node_Tree); + + Orig_Package := Orig_Project.Decl.Packages; + pragma Assert (Orig_Package /= No_Package, + "original package not found"); + + while Shared.Packages.Table + (Orig_Package).Name /= Orig_Package_Name + loop + Orig_Package := Shared.Packages.Table (Orig_Package).Next; + pragma Assert (Orig_Package /= No_Package, + "original package not found"); + end loop; + + Orig_Array := Shared.Packages.Table (Orig_Package).Decl.Arrays; + end if; + + -- Now look for the array + + while Orig_Array /= No_Array + and then Shared.Arrays.Table (Orig_Array).Name /= Current_Item_Name + loop + Orig_Array := Shared.Arrays.Table (Orig_Array).Next; + end loop; + + if Orig_Array = No_Array then + Error_Msg + (Env.Flags, + "associative array value not found", + Location_Of (Current_Item, Node_Tree), + Project); + + else + Orig_Element := Shared.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 Shared.Arrays.Table (New_Array).Value = + No_Array_Element + then + Array_Element_Table.Increment_Last + (Shared.Array_Elements); + New_Element := Array_Element_Table.Last + (Shared.Array_Elements); + Shared.Arrays.Table (New_Array).Value := New_Element; + Next_Element := No_Array_Element; + + -- Otherwise, the new element is the first + + else + New_Element := Shared.Arrays.Table (New_Array).Value; + Next_Element := + Shared.Array_Elements.Table (New_Element).Next; + end if; + + -- Otherwise, reuse an existing element, or create + -- one if necessary. + + else + Next_Element := + Shared.Array_Elements.Table (Prev_Element).Next; + + if Next_Element = No_Array_Element then + Array_Element_Table.Increment_Last + (Shared.Array_Elements); + New_Element := Array_Element_Table.Last + (Shared.Array_Elements); + Shared.Array_Elements.Table (Prev_Element).Next := + New_Element; + + else + New_Element := Next_Element; + Next_Element := + Shared.Array_Elements.Table (New_Element).Next; + end if; + end if; + + -- Copy the value of the element + + Shared.Array_Elements.Table (New_Element) := + Shared.Array_Elements.Table (Orig_Element); + Shared.Array_Elements.Table (New_Element).Value.Project + := Project; + + -- Adjust the Next link + + Shared.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 := Shared.Array_Elements.Table (Orig_Element).Next; + end loop; + + -- Make sure that the array ends here, in case there previously a + -- greater number of elements. + + Shared.Array_Elements.Table (New_Element).Next := No_Array_Element; + end if; + end Process_Associative_Array; + + ---------------------------------------------- + -- Process_Expression_For_Associative_Array -- + ---------------------------------------------- + + procedure Process_Expression_For_Associative_Array + (Current : Project_Node_Id; + New_Value : Variable_Value) + is + Name : constant Name_Id := Name_Of (Current, Node_Tree); + Current_Location : constant Source_Ptr := + Location_Of (Current, Node_Tree); + + Index_Name : Name_Id := + Associative_Array_Index_Of (Current, Node_Tree); + + Source_Index : constant Int := + Source_Index_Of (Current, Node_Tree); + + The_Array : Array_Id; + Elem : Array_Element_Id := No_Array_Element; + + begin + if Index_Name /= All_Other_Names then + Index_Name := Get_Attribute_Index (Node_Tree, Current, Index_Name); + end if; + + -- Look for the array in the appropriate list + + if Pkg /= No_Package then + The_Array := Shared.Packages.Table (Pkg).Decl.Arrays; + else + The_Array := Project.Decl.Arrays; + end if; + + while The_Array /= No_Array + and then Shared.Arrays.Table (The_Array).Name /= Name + loop + The_Array := Shared.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 (Shared.Arrays); + The_Array := Array_Table.Last (Shared.Arrays); + + if Pkg /= No_Package then + Shared.Arrays.Table (The_Array) := + (Name => Name, + Location => Current_Location, + Value => No_Array_Element, + Next => Shared.Packages.Table (Pkg).Decl.Arrays); + + Shared.Packages.Table (Pkg).Decl.Arrays := The_Array; + + else + Shared.Arrays.Table (The_Array) := + (Name => Name, + Location => Current_Location, + Value => No_Array_Element, + Next => Project.Decl.Arrays); + + Project.Decl.Arrays := The_Array; + end if; + + else + Elem := Shared.Arrays.Table (The_Array).Value; + end if; + + -- Look in the list, if any, to find an element with the same index + -- and same source index. + + while Elem /= No_Array_Element + and then + (Shared.Array_Elements.Table (Elem).Index /= Index_Name + or else + Shared.Array_Elements.Table (Elem).Src_Index /= Source_Index) + loop + Elem := Shared.Array_Elements.Table (Elem).Next; + end loop; + + -- If no such element were found, create a new one + -- and insert it in the element list, with the + -- proper value. + + if Elem = No_Array_Element then + Array_Element_Table.Increment_Last (Shared.Array_Elements); + Elem := Array_Element_Table.Last (Shared.Array_Elements); + + Shared.Array_Elements.Table + (Elem) := + (Index => Index_Name, + Restricted => False, + Src_Index => Source_Index, + Index_Case_Sensitive => + not Case_Insensitive (Current, Node_Tree), + Value => New_Value, + Next => Shared.Arrays.Table (The_Array).Value); + + Shared.Arrays.Table (The_Array).Value := Elem; + + else + -- An element with the same index already exists, just replace its + -- value with the new one. + + Shared.Array_Elements.Table (Elem).Value := New_Value; + end if; + + if Name = Snames.Name_External then + if In_Tree.Is_Root_Tree then + Add (Child_Env.External, + External_Name => Get_Name_String (Index_Name), + Value => Get_Name_String (New_Value.Value), + Source => From_External_Attribute); + Add (Env.External, + External_Name => Get_Name_String (Index_Name), + Value => Get_Name_String (New_Value.Value), + Source => From_External_Attribute); + else + if Current_Verbosity = High then + Debug_Output + ("'for External' has no effect except in root aggregate (" + & Get_Name_String (Index_Name) & ")", New_Value.Value); + end if; + end if; + end if; + end Process_Expression_For_Associative_Array; + + -------------------------------------- + -- Process_Expression_Variable_Decl -- + -------------------------------------- + + procedure Process_Expression_Variable_Decl + (Current_Item : Project_Node_Id; + New_Value : Variable_Value) + is + Name : constant Name_Id := Name_Of (Current_Item, Node_Tree); + + Is_Attribute : constant Boolean := + Kind_Of (Current_Item, Node_Tree) = + N_Attribute_Declaration; + + Var : Variable_Id := No_Variable; + + begin + -- First, find the list where to find the variable or attribute + + if Is_Attribute then + if Pkg /= No_Package then + Var := Shared.Packages.Table (Pkg).Decl.Attributes; + else + Var := Project.Decl.Attributes; + end if; + + else + if Pkg /= No_Package then + Var := Shared.Packages.Table (Pkg).Decl.Variables; + else + Var := Project.Decl.Variables; + end if; + end if; + + -- Loop through the list, to find if it has already been declared + + while Var /= No_Variable + and then Shared.Variable_Elements.Table (Var).Name /= Name + loop + Var := Shared.Variable_Elements.Table (Var).Next; + end loop; + + -- If it has not been declared, create a new entry in the list + + if Var = No_Variable then + + -- All single string attribute should already have been declared + -- with a default empty string value. + + pragma Assert + (not Is_Attribute, + "illegal attribute declaration for " & Get_Name_String (Name)); + + Variable_Element_Table.Increment_Last (Shared.Variable_Elements); + Var := Variable_Element_Table.Last (Shared.Variable_Elements); + + -- Put the new variable in the appropriate list + + if Pkg /= No_Package then + Shared.Variable_Elements.Table (Var) := + (Next => Shared.Packages.Table (Pkg).Decl.Variables, + Name => Name, + Value => New_Value); + Shared.Packages.Table (Pkg).Decl.Variables := Var; + + else + Shared.Variable_Elements.Table (Var) := + (Next => Project.Decl.Variables, + Name => Name, + Value => New_Value); + Project.Decl.Variables := Var; + end if; + + -- If the variable/attribute has already been declared, just + -- change the value. + + else + Shared.Variable_Elements.Table (Var).Value := New_Value; + end if; + + if Is_Attribute and then Name = Snames.Name_Project_Path then + if In_Tree.Is_Root_Tree then + declare + package Name_Ids is + new Ada.Containers.Vectors (Positive, Name_Id); + Val : String_List_Id := New_Value.Values; + List : Name_Ids.Vector; + begin + -- Get all values + + while Val /= Nil_String loop + List.Prepend + (Shared.String_Elements.Table (Val).Value); + Val := Shared.String_Elements.Table (Val).Next; + end loop; + + -- Prepend them in the order found in the attribute + + for K in Positive range 1 .. Positive (List.Length) loop + Prj.Env.Add_Directories + (Child_Env.Project_Path, + Normalize_Pathname + (Name => Get_Name_String + (List.Element (K)), + Directory => Get_Name_String + (Project.Directory.Display_Name)), + Prepend => True); + end loop; + end; + + else + if Current_Verbosity = High then + Debug_Output + ("'for Project_Path' has no effect except in" + & " root aggregate"); + end if; + end if; + end if; + end Process_Expression_Variable_Decl; + + ------------------------ + -- Process_Expression -- + ------------------------ + + procedure Process_Expression (Current : Project_Node_Id) is + New_Value : Variable_Value := + Expression + (Project => Project, + Shared => Shared, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => Node_Tree, + Env => Env, + Pkg => Pkg, + First_Term => + Tree.First_Term + (Expression_Of (Current, Node_Tree), Node_Tree), + Kind => + Expression_Kind_Of (Current, Node_Tree)); + + begin + -- Process a typed variable declaration + + if Kind_Of (Current, Node_Tree) = N_Typed_Variable_Declaration then + Check_Or_Set_Typed_Variable (New_Value, Current); + end if; + + if Kind_Of (Current, Node_Tree) /= N_Attribute_Declaration + or else Associative_Array_Index_Of (Current, Node_Tree) = No_Name + then + Process_Expression_Variable_Decl (Current, New_Value); + else + Process_Expression_For_Associative_Array (Current, New_Value); + end if; + end Process_Expression; + + ----------------------------------- + -- Process_Attribute_Declaration -- + ----------------------------------- + + procedure Process_Attribute_Declaration (Current : Project_Node_Id) is + begin + if Expression_Of (Current, Node_Tree) = Empty_Node then + Process_Associative_Array (Current); + else + Process_Expression (Current); + end if; + end Process_Attribute_Declaration; + + ------------------------------- + -- Process_Case_Construction -- + ------------------------------- + + procedure Process_Case_Construction + (Current_Item : Project_Node_Id) + is + 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, + Node_Tree); + + Var_Id : Variable_Id := No_Variable; + Name : Name_Id := No_Name; + + begin + -- If a project was specified for the case variable, get its id + + if Present (Project_Node_Of (Variable_Node, Node_Tree)) then + Name := + Name_Of + (Project_Node_Of (Variable_Node, Node_Tree), Node_Tree); + The_Project := + Imported_Or_Extended_Project_From (Project, Name); + end if; + + -- If a package was specified for the case variable, get its id + + if Present (Package_Node_Of (Variable_Node, Node_Tree)) then + Name := + Name_Of + (Package_Node_Of (Variable_Node, Node_Tree), Node_Tree); + The_Package := Package_From (The_Project, Shared, Name); + end if; + + Name := Name_Of (Variable_Node, Node_Tree); + + -- First, look for the case variable into the package, if any + + if The_Package /= No_Package then + Name := Name_Of (Variable_Node, Node_Tree); + + Var_Id := Shared.Packages.Table (The_Package).Decl.Variables; + while Var_Id /= No_Variable + and then Shared.Variable_Elements.Table (Var_Id).Name /= Name + loop + Var_Id := Shared.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 No (Package_Node_Of (Variable_Node, Node_Tree)) + then + Var_Id := The_Project.Decl.Variables; + while Var_Id /= No_Variable + and then Shared.Variable_Elements.Table (Var_Id).Name /= Name + loop + Var_Id := Shared.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 := Shared.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, Node_Tree); + + Case_Item_Loop : + while Present (Case_Item) loop + Choice_String := First_Choice_Of (Case_Item, Node_Tree); + + -- When Choice_String is nil, it means that it is the + -- "when others =>" alternative. + + if No (Choice_String) then + Decl_Item := First_Declarative_Item_Of (Case_Item, Node_Tree); + exit Case_Item_Loop; + end if; + + -- Look into all the alternative of this case item + + Choice_Loop : + while Present (Choice_String) loop + if Case_Value = String_Value_Of (Choice_String, Node_Tree) then + Decl_Item := + First_Declarative_Item_Of (Case_Item, Node_Tree); + exit Case_Item_Loop; + end if; + + Choice_String := Next_Literal_String (Choice_String, Node_Tree); + end loop Choice_Loop; + + Case_Item := Next_Case_Item (Case_Item, Node_Tree); + end loop Case_Item_Loop; + + -- If there is an alternative, then we process it + + if Present (Decl_Item) then + Process_Declarative_Items + (Project => Project, + In_Tree => In_Tree, + From_Project_Node => From_Project_Node, + Node_Tree => Node_Tree, + Env => Env, + Pkg => Pkg, + Item => Decl_Item, + Child_Env => Child_Env); + end if; + end Process_Case_Construction; + + -- Local variables + + Current, Decl : Project_Node_Id; + Kind : Project_Node_Kind; + + -- Start of processing for Process_Declarative_Items + + begin + Decl := Item; + while Present (Decl) loop + Current := Current_Item_Node (Decl, Node_Tree); + Decl := Next_Declarative_Item (Decl, Node_Tree); + Kind := Kind_Of (Current, Node_Tree); + + case Kind is + when N_Package_Declaration => + Process_Package_Declaration (Current); + + -- Nothing to process for string type declaration + + when N_String_Type_Declaration => + null; + + when N_Attribute_Declaration | + N_Typed_Variable_Declaration | + N_Variable_Declaration => + Process_Attribute_Declaration (Current); + + when N_Case_Construction => + Process_Case_Construction (Current); + + when others => + Write_Line ("Illegal declarative item: " & Kind'Img); + raise Program_Error; + end case; + end loop; + end Process_Declarative_Items; + + ---------------------------------- + -- Process_Project_Tree_Phase_1 -- + ---------------------------------- + + procedure Process_Project_Tree_Phase_1 + (In_Tree : Project_Tree_Ref; + Project : out Project_Id; + Packages_To_Check : String_List_Access; + Success : out Boolean; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Env : in out Prj.Tree.Environment; + Reset_Tree : Boolean := True) + is + begin + if Reset_Tree then + + -- Make sure there are no projects in the data structure + + Free_List (In_Tree.Projects, Free_Project => True); + end if; + + Processed_Projects.Reset; + + -- And process the main project and all of the projects it depends on, + -- recursively. + + Debug_Increase_Indent ("Process tree, phase 1"); + + Recursive_Process + (Project => Project, + In_Tree => In_Tree, + Packages_To_Check => Packages_To_Check, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => From_Project_Node_Tree, + Env => Env, + Extended_By => No_Project, + From_Encapsulated_Lib => False); + + Success := + Total_Errors_Detected = 0 + and then + (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0); + + if Current_Verbosity = High then + Debug_Decrease_Indent + ("Done Process tree, phase 1, Success=" & Success'Img); + end if; + end Process_Project_Tree_Phase_1; + + ---------------------------------- + -- Process_Project_Tree_Phase_2 -- + ---------------------------------- + + procedure Process_Project_Tree_Phase_2 + (In_Tree : Project_Tree_Ref; + Project : Project_Id; + Success : out Boolean; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Env : Environment) + is + Obj_Dir : Path_Name_Type; + Extending : Project_Id; + Extending2 : Project_Id; + Prj : Project_List; + + -- Start of processing for Process_Project_Tree_Phase_2 + + begin + Success := True; + + Debug_Increase_Indent ("Process tree, phase 2", Project.Name); + + if Project /= No_Project then + Check (In_Tree, Project, From_Project_Node_Tree, Env.Flags); + end if; + + -- 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 Is_Extending_All (From_Project_Node, From_Project_Node_Tree) + then + declare + Object_Dir : constant Path_Information := Project.Object_Directory; + + begin + Prj := In_Tree.Projects; + while Prj /= null loop + if Prj.Project.Virtual then + Prj.Project.Object_Directory := Object_Dir; + end if; + + Prj := Prj.Next; + 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 + Prj := In_Tree.Projects; + while Prj /= null loop + Extending := Prj.Project.Extended_By; + + if Extending /= No_Project then + Obj_Dir := Prj.Project.Object_Directory.Name; + + -- 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 Has_Ada_Sources (Extending2) + and then Extending2.Object_Directory.Name = Obj_Dir + then + if Extending2.Virtual then + Error_Msg_Name_1 := Prj.Project.Display_Name; + Error_Msg + (Env.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; + Error_Msg + (Env.Flags, + "project %% cannot extend project %%", + Extending2.Location, Project); + Error_Msg + (Env.Flags, + "\they share the same object directory", + Extending2.Location, Project); + end if; + end if; + + -- Continue with the next extending project, if any + + Extending2 := Extending2.Extended_By; + end loop; + end if; + + Prj := Prj.Next; + end loop; + end if; + + Debug_Decrease_Indent ("Done Process tree, phase 2"); + + Success := Total_Errors_Detected = 0 + and then + (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0); + end Process_Project_Tree_Phase_2; + + ----------------------- + -- Recursive_Process -- + ----------------------- + + procedure Recursive_Process + (In_Tree : Project_Tree_Ref; + Project : out Project_Id; + Packages_To_Check : String_List_Access; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Env : in out Prj.Tree.Environment; + Extended_By : Project_Id; + From_Encapsulated_Lib : Boolean) + is + Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared; + + Child_Env : Prj.Tree.Environment; + -- Only used for the root aggregate project (if any). This is left + -- uninitialized otherwise. + + procedure Process_Imported_Projects + (Imported : in out Project_List; + Limited_With : Boolean); + -- Process imported projects. If Limited_With is True, then only + -- projects processed through a "limited with" are processed, otherwise + -- only projects imported through a standard "with" are processed. + -- Imported is the id of the last imported project. + + procedure Process_Aggregated_Projects; + -- Process all the projects aggregated in List. This does nothing if the + -- project is not an aggregate project. + + procedure Process_Extended_Project; + -- Process the extended project: inherit all packages from the extended + -- project that are not explicitly defined or renamed. Also inherit the + -- languages, if attribute Languages is not explicitly defined. + + ------------------------------- + -- Process_Imported_Projects -- + ------------------------------- + + procedure Process_Imported_Projects + (Imported : in out Project_List; + Limited_With : Boolean) + is + With_Clause : Project_Node_Id; + New_Project : Project_Id; + Proj_Node : Project_Node_Id; + + begin + With_Clause := + First_With_Clause_Of + (From_Project_Node, From_Project_Node_Tree); + + while Present (With_Clause) loop + Proj_Node := + Non_Limited_Project_Node_Of + (With_Clause, From_Project_Node_Tree); + New_Project := No_Project; + + 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, + Packages_To_Check => Packages_To_Check, + From_Project_Node => + Project_Node_Of (With_Clause, From_Project_Node_Tree), + From_Project_Node_Tree => From_Project_Node_Tree, + Env => Env, + Extended_By => No_Project, + From_Encapsulated_Lib => From_Encapsulated_Lib); + + if Imported = null then + Project.Imported_Projects := new Project_List_Element' + (Project => New_Project, + From_Encapsulated_Lib => False, + Next => null); + Imported := Project.Imported_Projects; + else + Imported.Next := new Project_List_Element' + (Project => New_Project, + From_Encapsulated_Lib => False, + Next => null); + Imported := Imported.Next; + end if; + end if; + + With_Clause := + Next_With_Clause_Of (With_Clause, From_Project_Node_Tree); + end loop; + end Process_Imported_Projects; + + --------------------------------- + -- Process_Aggregated_Projects -- + --------------------------------- + + procedure Process_Aggregated_Projects is + List : Aggregated_Project_List; + Loaded_Project : Prj.Tree.Project_Node_Id; + Success : Boolean := True; + Tree : Project_Tree_Ref; + Node_Tree : Project_Node_Tree_Ref; + + begin + if Project.Qualifier not in Aggregate_Project then + return; + end if; + + Debug_Increase_Indent ("Process_Aggregated_Projects", Project.Name); + + Prj.Nmsc.Process_Aggregated_Projects + (Tree => In_Tree, + Project => Project, + Node_Tree => From_Project_Node_Tree, + Flags => Env.Flags); + + List := Project.Aggregated_Projects; + while Success and then List /= null loop + Node_Tree := new Project_Node_Tree_Data; + Initialize (Node_Tree); + + Prj.Part.Parse + (In_Tree => Node_Tree, + Project => Loaded_Project, + Packages_To_Check => Packages_To_Check, + Project_File_Name => Get_Name_String (List.Path), + Errout_Handling => Prj.Part.Never_Finalize, + Current_Directory => Get_Name_String (Project.Directory.Name), + Is_Config_File => False, + Env => Child_Env); + + Success := not Prj.Tree.No (Loaded_Project); + + if Success then + List.Tree := new Project_Tree_Data (Is_Root_Tree => False); + Prj.Initialize (List.Tree); + List.Tree.Shared := In_Tree.Shared; + + -- In aggregate library, aggregated projects are parsed using + -- the aggregate library tree. + + if Project.Qualifier = Aggregate_Library then + Tree := In_Tree; + else + Tree := List.Tree; + end if; + + -- We can only do the phase 1 of the processing, since we do + -- not have access to the configuration file yet (this is + -- called when doing phase 1 of the processing for the root + -- aggregate project). + + if In_Tree.Is_Root_Tree then + Process_Project_Tree_Phase_1 + (In_Tree => Tree, + Project => List.Project, + Packages_To_Check => Packages_To_Check, + Success => Success, + From_Project_Node => Loaded_Project, + From_Project_Node_Tree => Node_Tree, + Env => Child_Env, + Reset_Tree => False); + else + -- use the same environment as the rest of the aggregated + -- projects, ie the one that was setup by the root aggregate + Process_Project_Tree_Phase_1 + (In_Tree => Tree, + Project => List.Project, + Packages_To_Check => Packages_To_Check, + Success => Success, + From_Project_Node => Loaded_Project, + From_Project_Node_Tree => Node_Tree, + Env => Env, + Reset_Tree => False); + end if; + + else + Debug_Output ("Failed to parse", Name_Id (List.Path)); + end if; + + List := List.Next; + end loop; + + Debug_Decrease_Indent ("Done Process_Aggregated_Projects"); + end Process_Aggregated_Projects; + + ------------------------------ + -- Process_Extended_Project -- + ------------------------------ + + procedure Process_Extended_Project is + Extended_Pkg : Package_Id; + Current_Pkg : Package_Id; + Element : Package_Element; + First : constant Package_Id := Project.Decl.Packages; + Attribute1 : Variable_Id; + Attribute2 : Variable_Id; + Attr_Value1 : Variable; + Attr_Value2 : Variable; + + begin + Extended_Pkg := Project.Extends.Decl.Packages; + while Extended_Pkg /= No_Package loop + Element := Shared.Packages.Table (Extended_Pkg); + + Current_Pkg := First; + while Current_Pkg /= No_Package + and then + Shared.Packages.Table (Current_Pkg).Name /= Element.Name + loop + Current_Pkg := Shared.Packages.Table (Current_Pkg).Next; + end loop; + + if Current_Pkg = No_Package then + Package_Table.Increment_Last (Shared.Packages); + Current_Pkg := Package_Table.Last (Shared.Packages); + Shared.Packages.Table (Current_Pkg) := + (Name => Element.Name, + Decl => No_Declarations, + Parent => No_Package, + Next => Project.Decl.Packages); + Project.Decl.Packages := Current_Pkg; + Copy_Package_Declarations + (From => Element.Decl, + To => Shared.Packages.Table (Current_Pkg).Decl, + New_Loc => No_Location, + Restricted => True, + Shared => Shared); + end if; + + Extended_Pkg := Element.Next; + end loop; + + -- Check if attribute Languages is declared in the extending project + + Attribute1 := Project.Decl.Attributes; + while Attribute1 /= No_Variable loop + Attr_Value1 := Shared.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 := Project.Extends.Decl.Attributes; + while Attribute2 /= No_Variable loop + Attr_Value2 := Shared.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 + (Shared.Variable_Elements); + Attribute1 := Variable_Element_Table.Last + (Shared.Variable_Elements); + Attr_Value1.Next := Project.Decl.Attributes; + Project.Decl.Attributes := Attribute1; + end if; + + Attr_Value1.Name := Snames.Name_Languages; + Attr_Value1.Value := Attr_Value2.Value; + Shared.Variable_Elements.Table (Attribute1) := Attr_Value1; + end if; + end if; + end Process_Extended_Project; + + -- Start of processing for Recursive_Process + + begin + if No (From_Project_Node) then + Project := No_Project; + + else + declare + Imported, Mark : Project_List; + Declaration_Node : Project_Node_Id := Empty_Node; + + 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); + + 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 + Project.Extended_By := Extended_By; + end if; + + return; + end if; + + Project := + new Project_Data' + (Empty_Project + (Project_Qualifier_Of + (From_Project_Node, From_Project_Node_Tree))); + + -- Note that at this point we do not know yet if the project has + -- been withed from an encapsulated library or not. + + In_Tree.Projects := + new Project_List_Element' + (Project => Project, + From_Encapsulated_Lib => False, + Next => In_Tree.Projects); + + -- Keep track of this point + + Mark := In_Tree.Projects; + + Processed_Projects.Set (Name, Project); + + Project.Name := Name; + Project.Display_Name := Name_Node.Display_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 + Project.Virtual := True; + end if; + + Project.Path.Display_Name := + Path_Name_Of (From_Project_Node, From_Project_Node_Tree); + Get_Name_String (Project.Path.Display_Name); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Project.Path.Name := Name_Find; + + Project.Location := + Location_Of (From_Project_Node, From_Project_Node_Tree); + + Project.Directory.Display_Name := + Directory_Of (From_Project_Node, From_Project_Node_Tree); + Get_Name_String (Project.Directory.Display_Name); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Project.Directory.Name := Name_Find; + + Project.Extended_By := Extended_By; + + Add_Attributes + (Project, + Name, + Name_Id (Project.Directory.Display_Name), + In_Tree.Shared, + Project.Decl, + Prj.Attr.Attribute_First, + Project_Level => True); + + Process_Imported_Projects (Imported, Limited_With => False); + + if Project.Qualifier = Aggregate and then In_Tree.Is_Root_Tree then + Initialize_And_Copy (Child_Env, Copy_From => Env); + + elsif Project.Qualifier = Aggregate_Library then + + -- The child environment is the same as the current one + + Child_Env := Env; + + else + -- No need to initialize Child_Env, since it will not be + -- used anyway by Process_Declarative_Items (only the root + -- aggregate can modify it, and it is never read anyway). + + null; + end if; + + Declaration_Node := + Project_Declaration_Of + (From_Project_Node, From_Project_Node_Tree); + + Recursive_Process + (In_Tree => In_Tree, + Project => Project.Extends, + Packages_To_Check => Packages_To_Check, + From_Project_Node => + Extended_Project_Of + (Declaration_Node, From_Project_Node_Tree), + From_Project_Node_Tree => From_Project_Node_Tree, + Env => Env, + Extended_By => Project, + From_Encapsulated_Lib => From_Encapsulated_Lib); + + Process_Declarative_Items + (Project => Project, + In_Tree => In_Tree, + From_Project_Node => From_Project_Node, + Node_Tree => From_Project_Node_Tree, + Env => Env, + Pkg => No_Package, + Item => First_Declarative_Item_Of + (Declaration_Node, From_Project_Node_Tree), + Child_Env => Child_Env); + + if Project.Extends /= No_Project then + Process_Extended_Project; + end if; + + Process_Imported_Projects (Imported, Limited_With => True); + + if Total_Errors_Detected = 0 then + Process_Aggregated_Projects; + end if; + + -- At this point (after Process_Declarative_Items) we have the + -- attribute values set, we can backtrace In_Tree.Project and + -- set the From_Encapsulated_Library status. + + declare + Lib_Standalone : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Standalone, + Project.Decl.Attributes, + Shared); + List : Project_List := In_Tree.Projects; + Is_Encapsulated : Boolean; + + begin + Get_Name_String (Lib_Standalone.Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + + Is_Encapsulated := Name_Buffer (1 .. Name_Len) = "encapsulated"; + + if Is_Encapsulated then + while List /= null and then List /= Mark loop + List.From_Encapsulated_Lib := Is_Encapsulated; + List := List.Next; + end loop; + end if; + + if Total_Errors_Detected = 0 then + + -- For an aggregate library we add the aggregated projects + -- as imported ones. This is necessary to give visibility + -- to all sources from the aggregates from the aggregated + -- library projects. + + if Project.Qualifier = Aggregate_Library then + declare + L : Aggregated_Project_List; + begin + L := Project.Aggregated_Projects; + while L /= null loop + Project.Imported_Projects := + new Project_List_Element' + (Project => L.Project, + From_Encapsulated_Lib => Is_Encapsulated, + Next => + Project.Imported_Projects); + L := L.Next; + end loop; + end; + end if; + end if; + end; + + if Project.Qualifier = Aggregate and then In_Tree.Is_Root_Tree then + Free (Child_Env); + end if; + end; + end if; + end Recursive_Process; + +end Prj.Proc; |