diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/prj.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/prj.adb | 836 |
1 files changed, 0 insertions, 836 deletions
diff --git a/gcc-4.2.1/gcc/ada/prj.adb b/gcc-4.2.1/gcc/ada/prj.adb deleted file mode 100644 index 7f85ed304..000000000 --- a/gcc-4.2.1/gcc/ada/prj.adb +++ /dev/null @@ -1,836 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- P R J -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Characters.Handling; use Ada.Characters.Handling; - -with Namet; use Namet; -with Output; use Output; -with Osint; use Osint; -with Prj.Attr; -with Prj.Env; -with Prj.Err; use Prj.Err; -with Snames; use Snames; -with Uintp; use Uintp; - -with GNAT.Case_Util; use GNAT.Case_Util; - -package body Prj is - - Initial_Buffer_Size : constant := 100; - -- Initial size for extensible buffer used in Add_To_Buffer - - The_Empty_String : Name_Id; - - Name_C_Plus_Plus : Name_Id; - - Default_Ada_Spec_Suffix_Id : Name_Id; - Default_Ada_Body_Suffix_Id : Name_Id; - Slash_Id : Name_Id; - -- Initialized in Prj.Initialized, then never modified - - subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case; - - The_Casing_Images : constant array (Known_Casing) of String_Access := - (All_Lower_Case => new String'("lowercase"), - All_Upper_Case => new String'("UPPERCASE"), - Mixed_Case => new String'("MixedCase")); - - Initialized : Boolean := False; - - Standard_Dot_Replacement : constant Name_Id := - First_Name_Id + Character'Pos ('-'); - - Std_Naming_Data : Naming_Data := - (Dot_Replacement => Standard_Dot_Replacement, - Dot_Repl_Loc => No_Location, - Casing => All_Lower_Case, - Spec_Suffix => No_Array_Element, - Ada_Spec_Suffix => No_Name, - Spec_Suffix_Loc => No_Location, - Impl_Suffixes => No_Impl_Suffixes, - Supp_Suffixes => No_Supp_Language_Index, - Body_Suffix => No_Array_Element, - Ada_Body_Suffix => No_Name, - Body_Suffix_Loc => No_Location, - Separate_Suffix => No_Name, - Sep_Suffix_Loc => No_Location, - Specs => No_Array_Element, - Bodies => No_Array_Element, - Specification_Exceptions => No_Array_Element, - Implementation_Exceptions => No_Array_Element); - - Project_Empty : Project_Data := - (Externally_Built => False, - Languages => No_Languages, - Supp_Languages => No_Supp_Language_Index, - First_Referred_By => No_Project, - Name => No_Name, - Display_Name => No_Name, - Path_Name => No_Name, - Display_Path_Name => No_Name, - Virtual => False, - Location => No_Location, - Mains => Nil_String, - Directory => No_Name, - Display_Directory => No_Name, - Dir_Path => null, - Library => False, - Library_Dir => No_Name, - Display_Library_Dir => No_Name, - Library_Src_Dir => No_Name, - Display_Library_Src_Dir => No_Name, - Library_ALI_Dir => No_Name, - Display_Library_ALI_Dir => No_Name, - Library_Name => No_Name, - Library_Kind => Static, - Lib_Internal_Name => No_Name, - Standalone_Library => False, - Lib_Interface_ALIs => Nil_String, - Lib_Auto_Init => False, - Symbol_Data => No_Symbols, - Ada_Sources_Present => True, - Other_Sources_Present => True, - Sources => Nil_String, - First_Other_Source => No_Other_Source, - Last_Other_Source => No_Other_Source, - Imported_Directories_Switches => null, - Include_Path => null, - Include_Data_Set => False, - Source_Dirs => Nil_String, - Known_Order_Of_Source_Dirs => True, - Object_Directory => No_Name, - Display_Object_Dir => No_Name, - Library_TS => Empty_Time_Stamp, - Exec_Directory => No_Name, - Display_Exec_Dir => No_Name, - Extends => No_Project, - Extended_By => No_Project, - Naming => Std_Naming_Data, - First_Language_Processing => Default_First_Language_Processing_Data, - Supp_Language_Processing => No_Supp_Language_Index, - Default_Linker => No_Name, - Default_Linker_Path => No_Name, - Decl => No_Declarations, - Imported_Projects => Empty_Project_List, - All_Imported_Projects => Empty_Project_List, - Ada_Include_Path => null, - Ada_Objects_Path => null, - Include_Path_File => No_Name, - Objects_Path_File_With_Libs => No_Name, - Objects_Path_File_Without_Libs => No_Name, - Config_File_Name => No_Name, - Config_File_Temp => False, - Config_Checked => False, - Language_Independent_Checked => False, - Checked => False, - Seen => False, - Need_To_Build_Lib => False, - Depth => 0, - Unkept_Comments => False); - - ----------------------- - -- Add_Language_Name -- - ----------------------- - - procedure Add_Language_Name (Name : Name_Id) is - begin - Last_Language_Index := Last_Language_Index + 1; - Language_Indexes.Set (Name, Last_Language_Index); - Language_Names.Increment_Last; - Language_Names.Table (Last_Language_Index) := Name; - end Add_Language_Name; - - ------------------- - -- Add_To_Buffer -- - ------------------- - - procedure Add_To_Buffer - (S : String; - To : in out String_Access; - Last : in out Natural) - is - begin - if To = null then - To := new String (1 .. Initial_Buffer_Size); - Last := 0; - end if; - - -- If Buffer is too small, double its size - - while Last + S'Length > To'Last loop - declare - New_Buffer : constant String_Access := - new String (1 .. 2 * Last); - - begin - New_Buffer (1 .. Last) := To (1 .. Last); - Free (To); - To := New_Buffer; - end; - end loop; - - To (Last + 1 .. Last + S'Length) := S; - Last := Last + S'Length; - end Add_To_Buffer; - - ----------------------------- - -- Default_Ada_Body_Suffix -- - ----------------------------- - - function Default_Ada_Body_Suffix return Name_Id is - begin - return Default_Ada_Body_Suffix_Id; - end Default_Ada_Body_Suffix; - - ----------------------------- - -- Default_Ada_Spec_Suffix -- - ----------------------------- - - function Default_Ada_Spec_Suffix return Name_Id is - begin - return Default_Ada_Spec_Suffix_Id; - end Default_Ada_Spec_Suffix; - - --------------------------- - -- Display_Language_Name -- - --------------------------- - - procedure Display_Language_Name (Language : Language_Index) is - begin - Get_Name_String (Language_Names.Table (Language)); - To_Upper (Name_Buffer (1 .. 1)); - Write_Str (Name_Buffer (1 .. Name_Len)); - end Display_Language_Name; - - ------------------- - -- Empty_Project -- - ------------------- - - function Empty_Project (Tree : Project_Tree_Ref) return Project_Data is - Value : Project_Data; - begin - Prj.Initialize (Tree => No_Project_Tree); - Value := Project_Empty; - Value.Naming := Tree.Private_Part.Default_Naming; - return Value; - end Empty_Project; - - ------------------ - -- Empty_String -- - ------------------ - - function Empty_String return Name_Id is - begin - return The_Empty_String; - end Empty_String; - - ------------ - -- Expect -- - ------------ - - procedure Expect (The_Token : Token_Type; Token_Image : String) is - begin - if Token /= The_Token then - Error_Msg (Token_Image & " expected", Token_Ptr); - end if; - end Expect; - - -------------------------------- - -- For_Every_Project_Imported -- - -------------------------------- - - procedure For_Every_Project_Imported - (By : Project_Id; - In_Tree : Project_Tree_Ref; - With_State : in out State) - is - - procedure Recursive_Check (Project : Project_Id); - -- Check if a project has already been seen. If not seen, mark it as - -- Seen, Call Action, and check all its imported projects. - - --------------------- - -- Recursive_Check -- - --------------------- - - procedure Recursive_Check (Project : Project_Id) is - List : Project_List; - - begin - if not In_Tree.Projects.Table (Project).Seen then - In_Tree.Projects.Table (Project).Seen := True; - Action (Project, With_State); - - List := - In_Tree.Projects.Table (Project).Imported_Projects; - while List /= Empty_Project_List loop - Recursive_Check (In_Tree.Project_Lists.Table (List).Project); - List := In_Tree.Project_Lists.Table (List).Next; - end loop; - end if; - end Recursive_Check; - - -- Start of processing for For_Every_Project_Imported - - begin - for Project in Project_Table.First .. - Project_Table.Last (In_Tree.Projects) - loop - In_Tree.Projects.Table (Project).Seen := False; - end loop; - - Recursive_Check (Project => By); - end For_Every_Project_Imported; - - ---------- - -- Hash -- - ---------- - - function Hash (Name : Name_Id) return Header_Num is - begin - return Hash (Get_Name_String (Name)); - end Hash; - - ----------- - -- Image -- - ----------- - - function Image (Casing : Casing_Type) return String is - begin - return The_Casing_Images (Casing).all; - end Image; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Tree : Project_Tree_Ref) is - begin - if not Initialized then - Initialized := True; - Uintp.Initialize; - Name_Len := 0; - The_Empty_String := Name_Find; - Empty_Name := The_Empty_String; - Name_Len := 4; - Name_Buffer (1 .. 4) := ".ads"; - Default_Ada_Spec_Suffix_Id := Name_Find; - Name_Len := 4; - Name_Buffer (1 .. 4) := ".adb"; - Default_Ada_Body_Suffix_Id := Name_Find; - Name_Len := 1; - Name_Buffer (1) := '/'; - Slash_Id := Name_Find; - Name_Len := 3; - Name_Buffer (1 .. 3) := "c++"; - Name_C_Plus_Plus := Name_Find; - - Std_Naming_Data.Ada_Spec_Suffix := Default_Ada_Spec_Suffix; - Std_Naming_Data.Ada_Body_Suffix := Default_Ada_Body_Suffix; - Std_Naming_Data.Separate_Suffix := Default_Ada_Body_Suffix; - Project_Empty.Naming := Std_Naming_Data; - Prj.Env.Initialize; - Prj.Attr.Initialize; - Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project)); - Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends)); - Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External)); - - Language_Indexes.Reset; - Last_Language_Index := No_Language_Index; - Language_Names.Init; - Add_Language_Name (Name_Ada); - Add_Language_Name (Name_C); - Add_Language_Name (Name_C_Plus_Plus); - end if; - - if Tree /= No_Project_Tree then - Reset (Tree); - end if; - end Initialize; - - ---------------- - -- Is_Present -- - ---------------- - - function Is_Present - (Language : Language_Index; - In_Project : Project_Data; - In_Tree : Project_Tree_Ref) return Boolean - is - begin - case Language is - when No_Language_Index => - return False; - - when First_Language_Indexes => - return In_Project.Languages (Language); - - when others => - declare - Supp : Supp_Language; - Supp_Index : Supp_Language_Index := In_Project.Supp_Languages; - - begin - while Supp_Index /= No_Supp_Language_Index loop - Supp := In_Tree.Present_Languages.Table (Supp_Index); - - if Supp.Index = Language then - return Supp.Present; - end if; - - Supp_Index := Supp.Next; - end loop; - - return False; - end; - end case; - end Is_Present; - - --------------------------------- - -- Language_Processing_Data_Of -- - --------------------------------- - - function Language_Processing_Data_Of - (Language : Language_Index; - In_Project : Project_Data; - In_Tree : Project_Tree_Ref) return Language_Processing_Data - is - begin - case Language is - when No_Language_Index => - return Default_Language_Processing_Data; - - when First_Language_Indexes => - return In_Project.First_Language_Processing (Language); - - when others => - declare - Supp : Supp_Language_Data; - Supp_Index : Supp_Language_Index := - In_Project.Supp_Language_Processing; - - begin - while Supp_Index /= No_Supp_Language_Index loop - Supp := In_Tree.Supp_Languages.Table (Supp_Index); - - if Supp.Index = Language then - return Supp.Data; - end if; - - Supp_Index := Supp.Next; - end loop; - - return Default_Language_Processing_Data; - end; - end case; - end Language_Processing_Data_Of; - - ------------------------------------ - -- Register_Default_Naming_Scheme -- - ------------------------------------ - - procedure Register_Default_Naming_Scheme - (Language : Name_Id; - Default_Spec_Suffix : Name_Id; - Default_Body_Suffix : Name_Id; - In_Tree : Project_Tree_Ref) - is - Lang : Name_Id; - Suffix : Array_Element_Id; - Found : Boolean := False; - Element : Array_Element; - - begin - -- Get the language name in small letters - - Get_Name_String (Language); - Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len)); - Lang := Name_Find; - - Suffix := In_Tree.Private_Part.Default_Naming.Spec_Suffix; - Found := False; - - -- Look for an element of the spec sufix array indexed by the language - -- name. If one is found, put the default value. - - while Suffix /= No_Array_Element and then not Found loop - Element := In_Tree.Array_Elements.Table (Suffix); - - if Element.Index = Lang then - Found := True; - Element.Value.Value := Default_Spec_Suffix; - In_Tree.Array_Elements.Table (Suffix) := Element; - - else - Suffix := Element.Next; - end if; - end loop; - - -- If none can be found, create a new one - - if not Found then - Element := - (Index => Lang, - Src_Index => 0, - Index_Case_Sensitive => False, - Value => (Project => No_Project, - Kind => Single, - Location => No_Location, - Default => False, - Value => Default_Spec_Suffix, - Index => 0), - Next => In_Tree.Private_Part.Default_Naming.Spec_Suffix); - Array_Element_Table.Increment_Last (In_Tree.Array_Elements); - In_Tree.Array_Elements.Table - (Array_Element_Table.Last (In_Tree.Array_Elements)) := - Element; - In_Tree.Private_Part.Default_Naming.Spec_Suffix := - Array_Element_Table.Last (In_Tree.Array_Elements); - end if; - - Suffix := In_Tree.Private_Part.Default_Naming.Body_Suffix; - Found := False; - - -- Look for an element of the body sufix array indexed by the language - -- name. If one is found, put the default value. - - while Suffix /= No_Array_Element and then not Found loop - Element := In_Tree.Array_Elements.Table (Suffix); - - if Element.Index = Lang then - Found := True; - Element.Value.Value := Default_Body_Suffix; - In_Tree.Array_Elements.Table (Suffix) := Element; - - else - Suffix := Element.Next; - end if; - end loop; - - -- If none can be found, create a new one - - if not Found then - Element := - (Index => Lang, - Src_Index => 0, - Index_Case_Sensitive => False, - Value => (Project => No_Project, - Kind => Single, - Location => No_Location, - Default => False, - Value => Default_Body_Suffix, - Index => 0), - Next => In_Tree.Private_Part.Default_Naming.Body_Suffix); - Array_Element_Table.Increment_Last - (In_Tree.Array_Elements); - In_Tree.Array_Elements.Table - (Array_Element_Table.Last (In_Tree.Array_Elements)) - := Element; - In_Tree.Private_Part.Default_Naming.Body_Suffix := - Array_Element_Table.Last (In_Tree.Array_Elements); - end if; - end Register_Default_Naming_Scheme; - - ----------- - -- Reset -- - ----------- - - procedure Reset (Tree : Project_Tree_Ref) is - begin - Prj.Env.Initialize; - Present_Language_Table.Init (Tree.Present_Languages); - Supp_Suffix_Table.Init (Tree.Supp_Suffixes); - Name_List_Table.Init (Tree.Name_Lists); - Supp_Language_Table.Init (Tree.Supp_Languages); - Other_Source_Table.Init (Tree.Other_Sources); - String_Element_Table.Init (Tree.String_Elements); - Variable_Element_Table.Init (Tree.Variable_Elements); - Array_Element_Table.Init (Tree.Array_Elements); - Array_Table.Init (Tree.Arrays); - Package_Table.Init (Tree.Packages); - Project_List_Table.Init (Tree.Project_Lists); - Project_Table.Init (Tree.Projects); - Unit_Table.Init (Tree.Units); - Units_Htable.Reset (Tree.Units_HT); - Files_Htable.Reset (Tree.Files_HT); - Naming_Table.Init (Tree.Private_Part.Namings); - Naming_Table.Increment_Last (Tree.Private_Part.Namings); - Tree.Private_Part.Namings.Table - (Naming_Table.Last (Tree.Private_Part.Namings)) := Std_Naming_Data; - Path_File_Table.Init (Tree.Private_Part.Path_Files); - Source_Path_Table.Init (Tree.Private_Part.Source_Paths); - Object_Path_Table.Init (Tree.Private_Part.Object_Paths); - Tree.Private_Part.Default_Naming := Std_Naming_Data; - Register_Default_Naming_Scheme - (Language => Name_Ada, - Default_Spec_Suffix => Default_Ada_Spec_Suffix, - Default_Body_Suffix => Default_Ada_Body_Suffix, - In_Tree => Tree); - end Reset; - - ------------------------ - -- Same_Naming_Scheme -- - ------------------------ - - function Same_Naming_Scheme - (Left, Right : Naming_Data) return Boolean - is - begin - return Left.Dot_Replacement = Right.Dot_Replacement - and then Left.Casing = Right.Casing - and then Left.Ada_Spec_Suffix = Right.Ada_Spec_Suffix - and then Left.Ada_Body_Suffix = Right.Ada_Body_Suffix - and then Left.Separate_Suffix = Right.Separate_Suffix; - end Same_Naming_Scheme; - - --------- - -- Set -- - --------- - - procedure Set - (Language : Language_Index; - Present : Boolean; - In_Project : in out Project_Data; - In_Tree : Project_Tree_Ref) - is - begin - case Language is - when No_Language_Index => - null; - - when First_Language_Indexes => - In_Project.Languages (Language) := Present; - - when others => - declare - Supp : Supp_Language; - Supp_Index : Supp_Language_Index := In_Project.Supp_Languages; - - begin - while Supp_Index /= No_Supp_Language_Index loop - Supp := In_Tree.Present_Languages.Table - (Supp_Index); - - if Supp.Index = Language then - In_Tree.Present_Languages.Table - (Supp_Index).Present := Present; - return; - end if; - - Supp_Index := Supp.Next; - end loop; - - Supp := (Index => Language, Present => Present, - Next => In_Project.Supp_Languages); - Present_Language_Table.Increment_Last - (In_Tree.Present_Languages); - Supp_Index := Present_Language_Table.Last - (In_Tree.Present_Languages); - In_Tree.Present_Languages.Table (Supp_Index) := - Supp; - In_Project.Supp_Languages := Supp_Index; - end; - end case; - end Set; - - procedure Set - (Language_Processing : Language_Processing_Data; - For_Language : Language_Index; - In_Project : in out Project_Data; - In_Tree : Project_Tree_Ref) - is - begin - case For_Language is - when No_Language_Index => - null; - - when First_Language_Indexes => - In_Project.First_Language_Processing (For_Language) := - Language_Processing; - - when others => - declare - Supp : Supp_Language_Data; - Supp_Index : Supp_Language_Index := - In_Project.Supp_Language_Processing; - - begin - while Supp_Index /= No_Supp_Language_Index loop - Supp := In_Tree.Supp_Languages.Table (Supp_Index); - - if Supp.Index = For_Language then - In_Tree.Supp_Languages.Table - (Supp_Index).Data := Language_Processing; - return; - end if; - - Supp_Index := Supp.Next; - end loop; - - Supp := (Index => For_Language, Data => Language_Processing, - Next => In_Project.Supp_Language_Processing); - Supp_Language_Table.Increment_Last - (In_Tree.Supp_Languages); - Supp_Index := Supp_Language_Table.Last - (In_Tree.Supp_Languages); - In_Tree.Supp_Languages.Table (Supp_Index) := Supp; - In_Project.Supp_Language_Processing := Supp_Index; - end; - end case; - end Set; - - procedure Set - (Suffix : Name_Id; - For_Language : Language_Index; - In_Project : in out Project_Data; - In_Tree : Project_Tree_Ref) - is - begin - case For_Language is - when No_Language_Index => - null; - - when First_Language_Indexes => - In_Project.Naming.Impl_Suffixes (For_Language) := Suffix; - - when others => - declare - Supp : Supp_Suffix; - Supp_Index : Supp_Language_Index := - In_Project.Naming.Supp_Suffixes; - - begin - while Supp_Index /= No_Supp_Language_Index loop - Supp := In_Tree.Supp_Suffixes.Table - (Supp_Index); - - if Supp.Index = For_Language then - In_Tree.Supp_Suffixes.Table - (Supp_Index).Suffix := Suffix; - return; - end if; - - Supp_Index := Supp.Next; - end loop; - - Supp := (Index => For_Language, Suffix => Suffix, - Next => In_Project.Naming.Supp_Suffixes); - Supp_Suffix_Table.Increment_Last - (In_Tree.Supp_Suffixes); - Supp_Index := Supp_Suffix_Table.Last - (In_Tree.Supp_Suffixes); - In_Tree.Supp_Suffixes.Table (Supp_Index) := Supp; - In_Project.Naming.Supp_Suffixes := Supp_Index; - end; - end case; - end Set; - - ----------- - -- Slash -- - ----------- - - function Slash return Name_Id is - begin - return Slash_Id; - end Slash; - - -------------------------- - -- Standard_Naming_Data -- - -------------------------- - - function Standard_Naming_Data - (Tree : Project_Tree_Ref := No_Project_Tree) return Naming_Data - is - begin - if Tree = No_Project_Tree then - Prj.Initialize (Tree => No_Project_Tree); - return Std_Naming_Data; - - else - return Tree.Private_Part.Default_Naming; - end if; - end Standard_Naming_Data; - - --------------- - -- Suffix_Of -- - --------------- - - function Suffix_Of - (Language : Language_Index; - In_Project : Project_Data; - In_Tree : Project_Tree_Ref) return Name_Id - is - begin - case Language is - when No_Language_Index => - return No_Name; - - when First_Language_Indexes => - return In_Project.Naming.Impl_Suffixes (Language); - - when others => - declare - Supp : Supp_Suffix; - Supp_Index : Supp_Language_Index := - In_Project.Naming.Supp_Suffixes; - - begin - while Supp_Index /= No_Supp_Language_Index loop - Supp := In_Tree.Supp_Suffixes.Table (Supp_Index); - - if Supp.Index = Language then - return Supp.Suffix; - end if; - - Supp_Index := Supp.Next; - end loop; - - return No_Name; - end; - end case; - end Suffix_Of; - - ----------- - -- Value -- - ----------- - - function Value (Image : String) return Casing_Type is - begin - for Casing in The_Casing_Images'Range loop - if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then - return Casing; - end if; - end loop; - - raise Constraint_Error; - end Value; - -begin - -- Make sure that the standard project file extension is compatible - -- with canonical case file naming. - - Canonical_Case_File_Name (Project_File_Extension); -end Prj; |