===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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 (" ");
===================================================================
@@ -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.
===================================================================
@@ -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 Data.Tree.Source_Info_File_Exists then
+ Get_Sources_From_Source_Info;
- 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;
+ 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;
------------------
===================================================================
@@ -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 --
---------------
===================================================================
@@ -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;
===================================================================
@@ -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);
- end if;
+ if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then
+ Get_Name_String (Obj_Dir.Value);
- Conf_Pack_Id := Conf_Pack.Next;
- end loop;
+ 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;
- 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;