------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P R J -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2004 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. -- -- 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.Com; with Prj.Env; with Prj.Err; use Prj.Err; with Scans; use Scans; with Snames; use Snames; with Uintp; use Uintp; with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.OS_Lib; use GNAT.OS_Lib; package body Prj is The_Empty_String : Name_Id; Name_C_Plus_Plus : Name_Id; 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 : constant Project_Data := (Externally_Built => False, Languages => No_Languages, Supp_Languages => No_Supp_Language_Index, First_Referred_By => No_Project, 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_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, 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, 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) is begin -- If Buffer is too small, double its size if Buffer_Last + S'Length > Buffer'Last then declare New_Buffer : constant String_Access := new String (1 .. 2 * Buffer'Last); begin New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last); Free (Buffer); Buffer := New_Buffer; end; end if; Buffer (Buffer_Last + 1 .. Buffer_Last + S'Length) := S; Buffer_Last := Buffer_Last + S'Length; end Add_To_Buffer; --------------------------- -- 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 return Project_Data is begin Prj.Initialize; return Project_Empty; 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; With_State : in out State) is procedure 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. ----------- -- Check -- ----------- procedure Check (Project : Project_Id) is List : Project_List; begin if not Projects.Table (Project).Seen then Projects.Table (Project).Seen := True; Action (Project, With_State); List := Projects.Table (Project).Imported_Projects; while List /= Empty_Project_List loop Check (Project_Lists.Table (List).Project); List := Project_Lists.Table (List).Next; end loop; end if; end Check; -- Start of procecessing for For_Every_Project_Imported begin for Project in Projects.First .. Projects.Last loop Projects.Table (Project).Seen := False; end loop; 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 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 := Name_Find; Name_Len := 4; Name_Buffer (1 .. 4) := ".adb"; Default_Ada_Body_Suffix := Name_Find; Name_Len := 1; Name_Buffer (1) := '/'; Slash := 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; Register_Default_Naming_Scheme (Language => Name_Ada, Default_Spec_Suffix => Default_Ada_Spec_Suffix, Default_Body_Suffix => Default_Ada_Body_Suffix); 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; end Initialize; ---------------- -- Is_Present -- ---------------- function Is_Present (Language : Language_Index; In_Project : Project_Data) 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 := 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) 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 := 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) 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 := Std_Naming_Data.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 := Array_Elements.Table (Suffix); if Element.Index = Lang then Found := True; Element.Value.Value := Default_Spec_Suffix; 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 => Std_Naming_Data.Spec_Suffix); Array_Elements.Increment_Last; Array_Elements.Table (Array_Elements.Last) := Element; Std_Naming_Data.Spec_Suffix := Array_Elements.Last; end if; Suffix := Std_Naming_Data.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 := Array_Elements.Table (Suffix); if Element.Index = Lang then Found := True; Element.Value.Value := Default_Body_Suffix; 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 => Std_Naming_Data.Body_Suffix); Array_Elements.Increment_Last; Array_Elements.Table (Array_Elements.Last) := Element; Std_Naming_Data.Body_Suffix := Array_Elements.Last; end if; end Register_Default_Naming_Scheme; ----------- -- Reset -- ----------- procedure Reset is begin Projects.Init; Project_Lists.Init; Packages.Init; Arrays.Init; Variable_Elements.Init; String_Elements.Init; Prj.Com.Units.Init; Prj.Com.Units_Htable.Reset; Prj.Com.Files_Htable.Reset; 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) 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 := Present_Languages.Table (Supp_Index); if Supp.Index = Language then 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_Languages.Increment_Last; Supp_Index := Present_Languages.Last; Present_Languages.Table (Supp_Index) := Supp; In_Project.Supp_Languages := Supp_Index; end; end case; end Set; procedure Set (Language_Processing : in Language_Processing_Data; For_Language : Language_Index; In_Project : in out Project_Data) 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 := Supp_Languages.Table (Supp_Index); if Supp.Index = For_Language then 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_Languages.Increment_Last; Supp_Index := Supp_Languages.Last; 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) 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 := Supp_Suffix_Table.Table (Supp_Index); if Supp.Index = For_Language then Supp_Suffix_Table.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; Supp_Index := Supp_Suffix_Table.Last; Supp_Suffix_Table.Table (Supp_Index) := Supp; In_Project.Naming.Supp_Suffixes := Supp_Index; end; end case; end Set; -------------------------- -- Standard_Naming_Data -- -------------------------- function Standard_Naming_Data return Naming_Data is begin Prj.Initialize; return Std_Naming_Data; end Standard_Naming_Data; --------------- -- Suffix_Of -- --------------- function Suffix_Of (Language : Language_Index; In_Project : Project_Data) 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 := Supp_Suffix_Table.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;