X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fprj.adb;h=0bae53c23fc297e5b3caf01483ac0e7a472c6f68;hb=afb3d3c49fad6249e0b85722105326e9031d9475;hp=7f85ed3041e12328f1c3091c02258d4b4afe9397;hpb=e7c3eff78c00b0b3ab6572de81bd104e871cc29c;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 7f85ed3041e..0bae53c23fc 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -6,162 +6,128 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2006, 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- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- +-- 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 COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- +-- 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 Namet; use Namet; -with Output; use Output; +with Debug; 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 Uintp; use Uintp; -with GNAT.Case_Util; use GNAT.Case_Util; +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; 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 - The_Empty_String : Name_Id; - - Name_C_Plus_Plus : Name_Id; - - Default_Ada_Spec_Suffix_Id : Name_Id; - Default_Ada_Body_Suffix_Id : Name_Id; - Slash_Id : Name_Id; - -- Initialized in Prj.Initialized, then never modified + The_Empty_String : Name_Id := No_Name; subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case; - The_Casing_Images : constant array (Known_Casing) of String_Access := - (All_Lower_Case => new String'("lowercase"), - All_Upper_Case => new String'("UPPERCASE"), - Mixed_Case => new String'("MixedCase")); - - Initialized : Boolean := False; - - Standard_Dot_Replacement : constant Name_Id := - First_Name_Id + Character'Pos ('-'); - - Std_Naming_Data : Naming_Data := - (Dot_Replacement => Standard_Dot_Replacement, - Dot_Repl_Loc => No_Location, - Casing => All_Lower_Case, - Spec_Suffix => No_Array_Element, - Ada_Spec_Suffix => No_Name, - Spec_Suffix_Loc => No_Location, - Impl_Suffixes => No_Impl_Suffixes, - Supp_Suffixes => No_Supp_Language_Index, - Body_Suffix => No_Array_Element, - Ada_Body_Suffix => No_Name, - Body_Suffix_Loc => No_Location, - Separate_Suffix => No_Name, - Sep_Suffix_Loc => No_Location, - Specs => No_Array_Element, - Bodies => No_Array_Element, - Specification_Exceptions => No_Array_Element, - Implementation_Exceptions => No_Array_Element); - - Project_Empty : Project_Data := - (Externally_Built => False, - Languages => No_Languages, - Supp_Languages => No_Supp_Language_Index, - First_Referred_By => No_Project, - Name => No_Name, - Display_Name => No_Name, - Path_Name => No_Name, - Display_Path_Name => No_Name, - Virtual => False, - Location => No_Location, - Mains => Nil_String, - Directory => No_Name, - Display_Directory => No_Name, - Dir_Path => null, - Library => False, - Library_Dir => No_Name, - Display_Library_Dir => No_Name, - Library_Src_Dir => No_Name, - Display_Library_Src_Dir => No_Name, - Library_ALI_Dir => No_Name, - Display_Library_ALI_Dir => No_Name, - Library_Name => No_Name, - Library_Kind => Static, - Lib_Internal_Name => No_Name, - Standalone_Library => False, - Lib_Interface_ALIs => Nil_String, - Lib_Auto_Init => False, - Symbol_Data => No_Symbols, - Ada_Sources_Present => True, - Other_Sources_Present => True, - Sources => Nil_String, - First_Other_Source => No_Other_Source, - Last_Other_Source => No_Other_Source, - Imported_Directories_Switches => null, - Include_Path => null, - Include_Data_Set => False, - Source_Dirs => Nil_String, - Known_Order_Of_Source_Dirs => True, - Object_Directory => No_Name, - Display_Object_Dir => No_Name, - Library_TS => Empty_Time_Stamp, - Exec_Directory => No_Name, - Display_Exec_Dir => No_Name, - Extends => No_Project, - Extended_By => No_Project, - Naming => Std_Naming_Data, - First_Language_Processing => Default_First_Language_Processing_Data, - Supp_Language_Processing => No_Supp_Language_Index, - Default_Linker => No_Name, - Default_Linker_Path => No_Name, - Decl => No_Declarations, - Imported_Projects => Empty_Project_List, - All_Imported_Projects => Empty_Project_List, - Ada_Include_Path => null, - Ada_Objects_Path => null, - Include_Path_File => No_Name, - Objects_Path_File_With_Libs => No_Name, - Objects_Path_File_Without_Libs => No_Name, - Config_File_Name => No_Name, - Config_File_Temp => False, - Config_Checked => False, - Language_Independent_Checked => False, - Checked => False, - Seen => False, - Need_To_Build_Lib => False, - Depth => 0, - Unkept_Comments => False); - - ----------------------- - -- Add_Language_Name -- - ----------------------- - - procedure Add_Language_Name (Name : Name_Id) is - begin - Last_Language_Index := Last_Language_Index + 1; - Language_Indexes.Set (Name, Last_Language_Index); - Language_Names.Increment_Last; - Language_Names.Table (Last_Language_Index) := Name; - end Add_Language_Name; + type Cst_String_Access is access constant String; + + All_Lower_Case_Image : aliased constant String := "lowercase"; + All_Upper_Case_Image : aliased constant String := "UPPERCASE"; + Mixed_Case_Image : aliased constant String := "MixedCase"; + + 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, + Name => No_Name, + Display_Name => No_Name, + Path => No_Path_Information, + Virtual => False, + Location => No_Location, + Mains => Nil_String, + Directory => No_Path_Information, + 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, + Interfaces_Defined => False, + Source_Dirs => Nil_String, + 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, + Languages => No_Language_Index, + Decl => No_Declarations, + Imported_Projects => null, + Include_Path_File => No_Path, + All_Imported_Projects => null, + Ada_Include_Path => null, + Ada_Objects_Path => null, + Objects_Path => null, + 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, + Need_To_Build_Lib => False, + Has_Multi_Unit_Sources => False, + Depth => 0, + Unkept_Comments => False); + + 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 -- @@ -196,46 +162,124 @@ package body Prj is Last := Last + S'Length; end Add_To_Buffer; - ----------------------------- - -- Default_Ada_Body_Suffix -- - ----------------------------- + --------------------------- + -- Delete_Temporary_File -- + --------------------------- + + procedure Delete_Temporary_File + (Tree : Project_Tree_Ref; + Path : Path_Name_Type) + is + Dont_Care : Boolean; + pragma Warnings (Off, Dont_Care); - function Default_Ada_Body_Suffix return Name_Id is begin - return Default_Ada_Body_Suffix_Id; - end Default_Ada_Body_Suffix; + if not Debug.Debug_Flag_N then + if Current_Verbosity = High then + Write_Line ("Removing temp file: " & Get_Name_String (Path)); + end if; - ----------------------------- - -- Default_Ada_Spec_Suffix -- - ----------------------------- + Delete_File (Get_Name_String (Path), Dont_Care); - function Default_Ada_Spec_Suffix return Name_Id is - begin - return Default_Ada_Spec_Suffix_Id; - end Default_Ada_Spec_Suffix; + 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; + end loop; + end if; + end Delete_Temporary_File; --------------------------- - -- Display_Language_Name -- + -- Delete_All_Temp_Files -- --------------------------- - procedure Display_Language_Name (Language : Language_Index) is + procedure Delete_All_Temp_Files (Tree : Project_Tree_Ref) is + Dont_Care : Boolean; + pragma Warnings (Off, Dont_Care); + + Path : Path_Name_Type; + begin - Get_Name_String (Language_Names.Table (Language)); - To_Upper (Name_Buffer (1 .. 1)); - Write_Str (Name_Buffer (1 .. Name_Len)); - end Display_Language_Name; + 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; + + Delete_File (Get_Name_String (Path), Dont_Care); + end if; + end loop; + + Temp_Files_Table.Free (Tree.Private_Part.Temp_Files); + Temp_Files_Table.Init (Tree.Private_Part.Temp_Files); + end if; + + -- 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. + + if Tree.Private_Part.Current_Source_Path_File /= No_Path then + Setenv (Project_Include_Path_File, ""); + end if; + + if Tree.Private_Part.Current_Object_Path_File /= No_Path then + Setenv (Project_Objects_Path_File, ""); + 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; + + ---------------- + -- 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; + 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; ------------------ @@ -254,19 +298,158 @@ 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; + ----------------- + -- 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; + + --------------------- + -- 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 @@ -280,90 +463,175 @@ package body Prj 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; + ----------------- + -- 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 + + begin + 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 -- ---------- + 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 + 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; + ----------------------------- + -- Is_Standard_GNAT_Naming -- + ----------------------------- + + function Is_Standard_GNAT_Naming + (Naming : Lang_Naming_Data) return Boolean + is + begin + 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 -- ---------------- 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; - Name_Len := 4; - Name_Buffer (1 .. 4) := ".ads"; - Default_Ada_Spec_Suffix_Id := Name_Find; - Name_Len := 4; - Name_Buffer (1 .. 4) := ".adb"; - Default_Ada_Body_Suffix_Id := Name_Find; - Name_Len := 1; - Name_Buffer (1) := '/'; - Slash_Id := Name_Find; - Name_Len := 3; - Name_Buffer (1 .. 3) := "c++"; - Name_C_Plus_Plus := Name_Find; - - Std_Naming_Data.Ada_Spec_Suffix := Default_Ada_Spec_Suffix; - Std_Naming_Data.Ada_Body_Suffix := Default_Ada_Body_Suffix; - Std_Naming_Data.Separate_Suffix := Default_Ada_Body_Suffix; - Project_Empty.Naming := Std_Naming_Data; - Prj.Env.Initialize; + Prj.Attr.Initialize; Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project)); Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends)); Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External)); - - Language_Indexes.Reset; - Last_Language_Index := No_Language_Index; - Language_Names.Init; - Add_Language_Name (Name_Ada); - Add_Language_Name (Name_C); - Add_Language_Name (Name_C_Plus_Plus); end if; if Tree /= No_Project_Tree then @@ -371,188 +639,257 @@ package body Prj is end if; end Initialize; - ---------------- - -- Is_Present -- - ---------------- + ------------------ + -- Is_Extending -- + ------------------ - function Is_Present - (Language : Language_Index; - In_Project : Project_Data; - In_Tree : Project_Tree_Ref) return Boolean + function Is_Extending + (Extending : Project_Id; + Extended : Project_Id) return Boolean is + Proj : Project_Id; + begin - case Language is - when No_Language_Index => - return False; + Proj := Extending; + while Proj /= No_Project loop + if Proj = Extended then + return True; + end if; - when First_Language_Indexes => - return In_Project.Languages (Language); + Proj := Proj.Extends; + end loop; - when others => - declare - Supp : Supp_Language; - Supp_Index : Supp_Language_Index := In_Project.Supp_Languages; + return False; + end Is_Extending; - begin - while Supp_Index /= No_Supp_Language_Index loop - Supp := In_Tree.Present_Languages.Table (Supp_Index); + ----------------- + -- Object_Name -- + ----------------- - if Supp.Index = Language then - return Supp.Present; - end if; + function Object_Name + (Source_File_Name : File_Name_Type; + Object_File_Suffix : Name_Id := No_Name) return File_Name_Type + is + 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; - Supp_Index := Supp.Next; - end loop; + 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; - return False; - end; - end case; - end Is_Present; + begin + Get_Name_String (Source_File_Name); + + 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; + + Add_Char_To_Name_Buffer (Index_Separator); + Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last)); - --------------------------------- - -- Language_Processing_Data_Of -- - --------------------------------- + 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; + + return Name_Find; + end Object_Name; - function Language_Processing_Data_Of - (Language : Language_Index; - In_Project : Project_Data; - In_Tree : Project_Tree_Ref) return Language_Processing_Data + ---------------------- + -- Record_Temp_File -- + ---------------------- + + procedure Record_Temp_File + (Tree : Project_Tree_Ref; + Path : Path_Name_Type) is begin - case Language is - when No_Language_Index => - return Default_Language_Processing_Data; + Temp_Files_Table.Append (Tree.Private_Part.Temp_Files, Path); + end Record_Temp_File; - when First_Language_Indexes => - return In_Project.First_Language_Processing (Language); + ---------- + -- Free -- + ---------- - when others => - declare - Supp : Supp_Language_Data; - Supp_Index : Supp_Language_Index := - In_Project.Supp_Language_Processing; + procedure Free (Project : in out Project_Id) is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Project_Data, Project_Id); - begin - while Supp_Index /= No_Supp_Language_Index loop - Supp := In_Tree.Supp_Languages.Table (Supp_Index); + begin + 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; - if Supp.Index = Language then - return Supp.Data; - end if; + --------------- + -- Free_List -- + --------------- - Supp_Index := Supp.Next; - end loop; + 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; - return Default_Language_Processing_Data; - end; - end case; - end Language_Processing_Data_Of; + --------------- + -- Free_List -- + --------------- - ------------------------------------ - -- Register_Default_Naming_Scheme -- - ------------------------------------ + procedure Free_List (Source : in out Source_Id) is + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Source_Data, Source_Id); - procedure Register_Default_Naming_Scheme - (Language : Name_Id; - Default_Spec_Suffix : Name_Id; - Default_Body_Suffix : Name_Id; - In_Tree : Project_Tree_Ref) - is - Lang : Name_Id; - Suffix : Array_Element_Id; - Found : Boolean := False; - Element : Array_Element; + Tmp : Source_Id; begin - -- Get the language name in small letters + 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; - Get_Name_String (Language); - Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len)); - Lang := Name_Find; + Unchecked_Free (Source); + Source := Tmp; + end loop; + end Free_List; - Suffix := In_Tree.Private_Part.Default_Naming.Spec_Suffix; - Found := False; + --------------- + -- Free_List -- + --------------- - -- Look for an element of the spec sufix 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); - 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 := Default_Spec_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; - -- If none can be found, create a new one - - if not Found then - Element := - (Index => Lang, - Src_Index => 0, - Index_Case_Sensitive => False, - Value => (Project => No_Project, - Kind => Single, - Location => No_Location, - Default => False, - Value => Default_Spec_Suffix, - Index => 0), - Next => In_Tree.Private_Part.Default_Naming.Spec_Suffix); - Array_Element_Table.Increment_Last (In_Tree.Array_Elements); - In_Tree.Array_Elements.Table - (Array_Element_Table.Last (In_Tree.Array_Elements)) := - Element; - In_Tree.Private_Part.Default_Naming.Spec_Suffix := - Array_Element_Table.Last (In_Tree.Array_Elements); - end if; + --------------- + -- Free_List -- + --------------- - Suffix := In_Tree.Private_Part.Default_Naming.Body_Suffix; - Found := False; + procedure Free_List (Languages : in out Language_Ptr) is + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Language_Data, Language_Ptr); - -- Look for an element of the body sufix array indexed by the language - -- name. If one is found, put the default value. + Tmp : Language_Ptr; - while Suffix /= No_Array_Element and then not Found loop - Element := In_Tree.Array_Elements.Table (Suffix); + begin + while Languages /= null loop + Tmp := Languages.Next; + Free_List (Languages.First_Source); + Unchecked_Free (Languages); + Languages := Tmp; + end loop; + end Free_List; - if Element.Index = Lang then - Found := True; - Element.Value.Value := Default_Body_Suffix; - In_Tree.Array_Elements.Table (Suffix) := Element; + ---------------- + -- Free_Units -- + ---------------- - else - Suffix := Element.Next; + 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; + + 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; - -- If none can be found, create a new one - - if not Found then - Element := - (Index => Lang, - Src_Index => 0, - Index_Case_Sensitive => False, - Value => (Project => No_Project, - Kind => Single, - Location => No_Location, - Default => False, - Value => Default_Body_Suffix, - Index => 0), - Next => In_Tree.Private_Part.Default_Naming.Body_Suffix); - Array_Element_Table.Increment_Last - (In_Tree.Array_Elements); - In_Tree.Array_Elements.Table - (Array_Element_Table.Last (In_Tree.Array_Elements)) - := Element; - In_Tree.Private_Part.Default_Naming.Body_Suffix := - Array_Element_Table.Last (In_Tree.Array_Elements); + 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 -- @@ -560,277 +897,378 @@ package body Prj is procedure Reset (Tree : Project_Tree_Ref) is begin - Prj.Env.Initialize; - Present_Language_Table.Init (Tree.Present_Languages); - Supp_Suffix_Table.Init (Tree.Supp_Suffixes); - Name_List_Table.Init (Tree.Name_Lists); - Supp_Language_Table.Init (Tree.Supp_Languages); - Other_Source_Table.Init (Tree.Other_Sources); - String_Element_Table.Init (Tree.String_Elements); - Variable_Element_Table.Init (Tree.Variable_Elements); - Array_Element_Table.Init (Tree.Array_Elements); - Array_Table.Init (Tree.Arrays); - Package_Table.Init (Tree.Packages); - Project_List_Table.Init (Tree.Project_Lists); - Project_Table.Init (Tree.Projects); - Unit_Table.Init (Tree.Units); - Units_Htable.Reset (Tree.Units_HT); - Files_Htable.Reset (Tree.Files_HT); - Naming_Table.Init (Tree.Private_Part.Namings); - Naming_Table.Increment_Last (Tree.Private_Part.Namings); - Tree.Private_Part.Namings.Table - (Naming_Table.Last (Tree.Private_Part.Namings)) := Std_Naming_Data; - Path_File_Table.Init (Tree.Private_Part.Path_Files); - Source_Path_Table.Init (Tree.Private_Part.Source_Paths); - Object_Path_Table.Init (Tree.Private_Part.Object_Paths); - Tree.Private_Part.Default_Naming := Std_Naming_Data; - Register_Default_Naming_Scheme - (Language => Name_Ada, - Default_Spec_Suffix => Default_Ada_Spec_Suffix, - Default_Body_Suffix => Default_Ada_Body_Suffix, - In_Tree => Tree); + -- Visible tables + + 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); + Source_Paths_Htable.Reset (Tree.Source_Paths_HT); + + Free_List (Tree.Projects, Free_Project => True); + Free_Units (Tree.Units_HT); + + -- Private part table + + 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.Ada_Spec_Suffix = Right.Ada_Spec_Suffix - and then Left.Ada_Body_Suffix = Right.Ada_Body_Suffix - and then Left.Separate_Suffix = Right.Separate_Suffix; - end Same_Naming_Scheme; - - --------- - -- Set -- - --------- - - procedure Set - (Language : Language_Index; - Present : Boolean; - In_Project : in out Project_Data; - In_Tree : Project_Tree_Ref) - is + return Extend_Name (Source_File_Name, Switches_Dependency_Suffix); + end Switches_Name; + + ----------- + -- Value -- + ----------- + + function Value (Image : String) return Casing_Type is begin - case Language is - when No_Language_Index => - null; + 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; - when First_Language_Indexes => - In_Project.Languages (Language) := Present; + raise Constraint_Error; + end Value; - when others => - declare - Supp : Supp_Language; - Supp_Index : Supp_Language_Index := In_Project.Supp_Languages; + --------------------- + -- Has_Ada_Sources -- + --------------------- - begin - while Supp_Index /= No_Supp_Language_Index loop - Supp := In_Tree.Present_Languages.Table - (Supp_Index); - - if Supp.Index = Language then - In_Tree.Present_Languages.Table - (Supp_Index).Present := Present; - return; - end if; + function Has_Ada_Sources (Data : Project_Id) return Boolean is + Lang : Language_Ptr; - Supp_Index := Supp.Next; - end loop; + begin + 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; - Supp := (Index => Language, Present => Present, - Next => In_Project.Supp_Languages); - Present_Language_Table.Increment_Last - (In_Tree.Present_Languages); - Supp_Index := Present_Language_Table.Last - (In_Tree.Present_Languages); - In_Tree.Present_Languages.Table (Supp_Index) := - Supp; - In_Project.Supp_Languages := Supp_Index; - end; - end case; - end Set; + return False; + end Has_Ada_Sources; + + ------------------------ + -- Contains_ALI_Files -- + ------------------------ + + 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 - (Language_Processing : Language_Processing_Data; - For_Language : Language_Index; - In_Project : in out Project_Data; - In_Tree : Project_Tree_Ref) - is begin - case For_Language is - when No_Language_Index => - null; + Open (Direct, Dir_Name); - when First_Language_Indexes => - In_Project.First_Language_Processing (For_Language) := - Language_Processing; + -- For each file in the directory, check if it is an ALI file - when others => - declare - Supp : Supp_Language_Data; - Supp_Index : Supp_Language_Index := - In_Project.Supp_Language_Processing; + 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 - while Supp_Index /= No_Supp_Language_Index loop - Supp := In_Tree.Supp_Languages.Table (Supp_Index); + Close (Direct); + return Result; - if Supp.Index = For_Language then - In_Tree.Supp_Languages.Table - (Supp_Index).Data := Language_Processing; - return; - end if; + exception + -- If there is any problem, close the directory if open and return True. + -- The library directory will be added to the path. - Supp_Index := Supp.Next; - end loop; + when others => + if Is_Open (Direct) then + Close (Direct); + end if; - Supp := (Index => For_Language, Data => Language_Processing, - Next => In_Project.Supp_Language_Processing); - Supp_Language_Table.Increment_Last - (In_Tree.Supp_Languages); - Supp_Index := Supp_Language_Table.Last - (In_Tree.Supp_Languages); - In_Tree.Supp_Languages.Table (Supp_Index) := Supp; - In_Project.Supp_Language_Processing := Supp_Index; - end; - end case; - end Set; + return True; + end Contains_ALI_Files; - procedure Set - (Suffix : Name_Id; - For_Language : Language_Index; - In_Project : in out Project_Data; - In_Tree : Project_Tree_Ref) + -------------------------- + -- Get_Object_Directory -- + -------------------------- + + function Get_Object_Directory + (Project : Project_Id; + Including_Libraries : Boolean; + Only_If_Ada : Boolean := False) return Path_Name_Type is begin - case For_Language is - when No_Language_Index => - null; - - when First_Language_Indexes => - In_Project.Naming.Impl_Suffixes (For_Language) := Suffix; - - when others => + 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; + + -- 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 - Supp : Supp_Suffix; - Supp_Index : Supp_Language_Index := - In_Project.Naming.Supp_Suffixes; + Add_Object_Dir : Boolean; + Prj : Project_Id; begin - while Supp_Index /= No_Supp_Language_Index loop - Supp := In_Tree.Supp_Suffixes.Table - (Supp_Index); - - if Supp.Index = For_Language then - In_Tree.Supp_Suffixes.Table - (Supp_Index).Suffix := Suffix; - return; + 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; - - Supp_Index := Supp.Next; end loop; - Supp := (Index => For_Language, Suffix => Suffix, - Next => In_Project.Naming.Supp_Suffixes); - Supp_Suffix_Table.Increment_Last - (In_Tree.Supp_Suffixes); - Supp_Index := Supp_Suffix_Table.Last - (In_Tree.Supp_Suffixes); - In_Tree.Supp_Suffixes.Table (Supp_Index) := Supp; - In_Project.Naming.Supp_Suffixes := Supp_Index; + if Add_Object_Dir then + return Project.Object_Directory.Name; + end if; end; - end case; - end Set; + end if; + end if; - ----------- - -- Slash -- - ----------- + 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; - function Slash return Name_Id is begin - return Slash_Id; - end Slash; + Prj := Proj; + while Prj /= null and then Prj.Extended_By /= No_Project loop + Prj := Prj.Extended_By; + end loop; - -------------------------- - -- Standard_Naming_Data -- - -------------------------- + return Prj; + end Ultimate_Extending_Project_Of; + + ----------------------------------- + -- Compute_All_Imported_Projects -- + ----------------------------------- + + procedure Compute_All_Imported_Projects (Tree : Project_Tree_Ref) is + Project : Project_Id; + + procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean); + -- Recursively add the projects imported by project Project, but not + -- those that are extended. + + ------------------- + -- Recursive_Add -- + ------------------- + + procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean) is + pragma Unreferenced (Dummy); + List : Project_List; + Prj2 : Project_Id; + + begin + -- A project is not importing itself + + Prj2 := Ultimate_Extending_Project_Of (Prj); + + if Project /= Prj2 then + + -- 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. + + 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 + + Project.All_Imported_Projects := + new Project_List_Element' + (Project => Prj2, + Next => Project.All_Imported_Projects); + end if; + end Recursive_Add; + + procedure For_All_Projects is + new For_Every_Project_Imported (Boolean, Recursive_Add); + + 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; + 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; - else - return Tree.Private_Part.Default_Naming; - end if; - end Standard_Naming_Data; + ------------------- + -- Is_Compilable -- + ------------------- - --------------- - -- Suffix_Of -- - --------------- + function Is_Compilable (Source : Source_Id) return Boolean is + begin + 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; + + ------------------------------ + -- Object_To_Global_Archive -- + ------------------------------ - function Suffix_Of - (Language : Language_Index; - In_Project : Project_Data; - In_Tree : Project_Tree_Ref) return Name_Id + 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 + N : Name_Id; + Result : Language_Ptr; + begin - case Language is - when No_Language_Index => - return No_Name; + 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; - when First_Language_Indexes => - return In_Project.Naming.Impl_Suffixes (Language); + Result := Result.Next; + end loop; - when others => - declare - Supp : Supp_Suffix; - Supp_Index : Supp_Language_Index := - In_Project.Naming.Supp_Suffixes; + return No_Language_Index; + end Get_Language_From_Name; - begin - while Supp_Index /= No_Supp_Language_Index loop - Supp := In_Tree.Supp_Suffixes.Table (Supp_Index); + ---------------- + -- Other_Part -- + ---------------- - if Supp.Index = Language then - return Supp.Suffix; - end if; + function Other_Part (Source : Source_Id) return Source_Id is + begin + 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; - Supp_Index := Supp.Next; - end loop; + ------------------ + -- Create_Flags -- + ------------------ - return No_Name; - end; - end case; - end Suffix_Of; + 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; - ----------- - -- Value -- - ----------- + ------------ + -- Length -- + ------------ + + function Length + (Table : Name_List_Table.Instance; + List : Name_List_Index) return Natural + is + Count : Natural := 0; + Tmp : Name_List_Index; - 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; + 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 project file extension is compatible - -- with canonical case file naming. + -- 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;