X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fprj.adb;h=0bae53c23fc297e5b3caf01483ac0e7a472c6f68;hb=afb3d3c49fad6249e0b85722105326e9031d9475;hp=c59b2fdf5022f8ea57298ebb2b69fea3c296fefc;hpb=7ee888bd92955707f1cf733c6a1549c87eefd30c;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index c59b2fdf502..0bae53c23fc 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2009, 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- -- @@ -23,18 +23,19 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Characters.Handling; use Ada.Characters.Handling; - with Debug; -with Output; use Output; with Osint; use Osint; +with Output; use Output; with Prj.Attr; -with Prj.Env; with Prj.Err; use Prj.Err; with Snames; use Snames; -with Table; with Uintp; use Uintp; +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Unchecked_Deallocation; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; + with System.Case_Util; use System.Case_Util; with System.HTable; @@ -46,51 +47,25 @@ package body Prj is Initial_Buffer_Size : constant := 100; -- Initial size for extensible buffer used in Add_To_Buffer - Current_Mode : Mode := Ada_Only; + The_Empty_String : Name_Id := No_Name; - Configuration_Mode : Boolean := False; + subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case; - The_Empty_String : Name_Id; + type Cst_String_Access is access constant String; - 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 + All_Lower_Case_Image : aliased constant String := "lowercase"; + All_Upper_Case_Image : aliased constant String := "UPPERCASE"; + Mixed_Case_Image : aliased constant String := "MixedCase"; - 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); + The_Casing_Images : constant array (Known_Casing) of Cst_String_Access := + (All_Lower_Case => All_Lower_Case_Image'Access, + All_Upper_Case => All_Upper_Case_Image'Access, + Mixed_Case => Mixed_Case_Image'Access); 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, @@ -98,7 +73,6 @@ package body Prj is 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, @@ -111,58 +85,49 @@ package body Prj is Lib_Auto_Init => False, Libgnarl_Needed => Unknown, Symbol_Data => No_Symbols, - Ada_Sources_Present => True, - Other_Sources_Present => True, - Ada_Sources => Nil_String, - 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, + Source_Dir_Ranks => No_Number_List, 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, + Languages => No_Language_Index, Decl => No_Declarations, - Imported_Projects => Empty_Project_List, - All_Imported_Projects => Empty_Project_List, + Imported_Projects => null, + Include_Path_File => No_Path, + All_Imported_Projects => null, 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, - Linker_Name => No_File, - Linker_Path => No_Path, - Minimum_Linker_Options => No_Name_List, Config_Checked => False, - Checked => False, - Seen => False, Need_To_Build_Lib => False, + Has_Multi_Unit_Sources => 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. + procedure Free (Project : in out Project_Id); + -- Free memory allocated for Project + + procedure Free_List (Languages : in out Language_Ptr); + procedure Free_List (Source : in out Source_Id); + procedure Free_List (Languages : in out Language_List); + -- Free memory allocated for the list of languages or sources + + procedure Free_Units (Table : in out Units_Htable.Instance); + -- Free memory allocated for unit information in the project + + procedure Language_Changed (Iter : in out Source_Iterator); + procedure Project_Changed (Iter : in out Source_Iterator); + -- Called when a new project or language was selected for this iterator + + function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean; + -- Return True if there is at least one ALI file in the directory Dir ------------------- -- Add_To_Buffer -- @@ -197,159 +162,77 @@ package body Prj is 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; + --------------------------- + -- Delete_Temporary_File -- + --------------------------- - 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 + procedure Delete_Temporary_File + (Tree : Project_Tree_Ref; + Path : Path_Name_Type) is - Element_Id : Array_Element_Id; - Element : Array_Element; - Suffix : File_Name_Type := No_File; - Lang : Language_Index; + Dont_Care : Boolean; + pragma Warnings (Off, Dont_Care); 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); + if not Debug.Debug_Flag_N then + if Current_Verbosity = High then + Write_Line ("Removing temp file: " & Get_Name_String (Path)); end if; - Element_Id := Element.Next; - end loop; + Delete_File (Get_Name_String (Path), Dont_Care); - 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; + for Index in + 1 .. Temp_Files_Table.Last (Tree.Private_Part.Temp_Files) + loop + if Tree.Private_Part.Temp_Files.Table (Index) = Path then + Tree.Private_Part.Temp_Files.Table (Index) := No_Path; end if; - - Lang := In_Tree.Languages_Data.Table (Lang).Next; end loop; end if; + end Delete_Temporary_File; - return Suffix; - end Body_Suffix_Id_Of; + --------------------------- + -- Delete_All_Temp_Files -- + --------------------------- - -------------------- - -- Body_Suffix_Of -- - -------------------- + procedure Delete_All_Temp_Files (Tree : Project_Tree_Ref) is + Dont_Care : Boolean; + pragma Warnings (Off, Dont_Care); - 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; + Path : Path_Name_Type; 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 not Debug.Debug_Flag_N then + for Index in + 1 .. Temp_Files_Table.Last (Tree.Private_Part.Temp_Files) + loop + Path := Tree.Private_Part.Temp_Files.Table (Index); + + if Path /= No_Path then + if Current_Verbosity = High then + Write_Line ("Removing temp file: " + & Get_Name_String (Path)); + end if; - 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; + Delete_File (Get_Name_String (Path), Dont_Care); end if; - - Lang := In_Tree.Languages_Data.Table (Lang).Next; end loop; - if Suffix /= No_File then - return Get_Name_String (Suffix); - end if; + Temp_Files_Table.Free (Tree.Private_Part.Temp_Files); + Temp_Files_Table.Init (Tree.Private_Part.Temp_Files); 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 -- - ----------------------------- + -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or + -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to + -- the empty string. On VMS, this has the effect of deassigning + -- the logical names. - 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 -- - --------------------------- + if Tree.Private_Part.Current_Source_Path_File /= No_Path then + Setenv (Project_Include_Path_File, ""); + end if; - 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; + if Tree.Private_Part.Current_Object_Path_File /= No_Path then + Setenv (Project_Objects_Path_File, ""); end if; end Delete_All_Temp_Files; @@ -380,19 +263,6 @@ package body Prj is 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 -- ---------------- @@ -406,15 +276,10 @@ package body Prj is -- Empty_Project -- ------------------- - function Empty_Project (Tree : Project_Tree_Ref) return Project_Data is - Value : Project_Data; - + function Empty_Project return Project_Data is begin Prj.Initialize (Tree => No_Project_Tree); - Value := Project_Empty; - Value.Naming := Tree.Private_Part.Default_Naming; - - return Value; + return Project_Empty; end Empty_Project; ------------------ @@ -433,7 +298,8 @@ package body Prj is procedure Expect (The_Token : Token_Type; Token_Image : String) is begin if Token /= The_Token then - Error_Msg (Token_Image & " expected", Token_Ptr); + -- ??? Should pass user flags here instead + Error_Msg (Gnatmake_Flags, Token_Image & " expected", Token_Ptr); end if; end Expect; @@ -469,15 +335,121 @@ package body Prj is end Extend_Name; + --------------------- + -- Project_Changed -- + --------------------- + + procedure Project_Changed (Iter : in out Source_Iterator) is + begin + Iter.Language := Iter.Project.Project.Languages; + Language_Changed (Iter); + end Project_Changed; + + ---------------------- + -- Language_Changed -- + ---------------------- + + procedure Language_Changed (Iter : in out Source_Iterator) is + begin + Iter.Current := No_Source; + + if Iter.Language_Name /= No_Name then + while Iter.Language /= null + and then Iter.Language.Name /= Iter.Language_Name + loop + Iter.Language := Iter.Language.Next; + end loop; + end if; + + -- If there is no matching language in this project, move to next + + if Iter.Language = No_Language_Index then + if Iter.All_Projects then + Iter.Project := Iter.Project.Next; + + if Iter.Project /= null then + Project_Changed (Iter); + end if; + + else + Iter.Project := null; + end if; + + else + Iter.Current := Iter.Language.First_Source; + + if Iter.Current = No_Source then + Iter.Language := Iter.Language.Next; + Language_Changed (Iter); + end if; + end if; + end Language_Changed; + + --------------------- + -- For_Each_Source -- + --------------------- + + function For_Each_Source + (In_Tree : Project_Tree_Ref; + Project : Project_Id := No_Project; + Language : Name_Id := No_Name) return Source_Iterator + is + Iter : Source_Iterator; + begin + Iter := Source_Iterator' + (In_Tree => In_Tree, + Project => In_Tree.Projects, + All_Projects => Project = No_Project, + Language_Name => Language, + Language => No_Language_Index, + Current => No_Source); + + if Project /= null then + while Iter.Project /= null + and then Iter.Project.Project /= Project + loop + Iter.Project := Iter.Project.Next; + end loop; + end if; + + Project_Changed (Iter); + + return Iter; + end For_Each_Source; + + ------------- + -- Element -- + ------------- + + function Element (Iter : Source_Iterator) return Source_Id is + begin + return Iter.Current; + end Element; + + ---------- + -- Next -- + ---------- + + procedure Next (Iter : in out Source_Iterator) is + begin + Iter.Current := Iter.Current.Next_In_Lang; + if Iter.Current = No_Source then + Iter.Language := Iter.Language.Next; + Language_Changed (Iter); + end if; + end Next; + -------------------------------- -- For_Every_Project_Imported -- -------------------------------- procedure For_Every_Project_Imported - (By : Project_Id; - In_Tree : Project_Tree_Ref; - With_State : in out State) + (By : Project_Id; + With_State : in out State; + Imported_First : Boolean := False) is + use Project_Boolean_Htable; + Seen : Project_Boolean_Htable.Instance := Project_Boolean_Htable.Nil; procedure Recursive_Check (Project : Project_Id); -- Check if a project has already been seen. If not seen, mark it as @@ -489,39 +461,108 @@ package body Prj is 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; + if not Get (Seen, Project) then + Set (Seen, Project, True); + + if not Imported_First then + Action (Project, With_State); + end if; + + -- Visited all extended projects + + if Project.Extends /= No_Project then + Recursive_Check (Project.Extends); + end if; + + -- Visited all imported projects + + List := Project.Imported_Projects; + while List /= null loop + Recursive_Check (List.Project); + List := List.Next; end loop; + + if Imported_First then + Action (Project, With_State); + end if; 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); + Reset (Seen); end For_Every_Project_Imported; - -------------- - -- Get_Mode -- - -------------- + ----------------- + -- Find_Source -- + ----------------- + + function Find_Source + (In_Tree : Project_Tree_Ref; + Project : Project_Id; + In_Imported_Only : Boolean := False; + In_Extended_Only : Boolean := False; + Base_Name : File_Name_Type) return Source_Id + is + Result : Source_Id := No_Source; + + procedure Look_For_Sources (Proj : Project_Id; Src : in out Source_Id); + -- Look for Base_Name in the sources of Proj + + ---------------------- + -- Look_For_Sources -- + ---------------------- + + procedure Look_For_Sources (Proj : Project_Id; Src : in out Source_Id) is + Iterator : Source_Iterator; + + begin + Iterator := For_Each_Source (In_Tree => In_Tree, Project => Proj); + while Element (Iterator) /= No_Source loop + if Element (Iterator).File = Base_Name then + Src := Element (Iterator); + return; + end if; + + Next (Iterator); + end loop; + end Look_For_Sources; + + procedure For_Imported_Projects is new For_Every_Project_Imported + (State => Source_Id, Action => Look_For_Sources); + + Proj : Project_Id; + + -- Start of processing for Find_Source - function Get_Mode return Mode is begin - return Current_Mode; - end Get_Mode; + if In_Extended_Only then + Proj := Project; + while Proj /= No_Project loop + Look_For_Sources (Proj, Result); + exit when Result /= No_Source; + + Proj := Proj.Extends; + end loop; + + elsif In_Imported_Only then + Look_For_Sources (Project, Result); + + if Result = No_Source then + For_Imported_Projects + (By => Project, + With_State => Result); + end if; + else + Look_For_Sources (No_Project, Result); + end if; + + return Result; + end Find_Source; ---------- -- Hash -- @@ -547,26 +588,34 @@ package body Prj is function Hash (Project : Project_Id) return Header_Num is begin - return Header_Num (Project mod Max_Header_Num); + if Project = No_Project then + return Header_Num'First; + else + return Hash (Get_Name_String (Project.Name)); + end if; end Hash; ----------- -- Image -- ----------- - function Image (Casing : Casing_Type) return String is + function Image (The_Casing : Casing_Type) return String is begin - return The_Casing_Images (Casing).all; + return The_Casing_Images (The_Casing).all; end Image; - ---------------------- - -- In_Configuration -- - ---------------------- + ----------------------------- + -- Is_Standard_GNAT_Naming -- + ----------------------------- - function In_Configuration return Boolean is + function Is_Standard_GNAT_Naming + (Naming : Lang_Naming_Data) return Boolean + is begin - return Configuration_Mode; - end In_Configuration; + return Get_Name_String (Naming.Spec_Suffix) = ".ads" + and then Get_Name_String (Naming.Body_Suffix) = ".adb" + and then Get_Name_String (Naming.Dot_Replacement) = "-"; + end Is_Standard_GNAT_Naming; ---------------- -- Initialize -- @@ -574,24 +623,11 @@ package body Prj is procedure Initialize (Tree : Project_Tree_Ref) is begin - if not Initialized then - Initialized := True; + if The_Empty_String = No_Name then 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)); @@ -603,58 +639,13 @@ package body Prj is 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 + Extended : Project_Id) return Boolean is Proj : Project_Id; @@ -665,534 +656,614 @@ package body Prj is return True; end if; - Proj := In_Tree.Projects.Table (Proj).Extends; + Proj := Proj.Extends; end loop; return False; end Is_Extending; - ----------------------- - -- Objects_Exist_For -- - ----------------------- + ----------------- + -- Object_Name -- + ----------------- - function Objects_Exist_For - (Language : String; - In_Tree : Project_Tree_Ref) return Boolean + function Object_Name + (Source_File_Name : File_Name_Type; + Object_File_Suffix : Name_Id := No_Name) return File_Name_Type is - Language_Id : Name_Id; - Lang : Language_Index; + begin + if Object_File_Suffix = No_Name then + return Extend_Name + (Source_File_Name, Object_Suffix); + else + return Extend_Name + (Source_File_Name, Get_Name_String (Object_File_Suffix)); + end if; + end Object_Name; + + function Object_Name + (Source_File_Name : File_Name_Type; + Source_Index : Int; + Index_Separator : Character; + Object_File_Suffix : Name_Id := No_Name) return File_Name_Type + is + Index_Img : constant String := Source_Index'Img; + Last : Natural; 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.Objects_Generated; - end if; + Get_Name_String (Source_File_Name); - Lang := In_Tree.Languages_Data.Table (Lang).Next; - end loop; + Last := Name_Len; + while Last > 1 and then Name_Buffer (Last) /= '.' loop + Last := Last - 1; + end loop; + + if Last > 1 then + Name_Len := Last - 1; end if; - return True; - end Objects_Exist_For; + Add_Char_To_Name_Buffer (Index_Separator); + Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last)); - ----------------- - -- Object_Name -- - ----------------- + if Object_File_Suffix = No_Name then + Add_Str_To_Name_Buffer (Object_Suffix); + else + Add_Str_To_Name_Buffer (Get_Name_String (Object_File_Suffix)); + end if; - function Object_Name - (Source_File_Name : File_Name_Type) - return File_Name_Type - is - begin - return Extend_Name (Source_File_Name, Object_Suffix); + return Name_Find; end Object_Name; ---------------------- -- Record_Temp_File -- ---------------------- - procedure Record_Temp_File (Path : Path_Name_Type) is + procedure Record_Temp_File + (Tree : Project_Tree_Ref; + Path : Path_Name_Type) + is begin - Temp_Files.Increment_Last; - Temp_Files.Table (Temp_Files.Last) := Path; + Temp_Files_Table.Append (Tree.Private_Part.Temp_Files, Path); end Record_Temp_File; - ------------------------------------ - -- Register_Default_Naming_Scheme -- - ------------------------------------ + ---------- + -- Free -- + ---------- - 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; + procedure Free (Project : in out Project_Id) is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Project_Data, Project_Id); begin - -- Get the language name in small letters + if Project /= null then + Free (Project.Ada_Include_Path); + Free (Project.Objects_Path); + Free (Project.Ada_Objects_Path); + Free_List (Project.Imported_Projects, Free_Project => False); + Free_List (Project.All_Imported_Projects, Free_Project => False); + Free_List (Project.Languages); + + Unchecked_Free (Project); + end if; + end Free; + + --------------- + -- Free_List -- + --------------- - Get_Name_String (Language); - Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len)); - Lang := Name_Find; + procedure Free_List (Languages : in out Language_List) is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Language_List_Element, Language_List); + Tmp : Language_List; + begin + while Languages /= null loop + Tmp := Languages.Next; + Unchecked_Free (Languages); + Languages := Tmp; + end loop; + end Free_List; - -- Look for an element of the spec suffix array indexed by the language - -- name. If one is found, put the default value. + --------------- + -- Free_List -- + --------------- - 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); + procedure Free_List (Source : in out Source_Id) is + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Source_Data, Source_Id); - if Element.Index = Lang then - Found := True; - Element.Value.Value := Name_Id (Default_Spec_Suffix); - In_Tree.Array_Elements.Table (Suffix) := Element; + Tmp : Source_Id; - else - Suffix := Element.Next; + begin + while Source /= No_Source loop + Tmp := Source.Next_In_Lang; + Free_List (Source.Alternate_Languages); + + if Source.Unit /= null + and then Source.Kind in Spec_Or_Body + then + Source.Unit.File_Names (Source.Kind) := null; end if; + + Unchecked_Free (Source); + Source := Tmp; end loop; + end Free_List; - -- 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; + --------------- + -- Free_List -- + --------------- - -- Look for an element of the body suffix array indexed by the language - -- name. If one is found, put the default value. + procedure Free_List + (List : in out Project_List; + Free_Project : Boolean) + is + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Project_List_Element, Project_List); - 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); + Tmp : Project_List; - if Element.Index = Lang then - Found := True; - Element.Value.Value := Name_Id (Default_Body_Suffix); - In_Tree.Array_Elements.Table (Suffix) := Element; + begin + while List /= null loop + Tmp := List.Next; - else - Suffix := Element.Next; + if Free_Project then + Free (List.Project); end if; + + Unchecked_Free (List); + List := Tmp; + end loop; + end Free_List; + + --------------- + -- Free_List -- + --------------- + + procedure Free_List (Languages : in out Language_Ptr) is + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Language_Data, Language_Ptr); + + Tmp : Language_Ptr; + + begin + while Languages /= null loop + Tmp := Languages.Next; + Free_List (Languages.First_Source); + Unchecked_Free (Languages); + Languages := Tmp; end loop; + end Free_List; + + ---------------- + -- Free_Units -- + ---------------- + + procedure Free_Units (Table : in out Units_Htable.Instance) is + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Unit_Data, Unit_Index); + + Unit : Unit_Index; - -- 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); + begin + Unit := Units_Htable.Get_First (Table); + while Unit /= No_Unit_Index loop + if Unit.File_Names (Spec) /= null then + Unit.File_Names (Spec).Unit := No_Unit_Index; + end if; + + if Unit.File_Names (Impl) /= null then + Unit.File_Names (Impl).Unit := No_Unit_Index; + end if; + + Unchecked_Free (Unit); + Unit := Units_Htable.Get_Next (Table); + end loop; + + Units_Htable.Reset (Table); + end Free_Units; + + ---------- + -- Free -- + ---------- + + procedure Free (Tree : in out Project_Tree_Ref) is + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Project_Tree_Data, Project_Tree_Ref); + + begin + if Tree /= null then + Name_List_Table.Free (Tree.Name_Lists); + Number_List_Table.Free (Tree.Number_Lists); + String_Element_Table.Free (Tree.String_Elements); + Variable_Element_Table.Free (Tree.Variable_Elements); + Array_Element_Table.Free (Tree.Array_Elements); + Array_Table.Free (Tree.Arrays); + Package_Table.Free (Tree.Packages); + Source_Paths_Htable.Reset (Tree.Source_Paths_HT); + + Free_List (Tree.Projects, Free_Project => True); + Free_Units (Tree.Units_HT); + + -- Private part + + Temp_Files_Table.Free (Tree.Private_Part.Temp_Files); + + Unchecked_Free (Tree); end if; - end Register_Default_Naming_Scheme; + end Free; ----------- -- 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); + Number_List_Table.Init (Tree.Number_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); + Free_List (Tree.Projects, Free_Project => True); + Free_Units (Tree.Units_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; + Temp_Files_Table.Init (Tree.Private_Part.Temp_Files); + + Tree.Private_Part.Current_Source_Path_File := No_Path; + Tree.Private_Part.Current_Object_Path_File := No_Path; end Reset; - ------------------------ - -- Same_Naming_Scheme -- - ------------------------ + ------------------- + -- Switches_Name -- + ------------------- - function Same_Naming_Scheme - (Left, Right : Naming_Data) return Boolean + function Switches_Name + (Source_File_Name : File_Name_Type) return File_Name_Type 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; + 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; --------------------- - -- Set_Body_Suffix -- + -- Has_Ada_Sources -- --------------------- - 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; + function Has_Ada_Sources (Data : Project_Id) return Boolean is + Lang : Language_Ptr; 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; + Lang := Data.Languages; + while Lang /= No_Language_Index loop + if Lang.Name = Name_Ada then + return Lang.First_Source /= No_Source; + end if; + Lang := Lang.Next; + end loop; - -------------------------- - -- Set_In_Configuration -- - -------------------------- + return False; + end Has_Ada_Sources; - procedure Set_In_Configuration (Value : Boolean) is - begin - Configuration_Mode := Value; - end Set_In_Configuration; + ------------------------ + -- Contains_ALI_Files -- + ------------------------ - -------------- - -- Set_Mode -- - -------------- + function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is + Dir_Name : constant String := Get_Name_String (Dir); + Direct : Dir_Type; + Name : String (1 .. 1_000); + Last : Natural; + Result : Boolean := False; - 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; + Open (Direct, Dir_Name); - --------------------- - -- Set_Spec_Suffix -- - --------------------- + -- For each file in the directory, check if it is an ALI file - 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; + loop + Read (Direct, Name, Last); + exit when Last = 0; + Canonical_Case_File_Name (Name (1 .. Last)); + Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali"; + exit when Result; + end loop; - 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; + Close (Direct); + return Result; - ----------- - -- Slash -- - ----------- + exception + -- If there is any problem, close the directory if open and return True. + -- The library directory will be added to the path. - function Slash return Path_Name_Type is - begin - return Slash_Id; - end Slash; + when others => + if Is_Open (Direct) then + Close (Direct); + end if; - ----------------------- - -- Spec_Suffix_Id_Of -- - ----------------------- + return True; + end Contains_ALI_Files; - function Spec_Suffix_Id_Of - (In_Tree : Project_Tree_Ref; - Language : String; - Naming : Naming_Data) return File_Name_Type - is - Language_Id : Name_Id; + -------------------------- + -- Get_Object_Directory -- + -------------------------- - 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 + function Get_Object_Directory + (Project : Project_Id; + Including_Libraries : Boolean; + Only_If_Ada : Boolean := False) return Path_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 (Project.Library and then Including_Libraries) + or else + (Project.Object_Directory /= No_Path_Information + and then (not Including_Libraries or else not Project.Library)) + then + -- For a library project, add the library ALI directory if there is + -- no object directory or if the library ALI directory contains ALI + -- files; otherwise add the object directory. + + if Project.Library then + if Project.Object_Directory = No_Path_Information + or else Contains_ALI_Files (Project.Library_ALI_Dir.Name) + then + return Project.Library_ALI_Dir.Name; + else + return Project.Object_Directory.Name; + end if; - if Element.Index = Language_Id then - return File_Name_Type (Element.Value.Value); + -- For a non-library project, add object directory if it is not a + -- virtual project, and if there are Ada sources in the project or + -- one of the projects it extends. If there are no Ada sources, + -- adding the object directory could disrupt the order of the + -- object dirs in the path. + + elsif not Project.Virtual then + declare + Add_Object_Dir : Boolean; + Prj : Project_Id; + + begin + Add_Object_Dir := not Only_If_Ada; + Prj := Project; + while not Add_Object_Dir and then Prj /= No_Project loop + if Has_Ada_Sources (Prj) then + Add_Object_Dir := True; + else + Prj := Prj.Extends; + end if; + end loop; + + if Add_Object_Dir then + return Project.Object_Directory.Name; + end if; + end; end if; + end if; + + return No_Path; + end Get_Object_Directory; + + ----------------------------------- + -- Ultimate_Extending_Project_Of -- + ----------------------------------- + + function Ultimate_Extending_Project_Of + (Proj : Project_Id) return Project_Id + is + Prj : Project_Id; - Element_Id := Element.Next; + begin + Prj := Proj; + while Prj /= null and then Prj.Extended_By /= No_Project loop + Prj := Prj.Extended_By; 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; + return Prj; + end Ultimate_Extending_Project_Of; - Lang := In_Tree.Languages_Data.Table (Lang).Next; - end loop; - end if; + ----------------------------------- + -- Compute_All_Imported_Projects -- + ----------------------------------- - return Suffix; - end Spec_Suffix_Id_Of; + procedure Compute_All_Imported_Projects (Tree : Project_Tree_Ref) is + Project : Project_Id; - -------------------- - -- Spec_Suffix_Of -- - -------------------- + procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean); + -- Recursively add the projects imported by project Project, but not + -- those that are extended. - 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; + ------------------- + -- Recursive_Add -- + ------------------- - begin - Name_Len := 0; - Add_Str_To_Name_Buffer (Language); - To_Lower (Name_Buffer (1 .. Name_Len)); - Language_Id := Name_Find; + procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean) is + pragma Unreferenced (Dummy); + List : Project_List; + Prj2 : Project_Id; - Element_Id := Naming.Spec_Suffix; - while Element_Id /= No_Array_Element loop - Element := In_Tree.Array_Elements.Table (Element_Id); + begin + -- A project is not importing itself - if Element.Index = Language_Id then - return Get_Name_String (Element.Value.Value); - end if; + Prj2 := Ultimate_Extending_Project_Of (Prj); - Element_Id := Element.Next; - end loop; + if Project /= Prj2 then - 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; + -- Check that the project is not already in the list. We know the + -- one passed to Recursive_Add have never been visited before, but + -- the one passed it are the extended projects. - Lang := In_Tree.Languages_Data.Table (Lang).Next; - end loop; + List := Project.All_Imported_Projects; + while List /= null loop + if List.Project = Prj2 then + return; + end if; + + List := List.Next; + end loop; + + -- Add it to the list - if Suffix /= No_File then - return Get_Name_String (Suffix); + Project.All_Imported_Projects := + new Project_List_Element' + (Project => Prj2, + Next => Project.All_Imported_Projects); end if; - end if; + end Recursive_Add; - return ""; - end Spec_Suffix_Of; + procedure For_All_Projects is + new For_Every_Project_Imported (Boolean, Recursive_Add); - -------------------------- - -- Standard_Naming_Data -- - -------------------------- + Dummy : Boolean := False; + List : Project_List; - 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; + List := Tree.Projects; + while List /= null loop + Project := List.Project; + Free_List (Project.All_Imported_Projects, Free_Project => False); + For_All_Projects (Project, Dummy); + List := List.Next; + end loop; + end Compute_All_Imported_Projects; ------------------- - -- Switches_Name -- + -- Is_Compilable -- ------------------- - function Switches_Name - (Source_File_Name : File_Name_Type) return File_Name_Type - is + function Is_Compilable (Source : Source_Id) return Boolean is begin - return Extend_Name (Source_File_Name, Switches_Dependency_Suffix); - end Switches_Name; + return Source.Language.Config.Compiler_Driver /= No_File + and then Length_Of_Name (Source.Language.Config.Compiler_Driver) /= 0 + and then not Source.Locally_Removed; + end Is_Compilable; - --------------------------- - -- There_Are_Ada_Sources -- - --------------------------- + ------------------------------ + -- Object_To_Global_Archive -- + ------------------------------ - function There_Are_Ada_Sources - (In_Tree : Project_Tree_Ref; - Project : Project_Id) return Boolean + function Object_To_Global_Archive (Source : Source_Id) return Boolean is + begin + return Source.Language.Config.Kind = File_Based + and then Source.Kind = Impl + and then Source.Language.Config.Objects_Linked + and then Is_Compilable (Source) + and then Source.Language.Config.Object_Generated; + end Object_To_Global_Archive; + + ---------------------------- + -- Get_Language_From_Name -- + ---------------------------- + + function Get_Language_From_Name + (Project : Project_Id; + Name : String) return Language_Ptr is - Prj : Project_Id; + N : Name_Id; + Result : Language_Ptr; begin - Prj := Project; - while Prj /= No_Project loop - if In_Tree.Projects.Table (Prj).Ada_Sources /= Nil_String then - return True; + Name_Len := Name'Length; + Name_Buffer (1 .. Name_Len) := Name; + To_Lower (Name_Buffer (1 .. Name_Len)); + N := Name_Find; + + Result := Project.Languages; + while Result /= No_Language_Index loop + if Result.Name = N then + return Result; end if; - Prj := In_Tree.Projects.Table (Prj).Extends; + Result := Result.Next; end loop; - return False; - end There_Are_Ada_Sources; + return No_Language_Index; + end Get_Language_From_Name; - ----------- - -- Value -- - ----------- + ---------------- + -- Other_Part -- + ---------------- - function Value (Image : String) return Casing_Type is + function Other_Part (Source : Source_Id) return Source_Id 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; + if Source.Unit /= No_Unit_Index then + case Source.Kind is + when Impl => + return Source.Unit.File_Names (Spec); + when Spec => + return Source.Unit.File_Names (Impl); + when Sep => + return No_Source; + end case; + else + return No_Source; + end if; + end Other_Part; + + ------------------ + -- Create_Flags -- + ------------------ + + function Create_Flags + (Report_Error : Error_Handler; + When_No_Sources : Error_Warning; + Require_Sources_Other_Lang : Boolean := True; + Allow_Duplicate_Basenames : Boolean := True; + Compiler_Driver_Mandatory : Boolean := False; + Error_On_Unknown_Language : Boolean := True; + Require_Obj_Dirs : Error_Warning := Error) + return Processing_Flags + is + begin + return Processing_Flags' + (Report_Error => Report_Error, + When_No_Sources => When_No_Sources, + Require_Sources_Other_Lang => Require_Sources_Other_Lang, + Allow_Duplicate_Basenames => Allow_Duplicate_Basenames, + Error_On_Unknown_Language => Error_On_Unknown_Language, + Compiler_Driver_Mandatory => Compiler_Driver_Mandatory, + Require_Obj_Dirs => Require_Obj_Dirs); + end Create_Flags; + + ------------ + -- Length -- + ------------ + + function Length + (Table : Name_List_Table.Instance; + List : Name_List_Index) return Natural + is + Count : Natural := 0; + Tmp : Name_List_Index; + + begin + Tmp := List; + while Tmp /= No_Name_List loop + Count := Count + 1; + Tmp := Table.Table (Tmp).Next; end loop; - raise Constraint_Error; - end Value; + return Count; + end Length; begin -- Make sure that the standard config and user project file extensions are