diff options
| author | Arnaud Charlet <charlet@gcc.gnu.org> | 2017-09-06 15:21:31 +0200 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2017-09-06 15:21:31 +0200 |
| commit | c48e0f27232aa6604b80e0d15b6ecb50604400a7 (patch) | |
| tree | bfddb1ebb7a5ebb47669f302259856ea4f5a805a /gcc/ada/prj-proc.adb | |
| parent | a87169db7dc0667a978e3f5b63e0fca648d3b793 (diff) | |
| download | gcc-c48e0f27232aa6604b80e0d15b6ecb50604400a7.zip gcc-c48e0f27232aa6604b80e0d15b6ecb50604400a7.tar.gz gcc-c48e0f27232aa6604b80e0d15b6ecb50604400a7.tar.bz2 | |
[multiple changes]
2017-09-06 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch3.adb, sem_aux.adb, sem_res.adb: Minor reformatting.
2017-09-06 Yannick Moy <moy@adacore.com>
* sem_ch12.adb (Analyze_Instance_And_Renamings): Refactor to set
global variable Ignore_SPARK_Mode_Pragmas_In_Instance only once.
2017-09-06 Bob Duff <duff@adacore.com>
* sem_ch8.adb: Change Assert to be consistent with
other similar ones.
2017-09-06 Bob Duff <duff@adacore.com>
* binde.adb (Find_Elab_Order): Do not run Elab_Old unless
requested. Previously, the -do switch meant "run Elab_New and
Elab_Old and use the order chosen by Elab_Old, possibly with
debugging printouts comparing the two orders." Now it means
"do not run Elab_New." This is of use if there are bugs that
cause Elab_New to crash.
(Elab_Position, Num_Chosen): Change type to Nat, to avoid various
type conversions.
* ali.ads (Elab_Position): Change type to Nat, to avoid various
type conversions.
2017-09-06 Arnaud Charlet <charlet@adacore.com>
* sem_prag.adb (Check_Mode_Restriction_In_Enclosing_Context): Fix
reference to SPARK RM.
2017-09-06 Eric Botcazou <ebotcazou@adacore.com>
* layout.adb: Use SSU short hand consistently throughout the file.
2017-09-06 Eric Botcazou <ebotcazou@adacore.com>
* freeze.adb (Freeze_Record_Type)
<Sized_Component_Total_Round_RM_Size>: New local variable to
accumulate the rounded RM_Size of components. Update it for
every component whose RM_Size is statically known. Add missing
guard to check that bit packing is really required before issuing
the error about packing. Swap condition for clarity's sake.
* sem_prag.adb (Usage_Error): fix reference to
SPARK RM in comment
2017-09-06 Fedor Rybin <frybin@adacore.com>
* makeutl.adb, makeutl.ads, mlib.adb, mlib.ads, mlib-fil.adb,
mlib-fil.ads, mlib-prj.adb, mlib-prj.ads, mlib-tgt.adb, mlib-tgt.ads,
mlib-tgt-specific.adb, mlib-tgt-specific.ads,
mlib-tgt-specific-aix.adb, mlib-tgt-specific-darwin.adb,
mlib-tgt-specific-hpux.adb, mlib-tgt-specific-linux.adb,
mlib-tgt-specific-mingw.adb, mlib-tgt-specific-solaris.adb,
mlib-tgt-specific-vxworks.adb, mlib-tgt-specific-xi.adb, mlib-utl.adb,
mlib-utl.ads, prj.adb, prj.ads, prj-attr.adb, prj-attr.ads,
prj-attr-pm.adb, prj-attr-pm.ads, prj-com.ads, prj-conf.adb,
prj-conf.ads, prj-dect.adb, prj-dect.ads, prj-env.adb, prj-env.ads,
prj-err.adb, prj-err.ads, prj-ext.adb, prj-ext.ads, prj-makr.adb,
prj-makr.ads, prj-nmsc.adb, prj-nmsc.ads, prj-pars.adb, prj-pars.ads,
prj-part.adb, prj-part.ads, prj-pp.adb, prj-pp.ads, prj-proc.adb,
prj-proc.ads, prj-strt.adb, prj-strt.ads, prj-tree.adb, prj-tree.ads,
prj-util.adb, prj-util.ads, sinput-p.adb, sinput-p.ads: Remove obsolete
project manager sources.
2017-09-06 Ed Schonberg <schonberg@adacore.com>
* sem_ch5.adb (Analyze_Assigment): If the left-hand side is an
entity of a mutable type and the right-hand side is a conditional
expression, resolve the alternatives of the conditional using
the base type of the target entity, because the alternatives
may have distinct subtypes. This is particularly relevant if
the alternatives are aggregates.
From-SVN: r251797
Diffstat (limited to 'gcc/ada/prj-proc.adb')
| -rw-r--r-- | gcc/ada/prj-proc.adb | 3179 |
1 files changed, 0 insertions, 3179 deletions
diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb deleted file mode 100644 index ec52c23..0000000 --- a/gcc/ada/prj-proc.adb +++ /dev/null @@ -1,3179 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- P R J . P R O C -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2017, 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 - - package Runtime_Defaults is new GNAT.HTable.Simple_HTable - (Header_Num => Prj.Header_Num, - Element => Name_Id, - No_Element => No_Name, - Key => Name_Id, - Hash => Prj.Hash, - Equal => "="); - -- Stores the default values of 'Runtime names for the various languages - - package Name_Ids is new Ada.Containers.Vectors (Positive, Name_Id); - - 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; - No_Extending : Boolean := False) return Project_Id; - -- Find an imported or extended project of Project whose name is With_Name. - -- When No_Extending is True, do not look for extending projects, returns - -- the exact 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; - On_New_Tree_Loaded : Tree_Loaded_Callback := null); - -- 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. - -- - -- If specified, On_New_Tree_Loaded is called after each aggregated project - -- has been processed successfully. - - 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 - - Current_Term_Kind : Project_Node_Kind; - - 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); - - if The_Current_Term /= Empty_Node then - Current_Term_Kind := - Kind_Of (The_Current_Term, From_Project_Node_Tree); - - case Current_Term_Kind 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_Attribute_Reference - | N_Variable_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 - <<Object_Dir_Restart>> - The_Project := Project; - The_Package := Pkg; - The_Name := No_Name; - The_Variable_Id := No_Variable; - Index := No_Name; - - 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, - No_Extending => True); - 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 Current_Term_Kind = 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 Current_Term_Kind = 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 Current_Term_Kind = 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; - - if From_Project_Node_Tree.Incomplete_With then - if The_Variable_Id = No_Variable then - The_Variable := Nil_Variable_Value; - else - The_Variable := - Shared.Variable_Elements.Table - (The_Variable_Id).Value; - end if; - - else - pragma Assert (The_Variable_Id /= No_Variable, - "variable or attribute not found"); - - The_Variable := - Shared.Variable_Elements.Table - (The_Variable_Id).Value; - end if; - - 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; - - -- Check the defaults - - if Current_Term_Kind = N_Attribute_Reference then - declare - The_Default : constant Attribute_Default_Value := - Default_Of - (The_Current_Term, From_Project_Node_Tree); - - begin - -- Check the special value for 'Target when specified - - if The_Default = Target_Value - and then Opt.Target_Origin = Specified - then - Name_Len := 0; - Add_Str_To_Name_Buffer (Opt.Target_Value.all); - The_Variable.Value := Name_Find; - - -- Check the defaults - - elsif The_Variable.Default then - case The_Variable.Kind is - - when Undefined => - null; - - when Single => - case The_Default is - when Read_Only_Value => - null; - - when Empty_Value => - The_Variable.Value := Empty_String; - - when Dot_Value => - The_Variable.Value := Dot_String; - - when Object_Dir_Value => - From_Project_Node_Tree.Project_Nodes.Table - (The_Current_Term).Name := - Snames.Name_Object_Dir; - From_Project_Node_Tree.Project_Nodes.Table - (The_Current_Term).Default := - Dot_Value; - goto Object_Dir_Restart; - - when Target_Value => - if Opt.Target_Value = null then - The_Variable.Value := Empty_String; - - else - Name_Len := 0; - Add_Str_To_Name_Buffer - (Opt.Target_Value.all); - The_Variable.Value := Name_Find; - end if; - - when Runtime_Value => - Get_Name_String (Index); - To_Lower (Name_Buffer (1 .. Name_Len)); - The_Variable.Value := - Runtime_Defaults.Get (Name_Find); - if The_Variable.Value = No_Name then - The_Variable.Value := Empty_String; - end if; - - end case; - - when List => - case The_Default is - when Read_Only_Value => - null; - - when Empty_Value => - The_Variable.Values := Nil_String; - - when Dot_Value => - The_Variable.Values := - Shared.Dot_String_List; - - when Object_Dir_Value - | Runtime_Value - | Target_Value - => - null; - end case; - end case; - 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; - end if; - - 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; - No_Extending : Boolean := False) 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 - if No_Extending then - Temp_Result := Proj; - else - Temp_Result := Result; - end if; - - 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; - On_New_Tree_Loaded : Tree_Loaded_Callback := null) - 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, - On_New_Tree_Loaded => On_New_Tree_Loaded); - - 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, - Silent => True); - 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; - 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, No_Extending => True); - The_Package := No_Package; - 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 - if Node_Tree.Incomplete_With then - return; - - -- Should never happen, because this has already been checked - -- during parsing. - - else - Write_Line - ("variable """ & Get_Name_String (Name) & """ not found"); - raise Program_Error; - end if; - 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; - On_New_Tree_Loaded : Tree_Loaded_Callback := null) - 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, - On_New_Tree_Loaded => On_New_Tree_Loaded); - - 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; - On_New_Tree_Loaded : Tree_Loaded_Callback := null) - 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, - On_New_Tree_Loaded => On_New_Tree_Loaded); - - 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 - if Node_Tree.Incomplete_With then - From_Project_Node_Tree.Incomplete_With := True; - end if; - - 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, - On_New_Tree_Loaded => On_New_Tree_Loaded); - 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, - On_New_Tree_Loaded => On_New_Tree_Loaded); - end if; - - if On_New_Tree_Loaded /= null then - On_New_Tree_Loaded - (Node_Tree, Tree, Loaded_Project, List.Project); - 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); - - Display_Name : constant Name_Id := - Display_Name_Of - (From_Project_Node, From_Project_Node_Tree); - - begin - Project := Processed_Projects.Get (Name); - - if Project /= No_Project then - - -- Make sure that, when a project is extended, the project id - -- of the project extending it is recorded in its data, even - -- when it has already been processed as an imported project. - -- This is for virtually extended projects. - - if Extended_By /= No_Project then - Project.Extended_By := Extended_By; - end if; - - return; - end if; - - -- Check if the project is already in the tree - - Project := No_Project; - - declare - List : Project_List := In_Tree.Projects; - Path : constant Path_Name_Type := - Path_Name_Of (From_Project_Node, - From_Project_Node_Tree); - - begin - while List /= null loop - if List.Project.Path.Display_Name = Path then - Project := List.Project; - exit; - end if; - - List := List.Next; - end loop; - end; - - if Project = No_Project then - 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); - end if; - - -- Keep track of this point - - Mark := In_Tree.Projects; - - Processed_Projects.Set (Name, Project); - - Project.Name := Name; - Project.Display_Name := 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 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, - On_New_Tree_Loaded => On_New_Tree_Loaded); - - 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; - - ----------------------------- - -- Set_Default_Runtime_For -- - ----------------------------- - - procedure Set_Default_Runtime_For (Language : Name_Id; Value : String) is - begin - Name_Len := Value'Length; - Name_Buffer (1 .. Name_Len) := Value; - Runtime_Defaults.Set (Language, Name_Find); - end Set_Default_Runtime_For; -end Prj.Proc; |