------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P R J -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, 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 Ada.Characters.Handling; use Ada.Characters.Handling; with Debug; 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 Table; with Uintp; use Uintp; with System.Case_Util; use System.Case_Util; with System.HTable; package body Prj is Object_Suffix : constant String := Get_Target_Object_Suffix.all; -- File suffix for object files Initial_Buffer_Size : constant := 100; -- Initial size for extensible buffer used in Add_To_Buffer Current_Mode : Mode := Ada_Only; Configuration_Mode : Boolean := False; The_Empty_String : Name_Id; Default_Ada_Spec_Suffix_Id : File_Name_Type; Default_Ada_Body_Suffix_Id : File_Name_Type; Slash_Id : Path_Name_Type; -- Initialized in Prj.Initialize, 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 File_Name_Type := File_Name_Type (First_Name_Id + Character'Pos ('-')); Std_Naming_Data : constant Naming_Data := (Dot_Replacement => Standard_Dot_Replacement, Dot_Repl_Loc => No_Location, Casing => All_Lower_Case, Spec_Suffix => No_Array_Element, Ada_Spec_Suffix_Loc => No_Location, Body_Suffix => No_Array_Element, Ada_Body_Suffix_Loc => No_Location, Separate_Suffix => No_File, 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 := (Qualifier => Unspecified, Externally_Built => False, Config => Default_Project_Config, Languages => No_Name_List, First_Referred_By => No_Project, Name => No_Name, Display_Name => No_Name, Path => No_Path_Information, Virtual => False, Location => No_Location, Mains => Nil_String, Directory => No_Path_Information, Dir_Path => null, Library => False, Library_Dir => No_Path_Information, Library_Src_Dir => No_Path_Information, Library_ALI_Dir => No_Path_Information, Library_Name => No_Name, Library_Kind => Static, Lib_Internal_Name => No_Name, Standalone_Library => False, Lib_Interface_ALIs => Nil_String, Lib_Auto_Init => False, Libgnarl_Needed => Unknown, Symbol_Data => No_Symbols, Ada_Sources_Present => True, Other_Sources_Present => True, Ada_Sources => Nil_String, First_Source => No_Source, Last_Source => No_Source, Interfaces_Defined => False, Unit_Based_Language_Name => No_Name, Unit_Based_Language_Index => No_Language_Index, Imported_Directories_Switches => null, Include_Path => null, Include_Data_Set => False, Include_Language => No_Language_Index, Source_Dirs => Nil_String, Known_Order_Of_Source_Dirs => True, Object_Directory => No_Path_Information, Library_TS => Empty_Time_Stamp, Exec_Directory => No_Path_Information, Extends => No_Project, Extended_By => No_Project, Naming => Std_Naming_Data, First_Language_Processing => No_Language_Index, Decl => No_Declarations, Imported_Projects => Empty_Project_List, All_Imported_Projects => Empty_Project_List, Ada_Include_Path => null, Ada_Objects_Path => null, Objects_Path => null, Include_Path_File => No_Path, Objects_Path_File_With_Libs => No_Path, Objects_Path_File_Without_Libs => No_Path, Config_File_Name => No_Path, Config_File_Temp => False, Config_Checked => False, Checked => False, Seen => False, Need_To_Build_Lib => False, Depth => 0, Unkept_Comments => False); package Temp_Files is new Table.Table (Table_Component_Type => Path_Name_Type, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => 20, Table_Increment => 100, Table_Name => "Makegpr.Temp_Files"); -- Table to store the path name of all the created temporary files, so that -- they can be deleted at the end, or when the program is interrupted. ------------------- -- 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; ----------------------- -- Body_Suffix_Id_Of -- ----------------------- function Body_Suffix_Id_Of (In_Tree : Project_Tree_Ref; Language : String; Naming : Naming_Data) return File_Name_Type is Language_Id : Name_Id; begin Name_Len := 0; Add_Str_To_Name_Buffer (Language); To_Lower (Name_Buffer (1 .. Name_Len)); Language_Id := Name_Find; return Body_Suffix_Id_Of (In_Tree => In_Tree, Language_Id => Language_Id, Naming => Naming); end Body_Suffix_Id_Of; ----------------------- -- Body_Suffix_Id_Of -- ----------------------- function Body_Suffix_Id_Of (In_Tree : Project_Tree_Ref; Language_Id : Name_Id; Naming : Naming_Data) return File_Name_Type is Element_Id : Array_Element_Id; Element : Array_Element; Suffix : File_Name_Type := No_File; Lang : Language_Index; begin -- ??? This seems to be only for Ada_Only mode... Element_Id := Naming.Body_Suffix; while Element_Id /= No_Array_Element loop Element := In_Tree.Array_Elements.Table (Element_Id); if Element.Index = Language_Id then return File_Name_Type (Element.Value.Value); end if; Element_Id := Element.Next; end loop; if Current_Mode = Multi_Language then Lang := In_Tree.First_Language; while Lang /= No_Language_Index loop if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then Suffix := In_Tree.Languages_Data.Table (Lang).Config.Naming_Data.Body_Suffix; exit; end if; Lang := In_Tree.Languages_Data.Table (Lang).Next; end loop; end if; return Suffix; end Body_Suffix_Id_Of; -------------------- -- Body_Suffix_Of -- -------------------- function Body_Suffix_Of (In_Tree : Project_Tree_Ref; Language : String; Naming : Naming_Data) return String is Language_Id : Name_Id; Element_Id : Array_Element_Id; Element : Array_Element; Suffix : File_Name_Type := No_File; Lang : Language_Index; begin Name_Len := 0; Add_Str_To_Name_Buffer (Language); To_Lower (Name_Buffer (1 .. Name_Len)); Language_Id := Name_Find; Element_Id := Naming.Body_Suffix; while Element_Id /= No_Array_Element loop Element := In_Tree.Array_Elements.Table (Element_Id); if Element.Index = Language_Id then return Get_Name_String (Element.Value.Value); end if; Element_Id := Element.Next; end loop; if Current_Mode = Multi_Language then Lang := In_Tree.First_Language; while Lang /= No_Language_Index loop if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then Suffix := File_Name_Type (In_Tree.Languages_Data.Table (Lang).Config.Naming_Data.Body_Suffix); exit; end if; Lang := In_Tree.Languages_Data.Table (Lang).Next; end loop; if Suffix /= No_File then return Get_Name_String (Suffix); end if; end if; return ""; end Body_Suffix_Of; ----------------------------- -- Default_Ada_Body_Suffix -- ----------------------------- function Default_Ada_Body_Suffix return File_Name_Type is begin return Default_Ada_Body_Suffix_Id; end Default_Ada_Body_Suffix; ----------------------------- -- Default_Ada_Spec_Suffix -- ----------------------------- function Default_Ada_Spec_Suffix return File_Name_Type is begin return Default_Ada_Spec_Suffix_Id; end Default_Ada_Spec_Suffix; --------------------------- -- Delete_All_Temp_Files -- --------------------------- procedure Delete_All_Temp_Files is Dont_Care : Boolean; pragma Warnings (Off, Dont_Care); begin if not Debug.Debug_Flag_N then for Index in 1 .. Temp_Files.Last loop Delete_File (Get_Name_String (Temp_Files.Table (Index)), Dont_Care); end loop; end if; end Delete_All_Temp_Files; --------------------- -- Dependency_Name -- --------------------- function Dependency_Name (Source_File_Name : File_Name_Type; Dependency : Dependency_File_Kind) return File_Name_Type is begin case Dependency is when None => return No_File; when Makefile => return File_Name_Type (Extend_Name (Source_File_Name, Makefile_Dependency_Suffix)); when ALI_File => return File_Name_Type (Extend_Name (Source_File_Name, ALI_Dependency_Suffix)); end case; end Dependency_Name; --------------------------- -- Display_Language_Name -- --------------------------- procedure Display_Language_Name (In_Tree : Project_Tree_Ref; Language : Language_Index) is begin Get_Name_String (In_Tree.Languages_Data.Table (Language).Display_Name); Write_Str (Name_Buffer (1 .. Name_Len)); end Display_Language_Name; ---------------- -- Empty_File -- ---------------- function Empty_File return File_Name_Type is begin return File_Name_Type (The_Empty_String); end Empty_File; ------------------- -- 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; ----------------- -- Extend_Name -- ----------------- function Extend_Name (File : File_Name_Type; With_Suffix : String) return File_Name_Type is Last : Positive; begin Get_Name_String (File); Last := Name_Len + 1; while Name_Len /= 0 and then Name_Buffer (Name_Len) /= '.' loop Name_Len := Name_Len - 1; end loop; if Name_Len <= 1 then Name_Len := Last; end if; for J in With_Suffix'Range loop Name_Buffer (Name_Len) := With_Suffix (J); Name_Len := Name_Len + 1; end loop; Name_Len := Name_Len - 1; return Name_Find; end Extend_Name; -------------------------------- -- 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; -------------- -- Get_Mode -- -------------- function Get_Mode return Mode is begin return Current_Mode; end Get_Mode; ---------- -- Hash -- ---------- function Hash is new System.HTable.Hash (Header_Num => Header_Num); -- Used in implementation of other functions Hash below function Hash (Name : File_Name_Type) return Header_Num is begin return Hash (Get_Name_String (Name)); end Hash; function Hash (Name : Name_Id) return Header_Num is begin return Hash (Get_Name_String (Name)); end Hash; function Hash (Name : Path_Name_Type) return Header_Num is begin return Hash (Get_Name_String (Name)); end Hash; function Hash (Project : Project_Id) return Header_Num is begin return Header_Num (Project mod Max_Header_Num); end Hash; ----------- -- Image -- ----------- function Image (Casing : Casing_Type) return String is begin return The_Casing_Images (Casing).all; end Image; ---------------------- -- In_Configuration -- ---------------------- function In_Configuration return Boolean is begin return Configuration_Mode; end In_Configuration; ---------------- -- 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; Empty_File_Name := File_Name_Type (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; 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)); end if; if Tree /= No_Project_Tree then Reset (Tree); end if; end Initialize; ------------------- -- Is_A_Language -- ------------------- function Is_A_Language (Tree : Project_Tree_Ref; Data : Project_Data; Language_Name : Name_Id) return Boolean is begin if Get_Mode = Ada_Only then declare List : Name_List_Index := Data.Languages; begin while List /= No_Name_List loop if Tree.Name_Lists.Table (List).Name = Language_Name then return True; else List := Tree.Name_Lists.Table (List).Next; end if; end loop; end; else declare Lang_Ind : Language_Index := Data.First_Language_Processing; Lang_Data : Language_Data; begin while Lang_Ind /= No_Language_Index loop Lang_Data := Tree.Languages_Data.Table (Lang_Ind); if Lang_Data.Name = Language_Name then return True; end if; Lang_Ind := Lang_Data.Next; end loop; end; end if; return False; end Is_A_Language; ------------------ -- Is_Extending -- ------------------ function Is_Extending (Extending : Project_Id; Extended : Project_Id; In_Tree : Project_Tree_Ref) return Boolean is Proj : Project_Id; begin Proj := Extending; while Proj /= No_Project loop if Proj = Extended then return True; end if; Proj := In_Tree.Projects.Table (Proj).Extends; end loop; return False; end Is_Extending; ----------------------- -- Objects_Exist_For -- ----------------------- function Objects_Exist_For (Language : String; In_Tree : Project_Tree_Ref) return Boolean is Language_Id : Name_Id; Lang : Language_Index; begin if Current_Mode = Multi_Language then Name_Len := 0; Add_Str_To_Name_Buffer (Language); To_Lower (Name_Buffer (1 .. Name_Len)); Language_Id := Name_Find; Lang := In_Tree.First_Language; while Lang /= No_Language_Index loop if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then return In_Tree.Languages_Data.Table (Lang).Config.Object_Generated; end if; Lang := In_Tree.Languages_Data.Table (Lang).Next; end loop; end if; return True; end Objects_Exist_For; ----------------- -- Object_Name -- ----------------- function Object_Name (Source_File_Name : File_Name_Type) return File_Name_Type is begin return Extend_Name (Source_File_Name, Object_Suffix); end Object_Name; ---------------------- -- Record_Temp_File -- ---------------------- procedure Record_Temp_File (Path : Path_Name_Type) is begin Temp_Files.Increment_Last; Temp_Files.Table (Temp_Files.Last) := Path; end Record_Temp_File; ------------------------------------ -- Register_Default_Naming_Scheme -- ------------------------------------ procedure Register_Default_Naming_Scheme (Language : Name_Id; Default_Spec_Suffix : File_Name_Type; Default_Body_Suffix : File_Name_Type; 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; -- Look for an element of the spec suffix array indexed by the language -- name. If one is found, put the default value. Suffix := In_Tree.Private_Part.Default_Naming.Spec_Suffix; Found := False; 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 := Name_Id (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 => Name_Id (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; -- Look for an element of the body suffix array indexed by the language -- name. If one is found, put the default value. Suffix := In_Tree.Private_Part.Default_Naming.Body_Suffix; Found := False; 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 := Name_Id (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 => Name_Id (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 -- Def_Lang : constant Name_Node := -- (Name => Name_Ada, -- Next => No_Name_List); -- Why is the above commented out ??? begin Prj.Env.Initialize; -- Visible tables Language_Data_Table.Init (Tree.Languages_Data); Name_List_Table.Init (Tree.Name_Lists); 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); Source_Data_Table.Init (Tree.Sources); Alternate_Language_Table.Init (Tree.Alt_Langs); Unit_Table.Init (Tree.Units); Units_Htable.Reset (Tree.Units_HT); Files_Htable.Reset (Tree.Files_HT); Source_Paths_Htable.Reset (Tree.Source_Paths_HT); -- Private part table 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; if Current_Mode = Ada_Only then Register_Default_Naming_Scheme (Language => Name_Ada, Default_Spec_Suffix => Default_Ada_Spec_Suffix, Default_Body_Suffix => Default_Ada_Body_Suffix, In_Tree => Tree); Tree.Private_Part.Default_Naming.Separate_Suffix := Default_Ada_Body_Suffix; end if; 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.Separate_Suffix = Right.Separate_Suffix; end Same_Naming_Scheme; --------------------- -- Set_Body_Suffix -- --------------------- procedure Set_Body_Suffix (In_Tree : Project_Tree_Ref; Language : String; Naming : in out Naming_Data; Suffix : File_Name_Type) is Language_Id : Name_Id; Element : Array_Element; begin Name_Len := 0; Add_Str_To_Name_Buffer (Language); To_Lower (Name_Buffer (1 .. Name_Len)); Language_Id := Name_Find; Element := (Index => Language_Id, Src_Index => 0, Index_Case_Sensitive => False, Value => (Kind => Single, Project => No_Project, Location => No_Location, Default => False, Value => Name_Id (Suffix), Index => 0), Next => Naming.Body_Suffix); Array_Element_Table.Increment_Last (In_Tree.Array_Elements); Naming.Body_Suffix := Array_Element_Table.Last (In_Tree.Array_Elements); In_Tree.Array_Elements.Table (Naming.Body_Suffix) := Element; end Set_Body_Suffix; -------------------------- -- Set_In_Configuration -- -------------------------- procedure Set_In_Configuration (Value : Boolean) is begin Configuration_Mode := Value; end Set_In_Configuration; -------------- -- Set_Mode -- -------------- procedure Set_Mode (New_Mode : Mode) is begin Current_Mode := New_Mode; case New_Mode is when Ada_Only => Default_Language_Is_Ada := True; Must_Check_Configuration := False; when Multi_Language => Default_Language_Is_Ada := False; Must_Check_Configuration := True; end case; end Set_Mode; --------------------- -- Set_Spec_Suffix -- --------------------- procedure Set_Spec_Suffix (In_Tree : Project_Tree_Ref; Language : String; Naming : in out Naming_Data; Suffix : File_Name_Type) is Language_Id : Name_Id; Element : Array_Element; begin Name_Len := 0; Add_Str_To_Name_Buffer (Language); To_Lower (Name_Buffer (1 .. Name_Len)); Language_Id := Name_Find; Element := (Index => Language_Id, Src_Index => 0, Index_Case_Sensitive => False, Value => (Kind => Single, Project => No_Project, Location => No_Location, Default => False, Value => Name_Id (Suffix), Index => 0), Next => Naming.Spec_Suffix); Array_Element_Table.Increment_Last (In_Tree.Array_Elements); Naming.Spec_Suffix := Array_Element_Table.Last (In_Tree.Array_Elements); In_Tree.Array_Elements.Table (Naming.Spec_Suffix) := Element; end Set_Spec_Suffix; ----------- -- Slash -- ----------- function Slash return Path_Name_Type is begin return Slash_Id; end Slash; ----------------------- -- Spec_Suffix_Id_Of -- ----------------------- function Spec_Suffix_Id_Of (In_Tree : Project_Tree_Ref; Language : String; Naming : Naming_Data) return File_Name_Type is Language_Id : Name_Id; begin Name_Len := 0; Add_Str_To_Name_Buffer (Language); To_Lower (Name_Buffer (1 .. Name_Len)); Language_Id := Name_Find; return Spec_Suffix_Id_Of (In_Tree => In_Tree, Language_Id => Language_Id, Naming => Naming); end Spec_Suffix_Id_Of; ----------------------- -- Spec_Suffix_Id_Of -- ----------------------- function Spec_Suffix_Id_Of (In_Tree : Project_Tree_Ref; Language_Id : Name_Id; Naming : Naming_Data) return File_Name_Type is Element_Id : Array_Element_Id; Element : Array_Element; Suffix : File_Name_Type := No_File; Lang : Language_Index; begin Element_Id := Naming.Spec_Suffix; while Element_Id /= No_Array_Element loop Element := In_Tree.Array_Elements.Table (Element_Id); if Element.Index = Language_Id then return File_Name_Type (Element.Value.Value); end if; Element_Id := Element.Next; end loop; if Current_Mode = Multi_Language then Lang := In_Tree.First_Language; while Lang /= No_Language_Index loop if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then Suffix := In_Tree.Languages_Data.Table (Lang).Config.Naming_Data.Spec_Suffix; exit; end if; Lang := In_Tree.Languages_Data.Table (Lang).Next; end loop; end if; return Suffix; end Spec_Suffix_Id_Of; -------------------- -- Spec_Suffix_Of -- -------------------- function Spec_Suffix_Of (In_Tree : Project_Tree_Ref; Language : String; Naming : Naming_Data) return String is Language_Id : Name_Id; Element_Id : Array_Element_Id; Element : Array_Element; Suffix : File_Name_Type := No_File; Lang : Language_Index; begin Name_Len := 0; Add_Str_To_Name_Buffer (Language); To_Lower (Name_Buffer (1 .. Name_Len)); Language_Id := Name_Find; Element_Id := Naming.Spec_Suffix; while Element_Id /= No_Array_Element loop Element := In_Tree.Array_Elements.Table (Element_Id); if Element.Index = Language_Id then return Get_Name_String (Element.Value.Value); end if; Element_Id := Element.Next; end loop; if Current_Mode = Multi_Language then Lang := In_Tree.First_Language; while Lang /= No_Language_Index loop if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then Suffix := File_Name_Type (In_Tree.Languages_Data.Table (Lang).Config.Naming_Data.Spec_Suffix); exit; end if; Lang := In_Tree.Languages_Data.Table (Lang).Next; end loop; if Suffix /= No_File then return Get_Name_String (Suffix); end if; end if; return ""; end Spec_Suffix_Of; -------------------------- -- 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; ------------------- -- Switches_Name -- ------------------- function Switches_Name (Source_File_Name : File_Name_Type) return File_Name_Type is begin return Extend_Name (Source_File_Name, Switches_Dependency_Suffix); end Switches_Name; ----------- -- 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 config and user project file extensions are -- compatible with canonical case file naming. Canonical_Case_File_Name (Config_Project_File_Extension); Canonical_Case_File_Name (Project_File_Extension); end Prj;