| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- P R J . P R O C -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- $Revision$ |
| -- -- |
| -- Copyright (C) 2001 Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 2, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING. If not, write -- |
| -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- |
| -- MA 02111-1307, USA. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Errout; use Errout; |
| with Namet; use Namet; |
| with Opt; |
| with Output; use Output; |
| with Prj.Attr; use Prj.Attr; |
| with Prj.Com; use Prj.Com; |
| with Prj.Ext; use Prj.Ext; |
| with Prj.Nmsc; use Prj.Nmsc; |
| with Stringt; use Stringt; |
| |
| with GNAT.Case_Util; |
| with GNAT.HTable; |
| |
| package body Prj.Proc is |
| |
| Error_Report : Put_Line_Access := null; |
| |
| package Processed_Projects is new GNAT.HTable.Simple_HTable |
| (Header_Num => Header_Num, |
| Element => Project_Id, |
| No_Element => No_Project, |
| Key => Name_Id, |
| Hash => Hash, |
| Equal => "="); |
| -- This hash table contains all processed projects |
| |
| procedure Add (To_Exp : in out String_Id; Str : String_Id); |
| -- Concatenate two strings and returns another string if both |
| -- arguments are not null string. |
| |
| procedure Add_Attributes |
| (Decl : in out Declarations; |
| First : Attribute_Node_Id); |
| -- Add all attributes, starting with First, with their default |
| -- values to the package or project with declarations Decl. |
| |
| function Expression |
| (Project : Project_Id; |
| From_Project_Node : Project_Node_Id; |
| 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_Modified_Project_From |
| (Project : Project_Id; |
| With_Name : Name_Id) |
| return Project_Id; |
| -- Find an imported or modified project of Project whose name is With_Name. |
| |
| function Package_From |
| (Project : Project_Id; |
| With_Name : Name_Id) |
| return Package_Id; |
| -- Find the package of Project whose name is With_Name. |
| |
| procedure Process_Declarative_Items |
| (Project : Project_Id; |
| From_Project_Node : Project_Node_Id; |
| Pkg : Package_Id; |
| Item : Project_Node_Id); |
| -- Process declarative items starting with From_Project_Node, and put them |
| -- in declarations Decl. This is a recursive procedure; it calls itself for |
| -- a package declaration or a case construction. |
| |
| procedure Recursive_Process |
| (Project : out Project_Id; |
| From_Project_Node : Project_Node_Id; |
| Modified_By : Project_Id); |
| -- Process project with node From_Project_Node in the tree. |
| -- Do nothing if From_Project_Node is Empty_Node. |
| -- If project has already been processed, simply return its project id. |
| -- Otherwise create a new project id, mark it as processed, call itself |
| -- recursively for all imported projects and a modified project, if any. |
| -- Then process the declarative items of the project. |
| |
| procedure Check (Project : in out Project_Id); |
| -- Set all projects to not checked, then call Recursive_Check for |
| -- the main project Project. |
| -- Project is set to No_Project if errors occurred. |
| |
| procedure Recursive_Check (Project : Project_Id); |
| -- If Project is marked as not checked, mark it as checked, |
| -- call Check_Naming_Scheme for the project, then call itself |
| -- for a possible modified project and all the imported projects |
| -- of Project. |
| |
| --------- |
| -- Add -- |
| --------- |
| |
| procedure Add (To_Exp : in out String_Id; Str : String_Id) is |
| begin |
| if To_Exp = Types.No_String or else String_Length (To_Exp) = 0 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_String then |
| Start_String (To_Exp); |
| Store_String_Chars (Str); |
| To_Exp := End_String; |
| end if; |
| end Add; |
| |
| -------------------- |
| -- Add_Attributes -- |
| -------------------- |
| |
| procedure Add_Attributes |
| (Decl : in out Declarations; |
| First : Attribute_Node_Id) is |
| The_Attribute : Attribute_Node_Id := First; |
| Attribute_Data : Attribute_Record; |
| |
| begin |
| while The_Attribute /= Empty_Attribute loop |
| Attribute_Data := Attributes.Table (The_Attribute); |
| |
| if Attribute_Data.Kind_2 /= Associative_Array then |
| declare |
| New_Attribute : Variable_Value; |
| |
| begin |
| case Attribute_Data.Kind_1 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 := |
| (Kind => Single, |
| Location => No_Location, |
| Default => True, |
| Value => Empty_String); |
| |
| -- List attributes have a default value of nil list |
| |
| when List => |
| New_Attribute := |
| (Kind => List, |
| Location => No_Location, |
| Default => True, |
| Values => Nil_String); |
| |
| end case; |
| |
| Variable_Elements.Increment_Last; |
| Variable_Elements.Table (Variable_Elements.Last) := |
| (Next => Decl.Attributes, |
| Name => Attribute_Data.Name, |
| Value => New_Attribute); |
| Decl.Attributes := Variable_Elements.Last; |
| end; |
| end if; |
| |
| The_Attribute := Attributes.Table (The_Attribute).Next; |
| end loop; |
| |
| end Add_Attributes; |
| |
| ----------- |
| -- Check -- |
| ----------- |
| |
| procedure Check (Project : in out Project_Id) is |
| begin |
| -- Make sure that all projects are marked as not checked. |
| |
| for Index in 1 .. Projects.Last loop |
| Projects.Table (Index).Checked := False; |
| end loop; |
| |
| Recursive_Check (Project); |
| |
| if Errout.Errors_Detected > 0 then |
| Project := No_Project; |
| end if; |
| |
| end Check; |
| |
| ---------------- |
| -- Expression -- |
| ---------------- |
| |
| function Expression |
| (Project : Project_Id; |
| From_Project_Node : Project_Node_Id; |
| Pkg : Package_Id; |
| First_Term : Project_Node_Id; |
| Kind : Variable_Kind) |
| return Variable_Value |
| is |
| The_Term : Project_Node_Id := First_Term; |
| -- The term in the expression list |
| |
| The_Current_Term : Project_Node_Id := Empty_Node; |
| -- The current term node id |
| |
| Term_Kind : Variable_Kind; |
| -- The kind of the current term |
| |
| 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.Location := Location_Of (First_Term); |
| |
| -- Process each term of the expression, starting with First_Term |
| |
| while The_Term /= Empty_Node loop |
| |
| -- We get the term data and kind ... |
| |
| Term_Kind := Expression_Kind_Of (The_Term); |
| |
| The_Current_Term := Current_Term (The_Term); |
| |
| case Kind_Of (The_Current_Term) 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)); |
| |
| when List => |
| |
| String_Elements.Increment_Last; |
| |
| if Last = Nil_String then |
| |
| -- This can happen in an expression such as |
| -- () & "toto" |
| |
| Result.Values := String_Elements.Last; |
| |
| else |
| String_Elements.Table (Last).Next := |
| String_Elements.Last; |
| end if; |
| |
| Last := String_Elements.Last; |
| String_Elements.Table (Last) := |
| (Value => String_Value_Of (The_Current_Term), |
| Location => Location_Of (The_Current_Term), |
| Next => Nil_String); |
| |
| end case; |
| |
| when N_Literal_String_List => |
| |
| declare |
| String_Node : Project_Node_Id := |
| First_Expression_In_List (The_Current_Term); |
| |
| Value : Variable_Value; |
| |
| begin |
| if String_Node /= Empty_Node then |
| |
| -- If String_Node is nil, it is an empty list, |
| -- there is nothing to do |
| |
| Value := Expression |
| (Project => Project, |
| From_Project_Node => From_Project_Node, |
| Pkg => Pkg, |
| First_Term => Tree.First_Term (String_Node), |
| Kind => Single); |
| String_Elements.Increment_Last; |
| |
| if Result.Values = Nil_String then |
| |
| -- This literal string list is the first term |
| -- in a string list expression |
| |
| Result.Values := String_Elements.Last; |
| |
| else |
| String_Elements.Table (Last).Next := |
| String_Elements.Last; |
| end if; |
| |
| Last := String_Elements.Last; |
| String_Elements.Table (Last) := |
| (Value => Value.Value, |
| Location => Value.Location, |
| Next => Nil_String); |
| |
| loop |
| -- Add the other element of the literal string list |
| -- one after the other |
| |
| String_Node := |
| Next_Expression_In_List (String_Node); |
| |
| exit when String_Node = Empty_Node; |
| |
| Value := |
| Expression |
| (Project => Project, |
| From_Project_Node => From_Project_Node, |
| Pkg => Pkg, |
| First_Term => Tree.First_Term (String_Node), |
| Kind => Single); |
| |
| String_Elements.Increment_Last; |
| String_Elements.Table (Last).Next := |
| String_Elements.Last; |
| Last := String_Elements.Last; |
| String_Elements.Table (Last) := |
| (Value => Value.Value, |
| Location => Value.Location, |
| Next => Nil_String); |
| 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; |
| Term_Project : constant Project_Node_Id := |
| Project_Node_Of (The_Current_Term); |
| Term_Package : constant Project_Node_Id := |
| Package_Node_Of (The_Current_Term); |
| |
| begin |
| if Term_Project /= Empty_Node and then |
| Term_Project /= From_Project_Node |
| then |
| -- This variable or attribute comes from another project |
| |
| The_Name := Name_Of (Term_Project); |
| The_Project := Imported_Or_Modified_Project_From |
| (Project => Project, With_Name => The_Name); |
| end if; |
| |
| if Term_Package /= Empty_Node then |
| |
| -- This is an attribute of a package |
| |
| The_Name := Name_Of (Term_Package); |
| The_Package := Projects.Table (The_Project).Decl.Packages; |
| |
| while The_Package /= No_Package |
| and then Packages.Table (The_Package).Name /= The_Name |
| loop |
| The_Package := Packages.Table (The_Package).Next; |
| end loop; |
| |
| pragma Assert |
| (The_Package /= No_Package, |
| "package not found."); |
| |
| elsif Kind_Of (The_Current_Term) = N_Attribute_Reference then |
| The_Package := No_Package; |
| end if; |
| |
| The_Name := Name_Of (The_Current_Term); |
| |
| if The_Package /= No_Package then |
| |
| -- First, if there is a package, look into the package |
| |
| if Kind_Of (The_Current_Term) = N_Variable_Reference then |
| The_Variable_Id := |
| Packages.Table (The_Package).Decl.Variables; |
| |
| else |
| The_Variable_Id := |
| Packages.Table (The_Package).Decl.Attributes; |
| end if; |
| |
| while The_Variable_Id /= No_Variable |
| and then |
| Variable_Elements.Table (The_Variable_Id).Name /= |
| The_Name |
| loop |
| The_Variable_Id := |
| 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) = N_Variable_Reference then |
| The_Variable_Id := |
| Projects.Table (The_Project).Decl.Variables; |
| |
| else |
| The_Variable_Id := |
| Projects.Table (The_Project).Decl.Attributes; |
| end if; |
| |
| while The_Variable_Id /= No_Variable |
| and then |
| Variable_Elements.Table (The_Variable_Id).Name /= |
| The_Name |
| loop |
| The_Variable_Id := |
| 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 := Variable_Elements.Table (The_Variable_Id); |
| |
| case Kind is |
| |
| when Undefined => |
| |
| -- Should never happen |
| |
| pragma Assert (False, "undefined expression kind"); |
| null; |
| |
| when Single => |
| |
| case The_Variable.Value.Kind is |
| |
| when Undefined => |
| null; |
| |
| when Single => |
| Add (Result.Value, The_Variable.Value.Value); |
| |
| when List => |
| |
| -- Should never happen |
| |
| pragma Assert |
| (False, |
| "list cannot appear in single " & |
| "string expression"); |
| null; |
| |
| end case; |
| |
| when List => |
| case The_Variable.Value.Kind is |
| |
| when Undefined => |
| null; |
| |
| when Single => |
| String_Elements.Increment_Last; |
| |
| if Last = Nil_String then |
| |
| -- This can happen in an expression such as |
| -- () & Var |
| |
| Result.Values := String_Elements.Last; |
| |
| else |
| String_Elements.Table (Last).Next := |
| String_Elements.Last; |
| end if; |
| |
| Last := String_Elements.Last; |
| String_Elements.Table (Last) := |
| (Value => The_Variable.Value.Value, |
| Location => Location_Of (The_Current_Term), |
| Next => Nil_String); |
| |
| when List => |
| |
| declare |
| The_List : String_List_Id := |
| The_Variable.Value.Values; |
| |
| begin |
| while The_List /= Nil_String loop |
| String_Elements.Increment_Last; |
| |
| if Last = Nil_String then |
| Result.Values := String_Elements.Last; |
| |
| else |
| String_Elements.Table (Last).Next := |
| String_Elements.Last; |
| |
| end if; |
| |
| Last := String_Elements.Last; |
| String_Elements.Table (Last) := |
| (Value => |
| String_Elements.Table |
| (The_List).Value, |
| Location => Location_Of |
| (The_Current_Term), |
| Next => Nil_String); |
| The_List := |
| String_Elements.Table (The_List).Next; |
| |
| end loop; |
| end; |
| end case; |
| end case; |
| end; |
| |
| when N_External_Value => |
| String_To_Name_Buffer |
| (String_Value_Of (External_Reference_Of (The_Current_Term))); |
| |
| declare |
| Name : constant Name_Id := Name_Find; |
| Default : String_Id := No_String; |
| Value : String_Id := No_String; |
| |
| Default_Node : constant Project_Node_Id := |
| External_Default_Of (The_Current_Term); |
| |
| begin |
| if Default_Node /= Empty_Node then |
| Default := String_Value_Of (Default_Node); |
| end if; |
| |
| Value := Prj.Ext.Value_Of (Name, Default); |
| |
| if Value = No_String then |
| if Error_Report = null then |
| Error_Msg |
| ("undefined external reference", |
| Location_Of (The_Current_Term)); |
| |
| else |
| Error_Report |
| ("""" & Get_Name_String (Name) & |
| """ is an undefined external reference"); |
| end if; |
| |
| Value := Empty_String; |
| |
| end if; |
| |
| case Kind is |
| |
| when Undefined => |
| null; |
| |
| when Single => |
| Add (Result.Value, Value); |
| |
| when List => |
| String_Elements.Increment_Last; |
| |
| if Last = Nil_String then |
| Result.Values := String_Elements.Last; |
| |
| else |
| String_Elements.Table (Last).Next := |
| String_Elements.Last; |
| end if; |
| |
| Last := String_Elements.Last; |
| String_Elements.Table (Last) := |
| (Value => Value, |
| Location => Location_Of (The_Current_Term), |
| Next => Nil_String); |
| |
| 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); |
| end loop; |
| |
| return Result; |
| end Expression; |
| |
| --------------------------------------- |
| -- Imported_Or_Modified_Project_From -- |
| --------------------------------------- |
| |
| function Imported_Or_Modified_Project_From |
| (Project : Project_Id; |
| With_Name : Name_Id) |
| return Project_Id |
| is |
| Data : constant Project_Data := Projects.Table (Project); |
| List : Project_List := Data.Imported_Projects; |
| |
| begin |
| -- First check if it is the name of a modified project |
| |
| if Data.Modifies /= No_Project |
| and then Projects.Table (Data.Modifies).Name = With_Name |
| then |
| return Data.Modifies; |
| |
| else |
| -- Then check the name of each imported project |
| |
| while List /= Empty_Project_List |
| and then |
| Projects.Table |
| (Project_Lists.Table (List).Project).Name /= With_Name |
| |
| loop |
| List := Project_Lists.Table (List).Next; |
| end loop; |
| |
| pragma Assert |
| (List /= Empty_Project_List, |
| "project not found"); |
| |
| return Project_Lists.Table (List).Project; |
| end if; |
| end Imported_Or_Modified_Project_From; |
| |
| ------------------ |
| -- Package_From -- |
| ------------------ |
| |
| function Package_From |
| (Project : Project_Id; |
| With_Name : Name_Id) |
| return Package_Id |
| is |
| Data : constant Project_Data := Projects.Table (Project); |
| Result : Package_Id := Data.Decl.Packages; |
| |
| begin |
| -- Check the name of each existing package of Project |
| |
| while Result /= No_Package |
| and then |
| Packages.Table (Result).Name /= With_Name |
| loop |
| Result := 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 |
| (Project : out Project_Id; |
| From_Project_Node : Project_Node_Id; |
| Report_Error : Put_Line_Access) |
| is |
| begin |
| Error_Report := Report_Error; |
| |
| -- Make sure there is no projects in the data structure |
| |
| Projects.Set_Last (No_Project); |
| Processed_Projects.Reset; |
| |
| -- And process the main project and all of the projects it depends on, |
| -- recursively |
| |
| Recursive_Process |
| (Project => Project, |
| From_Project_Node => From_Project_Node, |
| Modified_By => No_Project); |
| |
| if Errout.Errors_Detected > 0 then |
| Project := No_Project; |
| end if; |
| |
| if Project /= No_Project then |
| Check (Project); |
| end if; |
| |
| end Process; |
| |
| ------------------------------- |
| -- Process_Declarative_Items -- |
| ------------------------------- |
| |
| procedure Process_Declarative_Items |
| (Project : Project_Id; |
| From_Project_Node : Project_Node_Id; |
| Pkg : Package_Id; |
| Item : Project_Node_Id) is |
| |
| Current_Declarative_Item : Project_Node_Id := Item; |
| |
| Current_Item : Project_Node_Id := Empty_Node; |
| |
| begin |
| -- For each declarative item |
| |
| while Current_Declarative_Item /= Empty_Node loop |
| |
| -- Get its data |
| |
| Current_Item := Current_Item_Node (Current_Declarative_Item); |
| |
| -- And set Current_Declarative_Item to the next declarative item |
| -- ready for the next iteration |
| |
| Current_Declarative_Item := Next_Declarative_Item |
| (Current_Declarative_Item); |
| |
| case Kind_Of (Current_Item) is |
| |
| when N_Package_Declaration => |
| Packages.Increment_Last; |
| |
| declare |
| New_Pkg : constant Package_Id := Packages.Last; |
| The_New_Package : Package_Element; |
| |
| Project_Of_Renamed_Package : constant Project_Node_Id := |
| Project_Of_Renamed_Package_Of |
| (Current_Item); |
| |
| begin |
| The_New_Package.Name := Name_Of (Current_Item); |
| |
| if Pkg /= No_Package then |
| The_New_Package.Next := |
| Packages.Table (Pkg).Decl.Packages; |
| Packages.Table (Pkg).Decl.Packages := New_Pkg; |
| else |
| The_New_Package.Next := |
| Projects.Table (Project).Decl.Packages; |
| Projects.Table (Project).Decl.Packages := New_Pkg; |
| end if; |
| |
| Packages.Table (New_Pkg) := The_New_Package; |
| |
| if Project_Of_Renamed_Package /= Empty_Node then |
| |
| -- Renamed package |
| |
| declare |
| Project_Name : constant Name_Id := |
| Name_Of |
| (Project_Of_Renamed_Package); |
| |
| Renamed_Project : constant Project_Id := |
| Imported_Or_Modified_Project_From |
| (Project, Project_Name); |
| |
| Renamed_Package : constant Package_Id := |
| Package_From |
| (Renamed_Project, |
| Name_Of (Current_Item)); |
| |
| begin |
| Packages.Table (New_Pkg).Decl := |
| Packages.Table (Renamed_Package).Decl; |
| end; |
| |
| else |
| -- Set the default values of the attributes |
| |
| Add_Attributes |
| (Packages.Table (New_Pkg).Decl, |
| Package_Attributes.Table |
| (Package_Id_Of (Current_Item)).First_Attribute); |
| |
| Process_Declarative_Items |
| (Project => Project, |
| From_Project_Node => From_Project_Node, |
| Pkg => New_Pkg, |
| Item => First_Declarative_Item_Of |
| (Current_Item)); |
| end if; |
| |
| end; |
| |
| when N_String_Type_Declaration => |
| |
| -- There is nothing to process |
| |
| null; |
| |
| when N_Attribute_Declaration | |
| N_Typed_Variable_Declaration | |
| N_Variable_Declaration => |
| |
| pragma Assert (Expression_Of (Current_Item) /= Empty_Node, |
| "no expression for an object declaration"); |
| |
| declare |
| New_Value : constant Variable_Value := |
| Expression |
| (Project => Project, |
| From_Project_Node => From_Project_Node, |
| Pkg => Pkg, |
| First_Term => |
| Tree.First_Term (Expression_Of |
| (Current_Item)), |
| Kind => |
| Expression_Kind_Of (Current_Item)); |
| |
| The_Variable : Variable_Id := No_Variable; |
| |
| Current_Item_Name : constant Name_Id := |
| Name_Of (Current_Item); |
| |
| begin |
| if Kind_Of (Current_Item) = N_Typed_Variable_Declaration then |
| |
| if String_Equal (New_Value.Value, Empty_String) then |
| Error_Msg_Name_1 := Name_Of (Current_Item); |
| |
| if Error_Report = null then |
| Error_Msg |
| ("no value defined for %", |
| Location_Of (Current_Item)); |
| |
| else |
| Error_Report |
| ("no value defined for " & |
| Get_Name_String (Error_Msg_Name_1)); |
| end if; |
| |
| else |
| declare |
| Current_String : Project_Node_Id := |
| First_Literal_String |
| (String_Type_Of |
| (Current_Item)); |
| |
| begin |
| while Current_String /= Empty_Node |
| and then not String_Equal |
| (String_Value_Of (Current_String), |
| New_Value.Value) |
| loop |
| Current_String := |
| Next_Literal_String (Current_String); |
| end loop; |
| |
| if Current_String = Empty_Node then |
| String_To_Name_Buffer (New_Value.Value); |
| Error_Msg_Name_1 := Name_Find; |
| Error_Msg_Name_2 := Name_Of (Current_Item); |
| |
| if Error_Report = null then |
| Error_Msg |
| ("value { is illegal for typed string %", |
| Location_Of (Current_Item)); |
| |
| else |
| Error_Report |
| ("value """ & |
| Get_Name_String (Error_Msg_Name_1) & |
| """ is illegal for typed string """ & |
| Get_Name_String (Error_Msg_Name_2) & |
| """"); |
| end if; |
| end if; |
| end; |
| end if; |
| end if; |
| |
| if Kind_Of (Current_Item) /= N_Attribute_Declaration |
| or else |
| Associative_Array_Index_Of (Current_Item) = No_String |
| then |
| -- Usual case |
| |
| -- Code below really needs more comments ??? |
| |
| if Kind_Of (Current_Item) = N_Attribute_Declaration then |
| if Pkg /= No_Package then |
| The_Variable := |
| Packages.Table (Pkg).Decl.Attributes; |
| |
| else |
| The_Variable := |
| Projects.Table (Project).Decl.Attributes; |
| end if; |
| |
| else |
| if Pkg /= No_Package then |
| The_Variable := |
| Packages.Table (Pkg).Decl.Variables; |
| |
| else |
| The_Variable := |
| Projects.Table (Project).Decl.Variables; |
| end if; |
| |
| end if; |
| |
| while |
| The_Variable /= No_Variable |
| and then |
| Variable_Elements.Table (The_Variable).Name /= |
| Current_Item_Name |
| loop |
| The_Variable := |
| Variable_Elements.Table (The_Variable).Next; |
| end loop; |
| |
| if The_Variable = No_Variable then |
| pragma Assert |
| (Kind_Of (Current_Item) /= N_Attribute_Declaration, |
| "illegal attribute declaration"); |
| |
| Variable_Elements.Increment_Last; |
| The_Variable := Variable_Elements.Last; |
| |
| if Pkg /= No_Package then |
| Variable_Elements.Table (The_Variable) := |
| (Next => |
| Packages.Table (Pkg).Decl.Variables, |
| Name => Current_Item_Name, |
| Value => New_Value); |
| Packages.Table (Pkg).Decl.Variables := The_Variable; |
| |
| else |
| Variable_Elements.Table (The_Variable) := |
| (Next => |
| Projects.Table (Project).Decl.Variables, |
| Name => Current_Item_Name, |
| Value => New_Value); |
| Projects.Table (Project).Decl.Variables := |
| The_Variable; |
| end if; |
| |
| else |
| Variable_Elements.Table (The_Variable).Value := |
| New_Value; |
| |
| end if; |
| |
| else |
| -- Associative array attribute |
| |
| String_To_Name_Buffer |
| (Associative_Array_Index_Of (Current_Item)); |
| |
| if Case_Insensitive (Current_Item) then |
| GNAT.Case_Util.To_Lower (Name_Buffer (1 .. Name_Len)); |
| end if; |
| |
| declare |
| The_Array : Array_Id; |
| |
| The_Array_Element : Array_Element_Id := |
| No_Array_Element; |
| |
| Index_Name : constant Name_Id := Name_Find; |
| |
| begin |
| |
| if Pkg /= No_Package then |
| The_Array := Packages.Table (Pkg).Decl.Arrays; |
| |
| else |
| The_Array := Projects.Table (Project).Decl.Arrays; |
| end if; |
| |
| while |
| The_Array /= No_Array |
| and then Arrays.Table (The_Array).Name /= |
| Current_Item_Name |
| loop |
| The_Array := Arrays.Table (The_Array).Next; |
| end loop; |
| |
| if The_Array = No_Array then |
| Arrays.Increment_Last; |
| The_Array := Arrays.Last; |
| |
| if Pkg /= No_Package then |
| Arrays.Table (The_Array) := |
| (Name => Current_Item_Name, |
| Value => No_Array_Element, |
| Next => Packages.Table (Pkg).Decl.Arrays); |
| Packages.Table (Pkg).Decl.Arrays := The_Array; |
| |
| else |
| Arrays.Table (The_Array) := |
| (Name => Current_Item_Name, |
| Value => No_Array_Element, |
| Next => |
| Projects.Table (Project).Decl.Arrays); |
| Projects.Table (Project).Decl.Arrays := |
| The_Array; |
| end if; |
| |
| else |
| The_Array_Element := Arrays.Table (The_Array).Value; |
| end if; |
| |
| while The_Array_Element /= No_Array_Element |
| and then |
| Array_Elements.Table (The_Array_Element).Index /= |
| Index_Name |
| loop |
| The_Array_Element := |
| Array_Elements.Table (The_Array_Element).Next; |
| end loop; |
| |
| if The_Array_Element = No_Array_Element then |
| Array_Elements.Increment_Last; |
| The_Array_Element := Array_Elements.Last; |
| Array_Elements.Table (The_Array_Element) := |
| (Index => Index_Name, |
| Value => New_Value, |
| Next => Arrays.Table (The_Array).Value); |
| Arrays.Table (The_Array).Value := The_Array_Element; |
| |
| else |
| Array_Elements.Table (The_Array_Element).Value := |
| New_Value; |
| end if; |
| end; |
| end if; |
| end; |
| |
| when N_Case_Construction => |
| declare |
| The_Project : Project_Id := Project; |
| The_Package : Package_Id := Pkg; |
| The_Variable : Variable_Value := Nil_Variable_Value; |
| Case_Value : String_Id := No_String; |
| 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); |
| |
| Var_Id : Variable_Id := No_Variable; |
| Name : Name_Id := No_Name; |
| |
| begin |
| if Project_Node_Of (Variable_Node) /= Empty_Node then |
| Name := Name_Of (Project_Node_Of (Variable_Node)); |
| The_Project := |
| Imported_Or_Modified_Project_From (Project, Name); |
| end if; |
| |
| if Package_Node_Of (Variable_Node) /= Empty_Node then |
| Name := Name_Of (Package_Node_Of (Variable_Node)); |
| The_Package := Package_From (The_Project, Name); |
| end if; |
| |
| Name := Name_Of (Variable_Node); |
| |
| if The_Package /= No_Package then |
| Var_Id := Packages.Table (The_Package).Decl.Variables; |
| Name := Name_Of (Variable_Node); |
| while Var_Id /= No_Variable |
| and then |
| Variable_Elements.Table (Var_Id).Name /= Name |
| loop |
| Var_Id := Variable_Elements.Table (Var_Id).Next; |
| end loop; |
| end if; |
| |
| if Var_Id = No_Variable |
| and then Package_Node_Of (Variable_Node) = Empty_Node |
| then |
| Var_Id := Projects.Table (The_Project).Decl.Variables; |
| while Var_Id /= No_Variable |
| and then |
| Variable_Elements.Table (Var_Id).Name /= Name |
| loop |
| Var_Id := Variable_Elements.Table (Var_Id).Next; |
| end loop; |
| end if; |
| |
| if Var_Id = No_Variable then |
| |
| -- Should never happen |
| |
| Write_Line ("variable """ & |
| Get_Name_String (Name) & |
| """ not found"); |
| raise Program_Error; |
| end if; |
| |
| The_Variable := Variable_Elements.Table (Var_Id).Value; |
| |
| if The_Variable.Kind /= Single then |
| |
| -- Should never happen |
| |
| Write_Line ("variable""" & |
| Get_Name_String (Name) & |
| """ is not a single string variable"); |
| raise Program_Error; |
| end if; |
| |
| Case_Value := The_Variable.Value; |
| end; |
| |
| Case_Item := First_Case_Item_Of (Current_Item); |
| Case_Item_Loop : |
| while Case_Item /= Empty_Node loop |
| Choice_String := First_Choice_Of (Case_Item); |
| |
| if Choice_String = Empty_Node then |
| Decl_Item := First_Declarative_Item_Of (Case_Item); |
| exit Case_Item_Loop; |
| end if; |
| |
| Choice_Loop : |
| while Choice_String /= Empty_Node loop |
| if String_Equal (Case_Value, |
| String_Value_Of (Choice_String)) |
| then |
| Decl_Item := |
| First_Declarative_Item_Of (Case_Item); |
| exit Case_Item_Loop; |
| end if; |
| |
| Choice_String := |
| Next_Literal_String (Choice_String); |
| end loop Choice_Loop; |
| Case_Item := Next_Case_Item (Case_Item); |
| end loop Case_Item_Loop; |
| |
| if Decl_Item /= Empty_Node then |
| Process_Declarative_Items |
| (Project => Project, |
| From_Project_Node => From_Project_Node, |
| Pkg => Pkg, |
| Item => Decl_Item); |
| end if; |
| end; |
| |
| when others => |
| |
| -- Should never happen |
| |
| Write_Line ("Illegal declarative item: " & |
| Project_Node_Kind'Image (Kind_Of (Current_Item))); |
| raise Program_Error; |
| end case; |
| end loop; |
| end Process_Declarative_Items; |
| |
| --------------------- |
| -- Recursive_Check -- |
| --------------------- |
| |
| procedure Recursive_Check (Project : Project_Id) is |
| Data : Project_Data; |
| Imported_Project_List : Project_List := Empty_Project_List; |
| |
| begin |
| -- Do nothing if Project is No_Project, or Project has already |
| -- been marked as checked. |
| |
| if Project /= No_Project |
| and then not Projects.Table (Project).Checked |
| then |
| Data := Projects.Table (Project); |
| |
| -- Call itself for a possible modified project. |
| -- (if there is no modified project, then nothing happens). |
| |
| Recursive_Check (Data.Modifies); |
| |
| -- Call itself for all imported projects |
| |
| Imported_Project_List := Data.Imported_Projects; |
| while Imported_Project_List /= Empty_Project_List loop |
| Recursive_Check |
| (Project_Lists.Table (Imported_Project_List).Project); |
| Imported_Project_List := |
| Project_Lists.Table (Imported_Project_List).Next; |
| end loop; |
| |
| -- Mark project as checked |
| |
| Projects.Table (Project).Checked := True; |
| |
| if Opt.Verbose_Mode then |
| Write_Str ("Checking project file """); |
| Write_Str (Get_Name_String (Data.Name)); |
| Write_Line (""""); |
| end if; |
| |
| Prj.Nmsc.Ada_Check (Project, Error_Report); |
| end if; |
| end Recursive_Check; |
| |
| ----------------------- |
| -- Recursive_Process -- |
| ----------------------- |
| |
| procedure Recursive_Process |
| (Project : out Project_Id; |
| From_Project_Node : Project_Node_Id; |
| Modified_By : Project_Id) |
| is |
| With_Clause : Project_Node_Id; |
| |
| begin |
| if From_Project_Node = Empty_Node then |
| Project := No_Project; |
| |
| else |
| declare |
| Processed_Data : Project_Data := Empty_Project; |
| Imported : Project_List := Empty_Project_List; |
| Declaration_Node : Project_Node_Id := Empty_Node; |
| Name : constant Name_Id := |
| Name_Of (From_Project_Node); |
| |
| begin |
| Project := Processed_Projects.Get (Name); |
| |
| if Project /= No_Project then |
| return; |
| end if; |
| |
| Projects.Increment_Last; |
| Project := Projects.Last; |
| Processed_Projects.Set (Name, Project); |
| Processed_Data.Name := Name; |
| Processed_Data.Path_Name := Path_Name_Of (From_Project_Node); |
| Processed_Data.Location := Location_Of (From_Project_Node); |
| Processed_Data.Directory := Directory_Of (From_Project_Node); |
| Processed_Data.Modified_By := Modified_By; |
| Add_Attributes (Processed_Data.Decl, Attribute_First); |
| With_Clause := First_With_Clause_Of (From_Project_Node); |
| |
| while With_Clause /= Empty_Node loop |
| declare |
| New_Project : Project_Id; |
| New_Data : Project_Data; |
| |
| begin |
| Recursive_Process |
| (Project => New_Project, |
| From_Project_Node => Project_Node_Of (With_Clause), |
| Modified_By => No_Project); |
| New_Data := Projects.Table (New_Project); |
| |
| -- If we were the first project to import it, |
| -- set First_Referred_By to us. |
| |
| if New_Data.First_Referred_By = No_Project then |
| New_Data.First_Referred_By := Project; |
| Projects.Table (New_Project) := New_Data; |
| end if; |
| |
| -- Add this project to our list of imported projects |
| |
| Project_Lists.Increment_Last; |
| Project_Lists.Table (Project_Lists.Last) := |
| (Project => New_Project, Next => Empty_Project_List); |
| |
| -- Imported is the id of the last imported project. |
| -- If it is nil, then this imported project is our first. |
| |
| if Imported = Empty_Project_List then |
| Processed_Data.Imported_Projects := Project_Lists.Last; |
| |
| else |
| Project_Lists.Table (Imported).Next := Project_Lists.Last; |
| end if; |
| |
| Imported := Project_Lists.Last; |
| |
| With_Clause := Next_With_Clause_Of (With_Clause); |
| end; |
| end loop; |
| |
| Declaration_Node := Project_Declaration_Of (From_Project_Node); |
| |
| Recursive_Process |
| (Project => Processed_Data.Modifies, |
| From_Project_Node => Modified_Project_Of (Declaration_Node), |
| Modified_By => Project); |
| |
| Projects.Table (Project) := Processed_Data; |
| |
| Process_Declarative_Items |
| (Project => Project, |
| From_Project_Node => From_Project_Node, |
| Pkg => No_Package, |
| Item => First_Declarative_Item_Of |
| (Declaration_Node)); |
| |
| end; |
| end if; |
| end Recursive_Process; |
| |
| end Prj.Proc; |
