From a02740bf3317a567a563ee9dde43500466a07ea3 Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 5 Oct 2010 09:56:39 +0000 Subject: [PATCH] 2010-10-05 Vincent Celier * make.adb (Scan_Make_Arg): Take into account new switch --source-info=file. * makeusg.adb: Add line for new switch --source-info=file. * makeutl.ads (Source_Info_Option): New constant String for new builder switch. * prj-conf.adb: Put subprograms in alphabetical order (Process_Project_And_Apply_Config): Read/write an eventual source info file, if necessary. * prj-nmsc.adb (Look_For_Sources.Get_Sources_From_Source_Info): New procedure. (Look_For_Sources): If a source info file was successfully read, get the source data from the data read from the source info file. * prj-util.adb (Source_Info_Table): New table (Source_Info_Project_HTable): New hash table (Create): New procedure (Put (File), Put_Line): New procedures (Write_Source_Info_File): New procedure (Read_Source_Info_File): New procedure (Initialize): New procedure (Source_Info_Of): New procedure (Next): New procedure (Close): When file is an out file, fail if the buffer cannot be written or if the file cannot be close successfully. (Get_Line): Fail if file is an out file * prj-util.ads (Create): New procedure (Put (File), Put_Line): New procedures (Write_Source_Info_File): New procedure (Read_Source_Info_File): New procedure (Source_Info_Data): New record type (Source_Info_Iterator): New private type (Initialize): New procedure (Source_Info_Of): New procedure (Next): New procedure * prj.ads (Project_Tree_Data): New components Source_Info_File_Name and Source_Info_File_Exists. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@164975 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/make.adb | 6 + gcc/ada/makeusg.adb | 7 + gcc/ada/makeutl.ads | 3 + gcc/ada/prj-conf.adb | 607 +++++++++++++++++++++++++++------------------------ gcc/ada/prj-nmsc.adb | 140 ++++++++++-- gcc/ada/prj-util.adb | 368 ++++++++++++++++++++++++++++++- gcc/ada/prj-util.ads | 71 +++++- gcc/ada/prj.ads | 6 + 8 files changed, 905 insertions(+), 303 deletions(-) diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 2c2489c..da2707b 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -7988,6 +7988,12 @@ package body Make is end; end if; + elsif Argv'Length > Source_Info_Option'Length and then + Argv (1 .. Source_Info_Option'Length) = Source_Info_Option + then + Project_Tree.Source_Info_File_Name := + new String'(Argv (Source_Info_Option'Length + 1 .. Argv'Last)); + elsif Argv'Length >= 8 and then Argv (1 .. 8) = "--param=" then diff --git a/gcc/ada/makeusg.adb b/gcc/ada/makeusg.adb index 7f8ddb6..123907a 100644 --- a/gcc/ada/makeusg.adb +++ b/gcc/ada/makeusg.adb @@ -313,6 +313,13 @@ begin Write_Str (" --subdirs=dir real obj/lib/exec dirs are subdirs"); Write_Eol; + -- Line for --source-info= + + Write_Str (" "); + Write_Str (Makeutl.Source_Info_Option); + Write_Str ("file specify a source info file"); + Write_Eol; + -- Line for --unchecked-shared-lib-imports Write_Str (" "); diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index bb1c915..4bfe6cd 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -43,6 +43,9 @@ package Makeutl is Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data; -- The project tree + Source_Info_Option : constant String := "--source-info="; + -- Switch to indicate the source info file + Subdirs_Option : constant String := "--subdirs="; -- Switch used to indicate that the real directories (object, exec, -- library, ...) are subdirectories of those in the project file. diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index 23869e0..d30cf57 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -315,22 +315,194 @@ package body Prj.Conf is end loop; end Add_Attributes; - ------------------------ - -- Locate_Config_File -- - ------------------------ + ------------------------------------ + -- Add_Default_GNAT_Naming_Scheme -- + ------------------------------------ + + procedure Add_Default_GNAT_Naming_Scheme + (Config_File : in out Project_Node_Id; + Project_Tree : Project_Node_Tree_Ref) + is + procedure Create_Attribute + (Name : Name_Id; + Value : String; + Index : String := ""; + Pkg : Project_Node_Id := Empty_Node); + + ---------------------- + -- Create_Attribute -- + ---------------------- + + procedure Create_Attribute + (Name : Name_Id; + Value : String; + Index : String := ""; + Pkg : Project_Node_Id := Empty_Node) + is + Attr : Project_Node_Id; + pragma Unreferenced (Attr); + + Expr : Name_Id := No_Name; + Val : Name_Id := No_Name; + Parent : Project_Node_Id := Config_File; + begin + if Index /= "" then + Name_Len := Index'Length; + Name_Buffer (1 .. Name_Len) := Index; + Val := Name_Find; + end if; + + if Pkg /= Empty_Node then + Parent := Pkg; + end if; + + Name_Len := Value'Length; + Name_Buffer (1 .. Name_Len) := Value; + Expr := Name_Find; + + Attr := Create_Attribute + (Tree => Project_Tree, + Prj_Or_Pkg => Parent, + Name => Name, + Index_Name => Val, + Kind => Prj.Single, + Value => Create_Literal_String (Expr, Project_Tree)); + end Create_Attribute; + + -- Local variables + + Name : Name_Id; + Naming : Project_Node_Id; + + -- Start of processing for Add_Default_GNAT_Naming_Scheme - function Locate_Config_File (Name : String) return String_Access is - Prefix_Path : constant String := Executable_Prefix_Path; begin - if Prefix_Path'Length /= 0 then - return Locate_Regular_File - (Name, - "." & Path_Separator & - Prefix_Path & "share" & Directory_Separator & "gpr"); - else - return Locate_Regular_File (Name, "."); + if Config_File = Empty_Node then + + -- Create a dummy config file is none was found + + Name_Len := Auto_Cgpr'Length; + Name_Buffer (1 .. Name_Len) := Auto_Cgpr; + Name := Name_Find; + + -- An invalid project name to avoid conflicts with user-created ones + + Name_Len := 5; + Name_Buffer (1 .. Name_Len) := "_auto"; + + Config_File := + Create_Project + (In_Tree => Project_Tree, + Name => Name_Find, + Full_Path => Path_Name_Type (Name), + Is_Config_File => True); + + -- Setup library support + + case MLib.Tgt.Support_For_Libraries is + when None => + null; + + when Static_Only => + Create_Attribute (Name_Library_Support, "static_only"); + + when Full => + Create_Attribute (Name_Library_Support, "full"); + end case; + + if MLib.Tgt.Standalone_Library_Auto_Init_Is_Supported then + Create_Attribute (Name_Library_Auto_Init_Supported, "true"); + else + Create_Attribute (Name_Library_Auto_Init_Supported, "false"); + end if; + + -- Setup Ada support (Ada is the default language here, since this + -- is only called when no config file existed initially, ie for + -- gnatmake). + + Create_Attribute (Name_Default_Language, "ada"); + + Naming := Create_Package (Project_Tree, Config_File, "naming"); + Create_Attribute (Name_Spec_Suffix, ".ads", "ada", Pkg => Naming); + Create_Attribute (Name_Separate_Suffix, ".adb", "ada", Pkg => Naming); + Create_Attribute (Name_Body_Suffix, ".adb", "ada", Pkg => Naming); + Create_Attribute (Name_Dot_Replacement, "-", Pkg => Naming); + Create_Attribute (Name_Casing, "lowercase", Pkg => Naming); + + if Current_Verbosity = High then + Write_Line ("Automatically generated (in-memory) config file"); + Prj.PP.Pretty_Print + (Project => Config_File, + In_Tree => Project_Tree, + Backward_Compatibility => False); + end if; end if; - end Locate_Config_File; + end Add_Default_GNAT_Naming_Scheme; + + ----------------------- + -- Apply_Config_File -- + ----------------------- + + procedure Apply_Config_File + (Config_File : Prj.Project_Id; + Project_Tree : Prj.Project_Tree_Ref) + is + Conf_Decl : constant Declarations := Config_File.Decl; + Conf_Pack_Id : Package_Id; + Conf_Pack : Package_Element; + + User_Decl : Declarations; + User_Pack_Id : Package_Id; + User_Pack : Package_Element; + Proj : Project_List; + + begin + Proj := Project_Tree.Projects; + while Proj /= null loop + if Proj.Project /= Config_File then + User_Decl := Proj.Project.Decl; + Add_Attributes + (Project_Tree => Project_Tree, + Conf_Decl => Conf_Decl, + User_Decl => User_Decl); + + Conf_Pack_Id := Conf_Decl.Packages; + while Conf_Pack_Id /= No_Package loop + Conf_Pack := Project_Tree.Packages.Table (Conf_Pack_Id); + + User_Pack_Id := User_Decl.Packages; + while User_Pack_Id /= No_Package loop + User_Pack := Project_Tree.Packages.Table (User_Pack_Id); + exit when User_Pack.Name = Conf_Pack.Name; + User_Pack_Id := User_Pack.Next; + end loop; + + if User_Pack_Id = No_Package then + Package_Table.Increment_Last (Project_Tree.Packages); + User_Pack := Conf_Pack; + User_Pack.Next := User_Decl.Packages; + User_Decl.Packages := + Package_Table.Last (Project_Tree.Packages); + Project_Tree.Packages.Table (User_Decl.Packages) := + User_Pack; + + else + Add_Attributes + (Project_Tree => Project_Tree, + Conf_Decl => Conf_Pack.Decl, + User_Decl => Project_Tree.Packages.Table + (User_Pack_Id).Decl); + end if; + + Conf_Pack_Id := Conf_Pack.Next; + end loop; + + Proj.Project.Decl := User_Decl; + end if; + + Proj := Proj.Next; + end loop; + end Apply_Config_File; ------------------ -- Check_Target -- @@ -965,15 +1137,33 @@ package body Prj.Conf is end if; end Get_Or_Create_Configuration_File; - -------------------------------------- - -- Process_Project_And_Apply_Config -- - -------------------------------------- + ------------------------ + -- Locate_Config_File -- + ------------------------ - procedure Process_Project_And_Apply_Config + function Locate_Config_File (Name : String) return String_Access is + Prefix_Path : constant String := Executable_Prefix_Path; + begin + if Prefix_Path'Length /= 0 then + return Locate_Regular_File + (Name, + "." & Path_Separator & + Prefix_Path & "share" & Directory_Separator & "gpr"); + else + return Locate_Regular_File (Name, "."); + end if; + end Locate_Config_File; + + ------------------------------------ + -- Parse_Project_And_Apply_Config -- + ------------------------------------ + + procedure Parse_Project_And_Apply_Config (Main_Project : out Prj.Project_Id; - User_Project_Node : Prj.Tree.Project_Node_Id; + User_Project_Node : out Prj.Tree.Project_Node_Id; Config_File_Name : String := ""; Autoconf_Specified : Boolean; + Project_File_Name : String; Project_Tree : Prj.Project_Tree_Ref; Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; Packages_To_Check : String_List_Access; @@ -983,93 +1173,15 @@ package body Prj.Conf is Target_Name : String := ""; Normalized_Hostname : String; Flags : Processing_Flags; - On_Load_Config : Config_File_Hook := null; - Reset_Tree : Boolean := True) + On_Load_Config : Config_File_Hook := null) is - Main_Config_Project : Project_Id; - Success : Boolean; - begin - Main_Project := No_Project; - Automatically_Generated := False; - - Process_Project_Tree_Phase_1 - (In_Tree => Project_Tree, - Project => Main_Project, - Success => Success, - From_Project_Node => User_Project_Node, - From_Project_Node_Tree => Project_Node_Tree, - Flags => Flags, - Reset_Tree => Reset_Tree); + -- Parse the user project tree - if not Success then - Main_Project := No_Project; - return; - end if; + Prj.Initialize (Project_Tree); - -- Find configuration file - - Get_Or_Create_Configuration_File - (Config => Main_Config_Project, - Project => Main_Project, - Project_Tree => Project_Tree, - Project_Node_Tree => Project_Node_Tree, - Allow_Automatic_Generation => Allow_Automatic_Generation, - Config_File_Name => Config_File_Name, - Autoconf_Specified => Autoconf_Specified, - Target_Name => Target_Name, - Normalized_Hostname => Normalized_Hostname, - Packages_To_Check => Packages_To_Check, - Config_File_Path => Config_File_Path, - Automatically_Generated => Automatically_Generated, - Flags => Flags, - On_Load_Config => On_Load_Config); - - Apply_Config_File (Main_Config_Project, Project_Tree); - - -- Finish processing the user's project - - Prj.Proc.Process_Project_Tree_Phase_2 - (In_Tree => Project_Tree, - Project => Main_Project, - Success => Success, - From_Project_Node => User_Project_Node, - From_Project_Node_Tree => Project_Node_Tree, - Flags => Flags); - - if not Success then - Main_Project := No_Project; - end if; - end Process_Project_And_Apply_Config; - - ------------------------------------ - -- Parse_Project_And_Apply_Config -- - ------------------------------------ - - procedure Parse_Project_And_Apply_Config - (Main_Project : out Prj.Project_Id; - User_Project_Node : out Prj.Tree.Project_Node_Id; - Config_File_Name : String := ""; - Autoconf_Specified : Boolean; - Project_File_Name : String; - Project_Tree : Prj.Project_Tree_Ref; - Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; - Packages_To_Check : String_List_Access; - Allow_Automatic_Generation : Boolean := True; - Automatically_Generated : out Boolean; - Config_File_Path : out String_Access; - Target_Name : String := ""; - Normalized_Hostname : String; - Flags : Processing_Flags; - On_Load_Config : Config_File_Hook := null) - is - begin - -- Parse the user project tree - - Prj.Initialize (Project_Tree); - - Main_Project := No_Project; - Automatically_Generated := False; + Main_Project := No_Project; + Automatically_Generated := False; Prj.Part.Parse (In_Tree => Project_Node_Tree, @@ -1103,81 +1215,125 @@ package body Prj.Conf is On_Load_Config => On_Load_Config); end Parse_Project_And_Apply_Config; - ----------------------- - -- Apply_Config_File -- - ----------------------- + -------------------------------------- + -- Process_Project_And_Apply_Config -- + -------------------------------------- - procedure Apply_Config_File - (Config_File : Prj.Project_Id; - Project_Tree : Prj.Project_Tree_Ref) + procedure Process_Project_And_Apply_Config + (Main_Project : out Prj.Project_Id; + User_Project_Node : Prj.Tree.Project_Node_Id; + Config_File_Name : String := ""; + Autoconf_Specified : Boolean; + Project_Tree : Prj.Project_Tree_Ref; + Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Packages_To_Check : String_List_Access; + Allow_Automatic_Generation : Boolean := True; + Automatically_Generated : out Boolean; + Config_File_Path : out String_Access; + Target_Name : String := ""; + Normalized_Hostname : String; + Flags : Processing_Flags; + On_Load_Config : Config_File_Hook := null; + Reset_Tree : Boolean := True) is - Conf_Decl : constant Declarations := Config_File.Decl; - Conf_Pack_Id : Package_Id; - Conf_Pack : Package_Element; - - User_Decl : Declarations; - User_Pack_Id : Package_Id; - User_Pack : Package_Element; - Proj : Project_List; + Main_Config_Project : Project_Id; + Success : Boolean; begin - Proj := Project_Tree.Projects; - while Proj /= null loop - if Proj.Project /= Config_File then - User_Decl := Proj.Project.Decl; - Add_Attributes - (Project_Tree => Project_Tree, - Conf_Decl => Conf_Decl, - User_Decl => User_Decl); + Main_Project := No_Project; + Automatically_Generated := False; - Conf_Pack_Id := Conf_Decl.Packages; - while Conf_Pack_Id /= No_Package loop - Conf_Pack := Project_Tree.Packages.Table (Conf_Pack_Id); + Process_Project_Tree_Phase_1 + (In_Tree => Project_Tree, + Project => Main_Project, + Success => Success, + From_Project_Node => User_Project_Node, + From_Project_Node_Tree => Project_Node_Tree, + Flags => Flags, + Reset_Tree => Reset_Tree); - User_Pack_Id := User_Decl.Packages; - while User_Pack_Id /= No_Package loop - User_Pack := Project_Tree.Packages.Table (User_Pack_Id); - exit when User_Pack.Name = Conf_Pack.Name; - User_Pack_Id := User_Pack.Next; - end loop; + if not Success then + Main_Project := No_Project; + return; + end if; - if User_Pack_Id = No_Package then - Package_Table.Increment_Last (Project_Tree.Packages); - User_Pack := Conf_Pack; - User_Pack.Next := User_Decl.Packages; - User_Decl.Packages := - Package_Table.Last (Project_Tree.Packages); - Project_Tree.Packages.Table (User_Decl.Packages) := - User_Pack; + if Project_Tree.Source_Info_File_Name /= null then + if not Is_Absolute_Path (Project_Tree.Source_Info_File_Name.all) then + declare + Obj_Dir : constant Variable_Value := + Value_Of + (Name_Object_Dir, + Main_Project.Decl.Attributes, + Project_Tree); + + begin + if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then + Get_Name_String (Main_Project.Directory.Display_Name); else - Add_Attributes - (Project_Tree => Project_Tree, - Conf_Decl => Conf_Pack.Decl, - User_Decl => Project_Tree.Packages.Table - (User_Pack_Id).Decl); + if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then + Get_Name_String (Obj_Dir.Value); + + else + Name_Len := 0; + Add_Str_To_Name_Buffer + (Get_Name_String (Main_Project.Directory.Display_Name)); + Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value)); + end if; end if; - Conf_Pack_Id := Conf_Pack.Next; - end loop; - - Proj.Project.Decl := User_Decl; + Add_Char_To_Name_Buffer (Directory_Separator); + Add_Str_To_Name_Buffer (Project_Tree.Source_Info_File_Name.all); + Free (Project_Tree.Source_Info_File_Name); + Project_Tree.Source_Info_File_Name := + new String'(Name_Buffer (1 .. Name_Len)); + end; end if; - Proj := Proj.Next; - end loop; - end Apply_Config_File; + Read_Source_Info_File (Project_Tree); + end if; - --------------------- - -- Set_Runtime_For -- - --------------------- + -- Find configuration file - procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String) is - begin - Name_Len := RTS_Name'Length; - Name_Buffer (1 .. Name_Len) := RTS_Name; - RTS_Languages.Set (Language, Name_Find); - end Set_Runtime_For; + Get_Or_Create_Configuration_File + (Config => Main_Config_Project, + Project => Main_Project, + Project_Tree => Project_Tree, + Project_Node_Tree => Project_Node_Tree, + Allow_Automatic_Generation => Allow_Automatic_Generation, + Config_File_Name => Config_File_Name, + Autoconf_Specified => Autoconf_Specified, + Target_Name => Target_Name, + Normalized_Hostname => Normalized_Hostname, + Packages_To_Check => Packages_To_Check, + Config_File_Path => Config_File_Path, + Automatically_Generated => Automatically_Generated, + Flags => Flags, + On_Load_Config => On_Load_Config); + + Apply_Config_File (Main_Config_Project, Project_Tree); + + -- Finish processing the user's project + + Prj.Proc.Process_Project_Tree_Phase_2 + (In_Tree => Project_Tree, + Project => Main_Project, + Success => Success, + From_Project_Node => User_Project_Node, + From_Project_Node_Tree => Project_Node_Tree, + Flags => Flags); + + if Success then + if Project_Tree.Source_Info_File_Name /= null and then + not Project_Tree.Source_Info_File_Exists + then + Write_Source_Info_File (Project_Tree); + end if; + + else + Main_Project := No_Project; + end if; + end Process_Project_And_Apply_Config; ---------------------- -- Runtime_Name_For -- @@ -1192,128 +1348,15 @@ package body Prj.Conf is end if; end Runtime_Name_For; - ------------------------------------ - -- Add_Default_GNAT_Naming_Scheme -- - ------------------------------------ - - procedure Add_Default_GNAT_Naming_Scheme - (Config_File : in out Project_Node_Id; - Project_Tree : Project_Node_Tree_Ref) - is - procedure Create_Attribute - (Name : Name_Id; - Value : String; - Index : String := ""; - Pkg : Project_Node_Id := Empty_Node); - - ---------------------- - -- Create_Attribute -- - ---------------------- - - procedure Create_Attribute - (Name : Name_Id; - Value : String; - Index : String := ""; - Pkg : Project_Node_Id := Empty_Node) - is - Attr : Project_Node_Id; - pragma Unreferenced (Attr); - - Expr : Name_Id := No_Name; - Val : Name_Id := No_Name; - Parent : Project_Node_Id := Config_File; - begin - if Index /= "" then - Name_Len := Index'Length; - Name_Buffer (1 .. Name_Len) := Index; - Val := Name_Find; - end if; - - if Pkg /= Empty_Node then - Parent := Pkg; - end if; - - Name_Len := Value'Length; - Name_Buffer (1 .. Name_Len) := Value; - Expr := Name_Find; - - Attr := Create_Attribute - (Tree => Project_Tree, - Prj_Or_Pkg => Parent, - Name => Name, - Index_Name => Val, - Kind => Prj.Single, - Value => Create_Literal_String (Expr, Project_Tree)); - end Create_Attribute; - - -- Local variables - - Name : Name_Id; - Naming : Project_Node_Id; - - -- Start of processing for Add_Default_GNAT_Naming_Scheme + --------------------- + -- Set_Runtime_For -- + --------------------- + procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String) is begin - if Config_File = Empty_Node then - - -- Create a dummy config file is none was found - - Name_Len := Auto_Cgpr'Length; - Name_Buffer (1 .. Name_Len) := Auto_Cgpr; - Name := Name_Find; - - -- An invalid project name to avoid conflicts with user-created ones - - Name_Len := 5; - Name_Buffer (1 .. Name_Len) := "_auto"; - - Config_File := - Create_Project - (In_Tree => Project_Tree, - Name => Name_Find, - Full_Path => Path_Name_Type (Name), - Is_Config_File => True); - - -- Setup library support - - case MLib.Tgt.Support_For_Libraries is - when None => - null; - - when Static_Only => - Create_Attribute (Name_Library_Support, "static_only"); - - when Full => - Create_Attribute (Name_Library_Support, "full"); - end case; - - if MLib.Tgt.Standalone_Library_Auto_Init_Is_Supported then - Create_Attribute (Name_Library_Auto_Init_Supported, "true"); - else - Create_Attribute (Name_Library_Auto_Init_Supported, "false"); - end if; - - -- Setup Ada support (Ada is the default language here, since this - -- is only called when no config file existed initially, ie for - -- gnatmake). - - Create_Attribute (Name_Default_Language, "ada"); - - Naming := Create_Package (Project_Tree, Config_File, "naming"); - Create_Attribute (Name_Spec_Suffix, ".ads", "ada", Pkg => Naming); - Create_Attribute (Name_Separate_Suffix, ".adb", "ada", Pkg => Naming); - Create_Attribute (Name_Body_Suffix, ".adb", "ada", Pkg => Naming); - Create_Attribute (Name_Dot_Replacement, "-", Pkg => Naming); - Create_Attribute (Name_Casing, "lowercase", Pkg => Naming); - - if Current_Verbosity = High then - Write_Line ("Automatically generated (in-memory) config file"); - Prj.PP.Pretty_Print - (Project => Config_File, - In_Tree => Project_Tree, - Backward_Compatibility => False); - end if; - end if; - end Add_Default_GNAT_Naming_Scheme; + Name_Len := RTS_Name'Length; + Name_Buffer (1 .. Name_Len) := RTS_Name; + RTS_Languages.Set (Language, Name_Find); + end Set_Runtime_For; end Prj.Conf; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 0849a90..2a1d90b 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -32,6 +32,7 @@ with Err_Vars; use Err_Vars; with Opt; use Opt; with Osint; use Osint; with Output; use Output; +with Prj.Com; with Prj.Err; use Prj.Err; with Prj.Util; use Prj.Util; with Sinput.P; @@ -7175,8 +7176,8 @@ package body Prj.Nmsc is Data : in out Tree_Processing_Data) is Object_Files : Object_File_Names_Htable.Instance; - Iter : Source_Iterator; - Src : Source_Id; + Iter : Source_Iterator; + Src : Source_Id; procedure Check_Object (Src : Source_Id); -- Check if object file name of Src is already used in the project tree, @@ -7192,6 +7193,10 @@ package body Prj.Nmsc is -- Check whether one of the languages has no sources, and report an -- error when appropriate + procedure Get_Sources_From_Source_Info; + -- Get the source information from the tabes that were created when a + -- source info fie was read. + --------------------------- -- Check_Missing_Sources -- --------------------------- @@ -7421,22 +7426,131 @@ package body Prj.Nmsc is end loop; end Check_Object_Files; + ---------------------------------- + -- Get_Sources_From_Source_Info -- + ---------------------------------- + + procedure Get_Sources_From_Source_Info is + Iter : Source_Info_Iterator; + Src : Source_Info; + Id : Source_Id; + Lang_Id : Language_Ptr; + begin + Initialize (Iter, Project.Project.Name); + + loop + Src := Source_Info_Of (Iter); + + exit when Src = No_Source_Info; + + Id := new Source_Data; + + Id.Project := Project.Project; + + Lang_Id := Project.Project.Languages; + while Lang_Id /= No_Language_Index and then + Lang_Id.Name /= Src.Language + loop + Lang_Id := Lang_Id.Next; + end loop; + + if Lang_Id = No_Language_Index then + Prj.Com.Fail + ("unknown language " & + Get_Name_String (Src.Language) & + " for project " & + Get_Name_String (Src.Project) & + " in source info file"); + end if; + + Id.Language := Lang_Id; + Id.Kind := Src.Kind; + + Id.Index := Src.Index; + + Id.Path := + (Path_Name_Type (Src.Display_Path_Name), + Path_Name_Type (Src.Path_Name)); + + Name_Len := 0; + Add_Str_To_Name_Buffer + (Ada.Directories.Simple_Name + (Get_Name_String (Src.Path_Name))); + Id.File := Name_Find; + + Name_Len := 0; + Add_Str_To_Name_Buffer + (Ada.Directories.Simple_Name + (Get_Name_String (Src.Display_Path_Name))); + Id.Display_File := Name_Find; + + Id.Dep_Name := Dependency_Name + (Id.File, Id.Language.Config.Dependency_Kind); + Id.Naming_Exception := Src.Naming_Exception; + Id.Object := Object_Name + (Id.File, Id.Language.Config.Object_File_Suffix); + Id.Switches := Switches_Name (Id.File); + + -- Add the source id to the Unit_Sources_HT hash table, if the + -- unit name is not null. + + if Src.Kind /= Sep and then Src.Unit_Name /= No_Name then + + declare + UData : Unit_Index := + Units_Htable.Get (Data.Tree.Units_HT, Src.Unit_Name); + begin + if UData = No_Unit_Index then + UData := new Unit_Data; + UData.Name := Src.Unit_Name; + Units_Htable.Set + (Data.Tree.Units_HT, Src.Unit_Name, UData); + end if; + + Id.Unit := UData; + end; + + -- Note that this updates Unit information as well + + Override_Kind (Id, Id.Kind); + end if; + + if Src.Index /= 0 then + Project.Project.Has_Multi_Unit_Sources := True; + end if; + + -- Add the source to the language list + + Id.Next_In_Lang := Id.Language.First_Source; + Id.Language.First_Source := Id; + + Files_Htable.Set (Data.File_To_Source, Id.File, Id); + + Next (Iter); + end loop; + end Get_Sources_From_Source_Info; + -- Start of processing for Look_For_Sources begin - if Project.Project.Source_Dirs /= Nil_String then - Find_Excluded_Sources (Project, Data); - - if Project.Project.Languages /= No_Language_Index then - Load_Naming_Exceptions (Project, Data); - Find_Sources (Project, Data); - Mark_Excluded_Sources; - Check_Object_Files; - Check_Missing_Sources; + if Data.Tree.Source_Info_File_Exists then + Get_Sources_From_Source_Info; + + else + if Project.Project.Source_Dirs /= Nil_String then + Find_Excluded_Sources (Project, Data); + + if Project.Project.Languages /= No_Language_Index then + Load_Naming_Exceptions (Project, Data); + Find_Sources (Project, Data); + Mark_Excluded_Sources; + Check_Object_Files; + Check_Missing_Sources; + end if; end if; - end if; - Object_File_Names_Htable.Reset (Object_Files); + Object_File_Names_Htable.Reset (Object_Files); + end if; end Look_For_Sources; ------------------ diff --git a/gcc/ada/prj-util.adb b/gcc/ada/prj-util.adb index d714cdb..ce5c38f 100644 --- a/gcc/ada/prj-util.adb +++ b/gcc/ada/prj-util.adb @@ -29,12 +29,32 @@ with GNAT.Case_Util; use GNAT.Case_Util; with Osint; use Osint; with Output; use Output; +with Opt; with Prj.Com; with Snames; use Snames; +with Table; with Targparm; use Targparm; +with GNAT.HTable; + package body Prj.Util is + package Source_Info_Table is new Table.Table + (Table_Component_Type => Source_Info_Iterator, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Makeutl.Source_Info_Table"); + + package Source_Info_Project_HTable is new GNAT.HTable.Simple_HTable + (Header_Num => Prj.Header_Num, + Element => Natural, + No_Element => 0, + Key => Name_Id, + Hash => Prj.Hash, + Equal => "="); + procedure Free is new Ada.Unchecked_Deallocation (Text_File_Data, Text_File); @@ -43,18 +63,65 @@ package body Prj.Util is ----------- procedure Close (File : in out Text_File) is + Len : Integer; + Status : Boolean; + begin if File = null then Prj.Com.Fail ("Close attempted on an invalid Text_File"); end if; - -- Close file, no need to test status, since this is a file that we - -- read, and the file was read successfully before we closed it. + if File.Out_File then + if File.Buffer_Len > 0 then + Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len); + + if Len /= File.Buffer_Len then + Prj.Com.Fail ("Unable to write to an out Text_File"); + end if; + end if; + + Close (File.FD, Status); + + if not Status then + Prj.Com.Fail ("Unable to close an out Text_File"); + end if; + + else + + -- Close in file, no need to test status, since this is a file that + -- we read, and the file was read successfully before we closed it. + + Close (File.FD); + end if; - Close (File.FD); Free (File); end Close; + ------------ + -- Create -- + ------------ + + procedure Create (File : out Text_File; Name : String) is + FD : File_Descriptor; + File_Name : String (1 .. Name'Length + 1); + + begin + File_Name (1 .. Name'Length) := Name; + File_Name (File_Name'Last) := ASCII.NUL; + FD := Create_File (Name => File_Name'Address, + Fmode => GNAT.OS_Lib.Text); + + if FD = Invalid_FD then + File := null; + + else + File := new Text_File_Data; + File.FD := FD; + File.Out_File := True; + File.End_Of_File_Reached := True; + end if; + end Create; + --------------- -- Duplicate -- --------------- @@ -365,6 +432,9 @@ package body Prj.Util is begin if File = null then Prj.Com.Fail ("Get_Line attempted on an invalid Text_File"); + + elsif File.Out_File then + Prj.Com.Fail ("Get_Line attempted on an out file"); end if; Last := Line'First - 1; @@ -400,6 +470,23 @@ package body Prj.Util is end if; end Get_Line; + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (Iter : out Source_Info_Iterator; For_Project : Name_Id) + is + Ind : constant Natural := Source_Info_Project_HTable.Get (For_Project); + begin + if Ind = 0 then + Iter := (No_Source_Info, 0); + + else + Iter := Source_Info_Table.Table (Ind); + end if; + end Initialize; + -------------- -- Is_Valid -- -------------- @@ -410,6 +497,20 @@ package body Prj.Util is end Is_Valid; ---------- + -- Next -- + ---------- + + procedure Next (Iter : in out Source_Info_Iterator) is + begin + if Iter.Next = 0 then + Iter.Info := No_Source_Info; + + else + Iter := Source_Info_Table.Table (Iter.Next); + end if; + end Next; + + ---------- -- Open -- ---------- @@ -496,6 +597,194 @@ package body Prj.Util is end loop; end Put; + procedure Put (File : Text_File; S : String) is + Len : Integer; + begin + if File = null then + Prj.Com.Fail ("Attempted to write on an invalid Text_File"); + + elsif not File.Out_File then + Prj.Com.Fail ("Attempted to write an in Text_File"); + end if; + + if File.Buffer_Len + S'Length > File.Buffer'Last then + -- Write buffer + Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len); + + if Len /= File.Buffer_Len then + Prj.Com.Fail ("Failed to write to an out Text_File"); + end if; + + File.Buffer_Len := 0; + end if; + + File.Buffer (File.Buffer_Len + 1 .. File.Buffer_Len + S'Length) := S; + File.Buffer_Len := File.Buffer_Len + S'Length; + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (File : Text_File; Line : String) is + L : String (1 .. Line'Length + 1); + begin + L (1 .. Line'Length) := Line; + L (L'Last) := ASCII.LF; + Put (File, L); + end Put_Line; + + --------------------------- + -- Read_Source_Info_File -- + --------------------------- + + procedure Read_Source_Info_File (Tree : Project_Tree_Ref) is + File : Text_File; + Info : Source_Info_Iterator; + Proj : Name_Id; + + procedure Report_Error; + + ------------------ + -- Report_Error -- + ------------------ + + procedure Report_Error is + begin + Write_Line ("errors in source info file """ & + Tree.Source_Info_File_Name.all & '"'); + Tree.Source_Info_File_Exists := False; + end Report_Error; + + begin + Source_Info_Project_HTable.Reset; + Source_Info_Table.Init; + + if Tree.Source_Info_File_Name = null then + Tree.Source_Info_File_Exists := False; + return; + end if; + + Open (File, Tree.Source_Info_File_Name.all); + + if not Is_Valid (File) then + if Opt.Verbose_Mode then + Write_Line ("source info file " & Tree.Source_Info_File_Name.all & + " does not exist"); + end if; + + Tree.Source_Info_File_Exists := False; + return; + end if; + + Tree.Source_Info_File_Exists := True; + + if Opt.Verbose_Mode then + Write_Line ("Reading source info file " & + Tree.Source_Info_File_Name.all); + end if; + + Source_Loop : + while not End_Of_File (File) loop + Info := (new Source_Info_Data, 0); + Source_Info_Table.Increment_Last; + + -- project name + Get_Line (File, Name_Buffer, Name_Len); + Proj := Name_Find; + Info.Info.Project := Proj; + Info.Next := Source_Info_Project_HTable.Get (Proj); + Source_Info_Project_HTable.Set (Proj, Source_Info_Table.Last); + + if End_Of_File (File) then + Report_Error; + exit Source_Loop; + end if; + + -- language name + Get_Line (File, Name_Buffer, Name_Len); + Info.Info.Language := Name_Find; + + if End_Of_File (File) then + Report_Error; + exit Source_Loop; + end if; + + -- kind + Get_Line (File, Name_Buffer, Name_Len); + Info.Info.Kind := Source_Kind'Value (Name_Buffer (1 .. Name_Len)); + + if End_Of_File (File) then + Report_Error; + exit Source_Loop; + end if; + + -- display path name + Get_Line (File, Name_Buffer, Name_Len); + Info.Info.Display_Path_Name := Name_Find; + Info.Info.Path_Name := Info.Info.Display_Path_Name; + + if End_Of_File (File) then + Report_Error; + exit Source_Loop; + end if; + + -- optional fields + Option_Loop : + loop + Get_Line (File, Name_Buffer, Name_Len); + exit Option_Loop when Name_Len = 0; + + if Name_Len <= 2 then + Report_Error; + exit Source_Loop; + + else + if Name_Buffer (1 .. 2) = "P=" then + Name_Buffer (1 .. Name_Len - 2) := + Name_Buffer (3 .. Name_Len); + Name_Len := Name_Len - 2; + Info.Info.Path_Name := Name_Find; + + elsif Name_Buffer (1 .. 2) = "U=" then + Name_Buffer (1 .. Name_Len - 2) := + Name_Buffer (3 .. Name_Len); + Name_Len := Name_Len - 2; + Info.Info.Unit_Name := Name_Find; + + elsif Name_Buffer (1 .. 2) = "I=" then + Info.Info.Index := Int'Value (Name_Buffer (3 .. Name_Len)); + + elsif Name_Buffer (1 .. Name_Len) = "N=T" then + Info.Info.Naming_Exception := True; + + else + Report_Error; + exit Source_Loop; + end if; + end if; + end loop Option_Loop; + + Source_Info_Table.Table (Source_Info_Table.Last) := Info; + end loop Source_Loop; + + Close (File); + + exception + when others => + Close (File); + Report_Error; + end Read_Source_Info_File; + + -------------------- + -- Source_Info_Of -- + -------------------- + + function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info is + begin + return Iter.Info; + end Source_Info_Of; + -------------- -- Value_Of -- -------------- @@ -746,6 +1035,79 @@ package body Prj.Util is return Nil_Variable_Value; end Value_Of; + ---------------------------- + -- Write_Source_Info_File -- + ---------------------------- + + procedure Write_Source_Info_File (Tree : Project_Tree_Ref) is + Iter : Source_Iterator := For_Each_Source (Tree); + Source : Prj.Source_Id; + File : Text_File; + begin + if Opt.Verbose_Mode then + Write_Line ("Writing new source info file " & + Tree.Source_Info_File_Name.all); + end if; + + Create (File, Tree.Source_Info_File_Name.all); + + if not Is_Valid (File) then + Write_Line ("warning: unable to create source info file """ & + Tree.Source_Info_File_Name.all & '"'); + return; + end if; + + loop + Source := Element (Iter); + exit when Source = No_Source; + + if not Source.Locally_Removed and then + Source.Replaced_By = No_Source + then + -- project name + Put_Line (File, Get_Name_String (Source.Project.Name)); + -- language name + Put_Line (File, Get_Name_String (Source.Language.Name)); + -- kind + Put_Line (File, Source.Kind'Img); + -- display path name + Put_Line (File, Get_Name_String (Source.Path.Display_Name)); + + -- Optional lines: + + -- path name (P=) + if Source.Path.Name /= Source.Path.Display_Name then + Put (File, "P="); + Put_Line (File, Get_Name_String (Source.Path.Name)); + end if; + + -- unit name (U=) + if Source.Unit /= No_Unit_Index then + Put (File, "U="); + Put_Line (File, Get_Name_String (Source.Unit.Name)); + end if; + + -- multi-source index (I=) + if Source.Index /= 0 then + Put (File, "I="); + Put_Line (File, Source.Index'Img); + end if; + + -- naming exception ("N=T"); + if Source.Naming_Exception then + Put_Line (File, "N=T"); + end if; + + -- empty line to indicate end of info on this source + Put_Line (File, ""); + end if; + + Next (Iter); + end loop; + + Close (File); + end Write_Source_Info_File; + --------------- -- Write_Str -- --------------- diff --git a/gcc/ada/prj-util.ads b/gcc/ada/prj-util.ads index 3c1ac0a..b34769e 100644 --- a/gcc/ada/prj-util.ads +++ b/gcc/ada/prj-util.ads @@ -160,32 +160,93 @@ package Prj.Util is -- closed. procedure Open (File : out Text_File; Name : String); - -- Open a text file to read (file is invalid if text file cannot be opened) + -- Open a text file to read (File is invalid if text file cannot be opened) + + procedure Create (File : out Text_File; Name : String); + -- Create a text file to write (File is invaid if text file cannot be + -- created). function End_Of_File (File : Text_File) return Boolean; -- Returns True if the end of the text file File has been reached. Fails if - -- File is invalid. + -- File is invalid. Return True if File is an out file. procedure Get_Line (File : Text_File; Line : out String; Last : out Natural); - -- Reads a line from an open text file (fails if file is invalid) + -- Reads a line from an open text file (fails if File is invalid or in an + -- out file). + + procedure Put (File : Text_File; S : String); + procedure Put_Line (File : Text_File; Line : String); + -- Output a string or a line to an out text file (fails if File is invalid + -- or in an in file). procedure Close (File : in out Text_File); -- Close an open text file. File becomes invalid. Fails if File is already - -- invalid. + -- invalid or if an out file cannot be closed successfully. + + ----------------------- + -- Source info files -- + ----------------------- + + procedure Write_Source_Info_File (Tree : Project_Tree_Ref); + -- Create a new source info file, with the path name specified in the + -- project tree data. Issue a warning if it is not possible to create + -- the new file. + + procedure Read_Source_Info_File (Tree : Project_Tree_Ref); + -- Check if there is a source info file specified for the project Tree and + -- if there is one, attempt to read it. If the file exists and is + -- successfully read, set the flag Source_Info_File_Exists to True for + -- the tree. + + type Source_Info_Data is record + Project : Name_Id; + Language : Name_Id; + Kind : Source_Kind; + Display_Path_Name : Name_Id; + Path_Name : Name_Id; + Unit_Name : Name_Id := No_Name; + Index : Int := 0; + Naming_Exception : Boolean := False; + end record; + -- Data read from a source info file for a single source + + type Source_Info is access all Source_Info_Data; + No_Source_Info : constant Source_Info := null; + + type Source_Info_Iterator is private; + -- Iterator to get the sources for a single project + + procedure Initialize + (Iter : out Source_Info_Iterator; For_Project : Name_Id); + -- Initiaize Iter for the project + + function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info; + -- Get the source info for the source corresponding to the current value of + -- the iterator. Returns No_Source_Info if there is no source corresponding + -- to the iterator. + + procedure Next (Iter : in out Source_Info_Iterator); + -- Advance the iterator to the next source in the project private type Text_File_Data is record FD : File_Descriptor := Invalid_FD; + Out_File : Boolean := False; Buffer : String (1 .. 1_000); - Buffer_Len : Natural; + Buffer_Len : Natural := 0; Cursor : Natural := 0; End_Of_File_Reached : Boolean := False; end record; type Text_File is access Text_File_Data; + type Source_Info_Iterator is record + Info : Source_Info; + Next : Natural; + end record; + end Prj.Util; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index c353cca..bdd7cce 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -1354,6 +1354,12 @@ package Prj is Source_Paths_HT : Source_Paths_Htable.Instance; -- Full path to Source_Id + Source_Info_File_Name : String_Access := null; + -- The name of the source info file, if specified by the builder + + Source_Info_File_Exists : Boolean := False; + -- True when a source info file has been successfully read + Private_Part : Private_Project_Tree_Data; end record; -- Data for a project tree -- 2.7.4