diff options
Diffstat (limited to 'gcc/ada/prj.adb')
| -rw-r--r-- | gcc/ada/prj.adb | 319 |
1 files changed, 182 insertions, 137 deletions
diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index ec7eeaa0903..e0c2f1bde20 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -28,10 +28,10 @@ with Ada.Unchecked_Deallocation; with Debug; with Osint; use Osint; +with Output; use Output; with Prj.Attr; with Prj.Err; use Prj.Err; with Snames; use Snames; -with Table; with Uintp; use Uintp; with GNAT.Directory_Operations; use GNAT.Directory_Operations; @@ -47,22 +47,20 @@ 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; - - Default_Ada_Spec_Suffix_Id : File_Name_Type; - Default_Ada_Body_Suffix_Id : File_Name_Type; - -- Initialized in Prj.Initialize, 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")); + type Cst_String_Access is access constant String; - Initialized : Boolean := False; + 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, @@ -114,16 +112,6 @@ package body Prj is 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 @@ -175,37 +163,77 @@ 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 File_Name_Type 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 File_Name_Type 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; --------------------------- -- Delete_All_Temp_Files -- --------------------------- - procedure Delete_All_Temp_Files is + procedure Delete_All_Temp_Files (Tree : Project_Tree_Ref) is Dont_Care : Boolean; pragma Warnings (Off, Dont_Care); + + Path : Path_Name_Type; + 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); + 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; @@ -271,7 +299,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,14 +498,72 @@ package body Prj is 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 -- @@ -518,25 +605,29 @@ package body Prj is return The_Casing_Images (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; - 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; Prj.Attr.Initialize; Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project)); @@ -549,18 +640,6 @@ package body Prj is end if; end Initialize; - ------------------- - -- Is_A_Language -- - ------------------- - - function Is_A_Language - (Project : Project_Id; - Language_Name : Name_Id) return Boolean is - begin - return Get_Language_From_Name - (Project, Get_Name_String (Language_Name)) /= null; - end Is_A_Language; - ------------------ -- Is_Extending -- ------------------ @@ -606,10 +685,12 @@ package body Prj is -- 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; ---------- @@ -766,22 +847,13 @@ package body Prj is Array_Table.Free (Tree.Arrays); Package_Table.Free (Tree.Packages); Source_Paths_Htable.Reset (Tree.Source_Paths_HT); - Unit_Sources_Htable.Reset (Tree.Unit_Sources_HT); Free_List (Tree.Projects, Free_Project => True); Free_Units (Tree.Units_HT); -- Private part - Path_File_Table.Free (Tree.Private_Part.Path_Files); - Source_Path_Table.Free (Tree.Private_Part.Source_Paths); - Object_Path_Table.Free (Tree.Private_Part.Object_Paths); - - Free (Tree.Private_Part.Ada_Path_Buffer); - - -- Naming data (nothing to free ???) - - null; + Temp_Files_Table.Free (Tree.Private_Part.Temp_Files); Unchecked_Free (Tree); end if; @@ -802,44 +874,17 @@ package body Prj is Array_Table.Init (Tree.Arrays); Package_Table.Init (Tree.Packages); Source_Paths_Htable.Reset (Tree.Source_Paths_HT); - Unit_Sources_Htable.Reset (Tree.Unit_Sources_HT); Free_List (Tree.Projects, Free_Project => True); Free_Units (Tree.Units_HT); -- Private part table - 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); - - if Current_Mode = Ada_Only then - Tree.Private_Part.Current_Source_Path_File := No_Path; - Tree.Private_Part.Current_Object_Path_File := No_Path; - Tree.Private_Part.Ada_Path_Length := 0; - Tree.Private_Part.Ada_Prj_Include_File_Set := False; - Tree.Private_Part.Ada_Prj_Objects_File_Set := False; - Tree.Private_Part.Fill_Mapping_File := True; - end if; - end Reset; - - -------------- - -- Set_Mode -- - -------------- + Temp_Files_Table.Init (Tree.Private_Part.Temp_Files); - 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; + Tree.Private_Part.Current_Source_Path_File := No_Path; + Tree.Private_Part.Current_Object_Path_File := No_Path; + end Reset; ------------------- -- Switches_Name -- @@ -886,29 +931,6 @@ package body Prj is return False; end Has_Ada_Sources; - ------------------------- - -- Has_Foreign_Sources -- - ------------------------- - - function Has_Foreign_Sources (Data : Project_Id) return Boolean is - Lang : Language_Ptr; - - begin - Lang := Data.Languages; - while Lang /= No_Language_Index loop - if Lang.Name /= Name_Ada - and then - (Current_Mode = Ada_Only or else Lang.First_Source /= No_Source) - then - return True; - end if; - - Lang := Lang.Next; - end loop; - - return False; - end Has_Foreign_Sources; - ------------------------ -- Contains_ALI_Files -- ------------------------ @@ -1086,7 +1108,8 @@ package body Prj is function Is_Compilable (Source : Source_Id) return Boolean is begin - return Source.Language.Config.Compiler_Driver /= Empty_File_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; @@ -1152,6 +1175,28 @@ package body Prj is 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) 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); + end Create_Flags; + begin -- Make sure that the standard config and user project file extensions are -- compatible with canonical case file naming. |