URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [prj-proc.adb] - Rev 706
Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P R J . P R O C -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2012, 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 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.Util; with Prj.Part; with Snames; 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.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 Val : String_List_Id := New_Value.Values; begin while Val /= Nil_String loop Prj.Env.Add_Directories (Child_Env.Project_Path, Get_Name_String (Shared.String_Elements.Table (Val).Value)); Val := Shared.String_Elements.Table (Val).Next; 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; 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 Prj.Part.Parse (In_Tree => From_Project_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 => From_Project_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 => From_Project_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.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 Err_Vars.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 Err_Vars.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;