| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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; |
