===================================================================
@@ -1668,8 +1668,9 @@ begin
elsif Argv'Length > 3
and then Argv (Argv'First + 1 .. Argv'First + 2) = "aP"
then
- Add_Search_Project_Directory
- (Project_Node_Tree, Argv (Argv'First + 3 .. Argv'Last));
+ Prj.Env.Add_Directories
+ (Project_Node_Tree.Project_Path,
+ Argv (Argv'First + 3 .. Argv'Last));
Remove_Switch (Arg_Num);
===================================================================
@@ -76,9 +76,10 @@ package body Prj.Proc is
-- the package or project with declarations Decl.
procedure Check
- (In_Tree : Project_Tree_Ref;
- Project : Project_Id;
- Flags : Processing_Flags);
+ (In_Tree : Project_Tree_Ref;
+ Project : Project_Id;
+ Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
+ Flags : Processing_Flags);
-- Set all projects to not checked, then call Recursive_Check for the
-- main project Project. Project is set to No_Project if errors occurred.
-- Current_Dir is for optimization purposes, avoiding extra system calls.
@@ -270,12 +271,13 @@ package body Prj.Proc is
-----------
procedure Check
- (In_Tree : Project_Tree_Ref;
- Project : Project_Id;
- Flags : Processing_Flags)
+ (In_Tree : Project_Tree_Ref;
+ Project : Project_Id;
+ Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
+ Flags : Processing_Flags)
is
begin
- Process_Naming_Scheme (In_Tree, Project, Flags);
+ Process_Naming_Scheme (In_Tree, Project, Node_Tree, Flags);
-- Set the Other_Part field for the units
@@ -2316,7 +2318,7 @@ package body Prj.Proc is
Success := True;
if Project /= No_Project then
- Check (In_Tree, Project, Flags);
+ Check (In_Tree, Project, From_Project_Node_Tree, Flags);
end if;
-- If main project is an extending all project, set object directory of
===================================================================
@@ -29,8 +29,8 @@ with Osint; use Osint;
with Output; use Output;
with Prj.Com; use Prj.Com;
with Prj.Dect;
+with Prj.Env; use Prj.Env;
with Prj.Err; use Prj.Err;
-with Prj.Ext; use Prj.Ext;
with Sinput; use Sinput;
with Sinput.P; use Sinput.P;
with Snames;
@@ -39,7 +39,6 @@ with Table;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Exceptions; use Ada.Exceptions;
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.HTable; use GNAT.HTable;
package body Prj.Part is
@@ -118,14 +117,6 @@ package body Prj.Part is
-- need to have a virtual extending project, to avoid processing the same
-- project twice.
- package Projects_Paths is new GNAT.HTable.Simple_HTable
- (Header_Num => Header_Num,
- Element => Path_Name_Type,
- No_Element => No_Path,
- Key => Name_Id,
- Hash => Hash,
- Equal => "=");
-
function Has_Circular_Dependencies
(Flags : Processing_Flags;
Normed_Path_Name : Path_Name_Type;
@@ -186,7 +177,7 @@ package body Prj.Part is
(In_Tree : Project_Node_Tree_Ref;
Project : out Project_Node_Id;
Extends_All : out Boolean;
- Path_Name : String;
+ Path_Name_Id : Path_Name_Type;
Extended : Boolean;
From_Extended : Extension_Origin;
In_Limited : Boolean;
@@ -239,13 +230,6 @@ package body Prj.Part is
-- Is_Config_File should be set to True if the project represents a config
-- file (.cgpr) since some specific checks apply.
- function Project_Path_Name_Of
- (In_Tree : Project_Node_Tree_Ref;
- Project_File_Name : String;
- Directory : String) return String;
- -- Returns the path name of a project file. Returns an empty string
- -- if project file cannot be found.
-
function Project_Name_From
(Path_Name : String;
Is_Config_File : Boolean) return Name_Id;
@@ -472,6 +456,7 @@ package body Prj.Part is
Real_Project_File_Name : String_Access :=
Osint.To_Canonical_File_Spec
(Project_File_Name);
+ Path_Name_Id : Path_Name_Type;
begin
if Real_Project_File_Name = null then
@@ -480,153 +465,146 @@ package body Prj.Part is
Project := Empty_Node;
- Projects_Paths.Reset;
-
- if Current_Verbosity >= Medium then
- Write_Str ("GPR_PROJECT_PATH=""");
- Write_Str (Project_Path (In_Tree));
- Write_Line ("""");
- end if;
-
- declare
- Path_Name : constant String :=
- Project_Path_Name_Of (In_Tree,
- Real_Project_File_Name.all,
- Directory => Current_Directory);
-
- begin
- Free (Real_Project_File_Name);
-
- Prj.Err.Initialize;
- Prj.Err.Scanner.Set_Comment_As_Token (Store_Comments);
- Prj.Err.Scanner.Set_End_Of_Line_As_Token (Store_Comments);
+ Find_Project (In_Tree.Project_Path,
+ Project_File_Name => Real_Project_File_Name.all,
+ Directory => Current_Directory,
+ Path => Path_Name_Id);
+ Free (Real_Project_File_Name);
+
+ Prj.Err.Initialize;
+ Prj.Err.Scanner.Set_Comment_As_Token (Store_Comments);
+ Prj.Err.Scanner.Set_End_Of_Line_As_Token (Store_Comments);
- -- Parse the main project file
-
- if Path_Name = "" then
+ if Path_Name_Id = No_Path then
+ declare
+ P : String_Access;
+ begin
+ Get_Path (In_Tree.Project_Path, Path => P);
Prj.Com.Fail
("project file """
& Project_File_Name
& """ not found in "
- & Project_Path (In_Tree));
+ & P.all);
Project := Empty_Node;
return;
- end if;
-
- begin
- Parse_Single_Project
- (In_Tree => In_Tree,
- Project => Project,
- Extends_All => Dummy,
- Path_Name => Path_Name,
- Extended => False,
- From_Extended => None,
- In_Limited => False,
- Packages_To_Check => Packages_To_Check,
- Depth => 0,
- Current_Dir => Current_Directory,
- Is_Config_File => Is_Config_File,
- Flags => Flags);
-
- exception
- when Types.Unrecoverable_Error =>
- -- Unrecoverable_Error is raised when a line is too long.
- -- A meaningful error message will be displayed later.
- Project := Empty_Node;
end;
+ end if;
- -- If Project is an extending-all project, create the eventual
- -- virtual extending projects and check that there are no illegally
- -- imported projects.
+ -- Parse the main project file
- if Present (Project)
- and then Is_Extending_All (Project, In_Tree)
- then
- -- First look for projects that potentially need a virtual
- -- extending project.
+ begin
+ Parse_Single_Project
+ (In_Tree => In_Tree,
+ Project => Project,
+ Extends_All => Dummy,
+ Path_Name_Id => Path_Name_Id,
+ Extended => False,
+ From_Extended => None,
+ In_Limited => False,
+ Packages_To_Check => Packages_To_Check,
+ Depth => 0,
+ Current_Dir => Current_Directory,
+ Is_Config_File => Is_Config_File,
+ Flags => Flags);
- Virtual_Hash.Reset;
- Processed_Hash.Reset;
+ exception
+ when Types.Unrecoverable_Error =>
+ -- Unrecoverable_Error is raised when a line is too long.
+ -- A meaningful error message will be displayed later.
+ Project := Empty_Node;
+ end;
- -- Mark the extending all project as processed, to avoid checking
- -- the imported projects in case of a "limited with" on this
- -- extending all project.
+ -- If Project is an extending-all project, create the eventual
+ -- virtual extending projects and check that there are no illegally
+ -- imported projects.
- Processed_Hash.Set (Project, True);
+ if Present (Project)
+ and then Is_Extending_All (Project, In_Tree)
+ then
+ -- First look for projects that potentially need a virtual
+ -- extending project.
- declare
- Declaration : constant Project_Node_Id :=
- Project_Declaration_Of (Project, In_Tree);
- begin
- Look_For_Virtual_Projects_For
- (Extended_Project_Of (Declaration, In_Tree), In_Tree,
- Potentially_Virtual => False);
- end;
+ Virtual_Hash.Reset;
+ Processed_Hash.Reset;
- -- Now, check the projects directly imported by the main project.
- -- Remove from the potentially virtual any project extended by one
- -- of these imported projects. For non extending imported
- -- projects, check that they do not belong to the project tree of
- -- the project being "extended-all" by the main project.
+ -- Mark the extending all project as processed, to avoid checking
+ -- the imported projects in case of a "limited with" on this
+ -- extending all project.
- declare
- With_Clause : Project_Node_Id;
- Imported : Project_Node_Id := Empty_Node;
- Declaration : Project_Node_Id := Empty_Node;
+ Processed_Hash.Set (Project, True);
- begin
- With_Clause := First_With_Clause_Of (Project, In_Tree);
- while Present (With_Clause) loop
- Imported := Project_Node_Of (With_Clause, In_Tree);
+ declare
+ Declaration : constant Project_Node_Id :=
+ Project_Declaration_Of (Project, In_Tree);
+ begin
+ Look_For_Virtual_Projects_For
+ (Extended_Project_Of (Declaration, In_Tree), In_Tree,
+ Potentially_Virtual => False);
+ end;
- if Present (Imported) then
- Declaration := Project_Declaration_Of (Imported, In_Tree);
+ -- Now, check the projects directly imported by the main project.
+ -- Remove from the potentially virtual any project extended by one
+ -- of these imported projects. For non extending imported
+ -- projects, check that they do not belong to the project tree of
+ -- the project being "extended-all" by the main project.
- if Extended_Project_Of (Declaration, In_Tree) /=
- Empty_Node
- then
- loop
- Imported :=
- Extended_Project_Of (Declaration, In_Tree);
- exit when No (Imported);
- Virtual_Hash.Remove (Imported);
- Declaration :=
- Project_Declaration_Of (Imported, In_Tree);
- end loop;
- end if;
+ declare
+ With_Clause : Project_Node_Id;
+ Imported : Project_Node_Id := Empty_Node;
+ Declaration : Project_Node_Id := Empty_Node;
+
+ begin
+ With_Clause := First_With_Clause_Of (Project, In_Tree);
+ while Present (With_Clause) loop
+ Imported := Project_Node_Of (With_Clause, In_Tree);
+
+ if Present (Imported) then
+ Declaration := Project_Declaration_Of (Imported, In_Tree);
+
+ if Extended_Project_Of (Declaration, In_Tree) /=
+ Empty_Node
+ then
+ loop
+ Imported :=
+ Extended_Project_Of (Declaration, In_Tree);
+ exit when No (Imported);
+ Virtual_Hash.Remove (Imported);
+ Declaration :=
+ Project_Declaration_Of (Imported, In_Tree);
+ end loop;
end if;
+ end if;
- With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
- end loop;
- end;
+ With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
+ end loop;
+ end;
- -- Now create all the virtual extending projects
+ -- Now create all the virtual extending projects
- declare
- Proj : Project_Node_Id := Virtual_Hash.Get_First;
- begin
- while Present (Proj) loop
- Create_Virtual_Extending_Project (Proj, Project, In_Tree);
- Proj := Virtual_Hash.Get_Next;
- end loop;
- end;
- end if;
+ declare
+ Proj : Project_Node_Id := Virtual_Hash.Get_First;
+ begin
+ while Present (Proj) loop
+ Create_Virtual_Extending_Project (Proj, Project, In_Tree);
+ Proj := Virtual_Hash.Get_Next;
+ end loop;
+ end;
+ end if;
- -- If there were any kind of error during the parsing, serious
- -- or not, then the parsing fails.
+ -- If there were any kind of error during the parsing, serious
+ -- or not, then the parsing fails.
- if Err_Vars.Total_Errors_Detected > 0 then
- Project := Empty_Node;
- end if;
+ if Err_Vars.Total_Errors_Detected > 0 then
+ Project := Empty_Node;
+ end if;
- if No (Project) or else Always_Errout_Finalize then
- Prj.Err.Finalize;
+ if No (Project) or else Always_Errout_Finalize then
+ Prj.Err.Finalize;
- -- Reinitialize to avoid duplicate warnings later on
+ -- Reinitialize to avoid duplicate warnings later on
- Prj.Err.Initialize;
- end if;
- end;
+ Prj.Err.Initialize;
+ end if;
exception
when X : others =>
@@ -769,6 +747,7 @@ package body Prj.Part is
Current_With : With_Record;
Extends_All : Boolean := False;
+ Imported_Path_Name_Id : Path_Name_Type;
begin
-- Set Current_Project to the last project in the current list, if the
@@ -787,51 +766,48 @@ package body Prj.Part is
Current_With_Clause := Current_With.Next;
if Limited_Withs = Current_With.Limited_With then
- declare
- Original_Path : constant String :=
- Get_Name_String (Current_With.Path);
+ Find_Project
+ (In_Tree.Project_Path,
+ Project_File_Name => Get_Name_String (Current_With.Path),
+ Directory => Project_Directory_Path,
+ Path => Imported_Path_Name_Id);
- Imported_Path_Name : constant String :=
- Project_Path_Name_Of
- (In_Tree,
- Original_Path,
- Project_Directory_Path);
+ if Imported_Path_Name_Id = No_Path then
- Resolved_Path : constant String :=
- Normalize_Pathname
- (Imported_Path_Name,
- Directory => Current_Dir,
- Resolve_Links =>
- Opt.Follow_Links_For_Files,
- Case_Sensitive => True);
-
- Withed_Project : Project_Node_Id := Empty_Node;
+ -- The project file cannot be found
- begin
- if Imported_Path_Name = "" then
+ Error_Msg_File_1 := File_Name_Type (Current_With.Path);
+ Error_Msg
+ (Flags, "unknown project file: {", Current_With.Location);
- -- The project file cannot be found
+ -- If this is not imported by the main project file, display
+ -- the import path.
- Error_Msg_File_1 := File_Name_Type (Current_With.Path);
- Error_Msg
- (Flags, "unknown project file: {", Current_With.Location);
+ if Project_Stack.Last > 1 then
+ for Index in reverse 1 .. Project_Stack.Last loop
+ Error_Msg_File_1 :=
+ File_Name_Type
+ (Project_Stack.Table (Index).Path_Name);
+ Error_Msg
+ (Flags, "\imported by {", Current_With.Location);
+ end loop;
+ end if;
- -- If this is not imported by the main project file, display
- -- the import path.
+ else
+ -- New with clause
- if Project_Stack.Last > 1 then
- for Index in reverse 1 .. Project_Stack.Last loop
- Error_Msg_File_1 :=
- File_Name_Type
- (Project_Stack.Table (Index).Path_Name);
- Error_Msg
- (Flags, "\imported by {", Current_With.Location);
- end loop;
- end if;
+ declare
+ Resolved_Path : constant String :=
+ Normalize_Pathname
+ (Get_Name_String (Imported_Path_Name_Id),
+ Directory => Current_Dir,
+ Resolve_Links =>
+ Opt.Follow_Links_For_Files,
+ Case_Sensitive => True);
- else
- -- New with clause
+ Withed_Project : Project_Node_Id := Empty_Node;
+ begin
Previous_Project := Current_Project;
if No (Current_Project) then
@@ -890,7 +866,7 @@ package body Prj.Part is
(In_Tree => In_Tree,
Project => Withed_Project,
Extends_All => Extends_All,
- Path_Name => Imported_Path_Name,
+ Path_Name_Id => Imported_Path_Name_Id,
Extended => False,
From_Extended => From_Extended,
In_Limited => Limited_Withs,
@@ -939,8 +915,8 @@ package body Prj.Part is
Set_Is_Extending_All (Current_Project, In_Tree);
end if;
end if;
- end if;
- end;
+ end;
+ end if;
end if;
end loop;
end Post_Parse_Context_Clause;
@@ -1132,7 +1108,7 @@ package body Prj.Part is
(In_Tree : Project_Node_Tree_Ref;
Project : out Project_Node_Id;
Extends_All : out Boolean;
- Path_Name : String;
+ Path_Name_Id : Path_Name_Type;
Extended : Boolean;
From_Extended : Extension_Origin;
In_Limited : Boolean;
@@ -1142,6 +1118,8 @@ package body Prj.Part is
Is_Config_File : Boolean;
Flags : Processing_Flags)
is
+ Path_Name : constant String := Get_Name_String (Path_Name_Id);
+
Normed_Path_Name : Path_Name_Type;
Canonical_Path_Name : Path_Name_Type;
Project_Directory : Path_Name_Type;
@@ -1397,7 +1375,7 @@ package body Prj.Part is
-- Make sure that gnatmake will use mapping files
- Create_Mapping_File := True;
+ Opt.Create_Mapping_File := True;
-- We are extending another project
@@ -1557,16 +1535,15 @@ package body Prj.Part is
declare
Original_Path_Name : constant String :=
Get_Name_String (Token_Name);
-
- Extended_Project_Path_Name : constant String :=
- Project_Path_Name_Of
- (In_Tree,
- Original_Path_Name,
- Get_Name_String
- (Project_Directory));
-
+ Extended_Project_Path_Name_Id : Path_Name_Type;
begin
- if Extended_Project_Path_Name = "" then
+ Find_Project
+ (In_Tree.Project_Path,
+ Project_File_Name => Original_Path_Name,
+ Directory => Get_Name_String (Project_Directory),
+ Path => Extended_Project_Path_Name_Id);
+
+ if Extended_Project_Path_Name_Id = No_Path then
-- We could not find the project file to extend
@@ -1604,7 +1581,7 @@ package body Prj.Part is
(In_Tree => In_Tree,
Project => Extended_Project,
Extends_All => Extends_All,
- Path_Name => Extended_Project_Path_Name,
+ Path_Name_Id => Extended_Project_Path_Name_Id,
Extended => True,
From_Extended => From_Ext,
In_Limited => In_Limited,
@@ -2010,183 +1987,4 @@ package body Prj.Part is
end loop;
end Project_Name_From;
- --------------------------
- -- Project_Path_Name_Of --
- --------------------------
-
- function Project_Path_Name_Of
- (In_Tree : Project_Node_Tree_Ref;
- Project_File_Name : String;
- Directory : String) return String
- is
-
- function Try_Path_Name (Path : String) return String_Access;
- pragma Inline (Try_Path_Name);
- -- Try the specified Path
-
- -------------------
- -- Try_Path_Name --
- -------------------
-
- function Try_Path_Name (Path : String) return String_Access is
- Prj_Path : constant String := Project_Path (In_Tree);
- First : Natural;
- Last : Natural;
- Result : String_Access := null;
-
- begin
- if Current_Verbosity = High then
- Write_Str (" Trying ");
- Write_Line (Path);
- end if;
-
- if Is_Absolute_Path (Path) then
- if Is_Regular_File (Path) then
- Result := new String'(Path);
- end if;
-
- else
- -- Because we don't want to resolve symbolic links, we cannot use
- -- Locate_Regular_File. So, we try each possible path
- -- successively.
-
- First := Prj_Path'First;
- while First <= Prj_Path'Last loop
- while First <= Prj_Path'Last
- and then Prj_Path (First) = Path_Separator
- loop
- First := First + 1;
- end loop;
-
- exit when First > Prj_Path'Last;
-
- Last := First;
- while Last < Prj_Path'Last
- and then Prj_Path (Last + 1) /= Path_Separator
- loop
- Last := Last + 1;
- end loop;
-
- Name_Len := 0;
-
- if not Is_Absolute_Path (Prj_Path (First .. Last)) then
- Add_Str_To_Name_Buffer (Get_Current_Dir);
- Add_Char_To_Name_Buffer (Directory_Separator);
- end if;
-
- Add_Str_To_Name_Buffer (Prj_Path (First .. Last));
- Add_Char_To_Name_Buffer (Directory_Separator);
- Add_Str_To_Name_Buffer (Path);
-
- if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
- Result := new String'(Name_Buffer (1 .. Name_Len));
- exit;
- end if;
-
- First := Last + 1;
- end loop;
- end if;
-
- return Result;
- end Try_Path_Name;
-
- -- Local Declarations
-
- Result : String_Access;
- Result_Id : Path_Name_Type;
- Has_Dot : Boolean := False;
- Key : Name_Id;
-
- -- Start of processing for Project_Path_Name_Of
-
- begin
- if Current_Verbosity = High then
- Write_Str ("Project_Path_Name_Of (""");
- Write_Str (Project_File_Name);
- Write_Str (""", """);
- Write_Str (Directory);
- Write_Line (""");");
- end if;
-
- -- Check the project cache
-
- Name_Len := Project_File_Name'Length;
- Name_Buffer (1 .. Name_Len) := Project_File_Name;
- Key := Name_Find;
- Result_Id := Projects_Paths.Get (Key);
-
- if Result_Id /= No_Path then
- return Get_Name_String (Result_Id);
- end if;
-
- -- Check if Project_File_Name contains an extension (a dot before a
- -- directory separator). If it is the case we do not try project file
- -- with an added extension as it is not possible to have multiple dots
- -- on a project file name.
-
- Check_Dot : for K in reverse Project_File_Name'Range loop
- if Project_File_Name (K) = '.' then
- Has_Dot := True;
- exit Check_Dot;
- end if;
-
- exit Check_Dot when Project_File_Name (K) = Directory_Separator
- or else Project_File_Name (K) = '/';
- end loop Check_Dot;
-
- if not Is_Absolute_Path (Project_File_Name) then
-
- -- First we try <directory>/<file_name>.<extension>
-
- if not Has_Dot then
- Result := Try_Path_Name
- (Directory & Directory_Separator &
- Project_File_Name & Project_File_Extension);
- end if;
-
- -- Then we try <directory>/<file_name>
-
- if Result = null then
- Result := Try_Path_Name
- (Directory & Directory_Separator & Project_File_Name);
- end if;
- end if;
-
- -- Then we try <file_name>.<extension>
-
- if Result = null and then not Has_Dot then
- Result := Try_Path_Name (Project_File_Name & Project_File_Extension);
- end if;
-
- -- Then we try <file_name>
-
- if Result = null then
- Result := Try_Path_Name (Project_File_Name);
- end if;
-
- -- If we cannot find the project file, we return an empty string
-
- if Result = null then
- return "";
-
- else
- declare
- Final_Result : constant String :=
- GNAT.OS_Lib.Normalize_Pathname
- (Result.all,
- Directory => Directory,
- Resolve_Links => Opt.Follow_Links_For_Files,
- Case_Sensitive => True);
- begin
- Free (Result);
- Name_Len := Final_Result'Length;
- Name_Buffer (1 .. Name_Len) := Final_Result;
- Result_Id := Name_Find;
-
- Projects_Paths.Set (Key, Result_Id);
- return Final_Result;
- end;
- end if;
- end Project_Path_Name_Of;
-
end Prj.Part;
===================================================================
@@ -23,26 +23,11 @@
-- --
------------------------------------------------------------------------------
-with Hostparm;
-with Makeutl; use Makeutl;
-with Opt;
with Osint; use Osint;
with Prj.Tree; use Prj.Tree;
-with Sdefault;
package body Prj.Ext is
- No_Project_Default_Dir : constant String := "-";
- -- Indicator in the project path to indicate that the default search
- -- directories should not be added to the path
-
- Uninitialized_Prefix : constant String := '#' & Path_Separator;
- -- Prefix to indicate that the project path has not been initilized yet.
- -- Must be two characters long
-
- procedure Initialize_Project_Path (Tree : Prj.Tree.Project_Node_Tree_Ref);
- -- Initialize Current_Project_Path
-
---------
-- Add --
---------
@@ -65,25 +50,6 @@ package body Prj.Ext is
Name_To_Name_HTable.Set (Tree.External_References, The_Key, The_Value);
end Add;
- ----------------------------------
- -- Add_Search_Project_Directory --
- ----------------------------------
-
- procedure Add_Search_Project_Directory
- (Tree : Prj.Tree.Project_Node_Tree_Ref;
- Path : String)
- is
- Tmp : String_Access;
- begin
- if Tree.Project_Path = null then
- Tree.Project_Path := new String'(Uninitialized_Prefix & Path);
- else
- Tmp := Tree.Project_Path;
- Tree.Project_Path := new String'(Tmp.all & Path_Separator & Path);
- Free (Tmp);
- end if;
- end Add_Search_Project_Directory;
-
-----------
-- Check --
-----------
@@ -109,197 +75,6 @@ package body Prj.Ext is
return False;
end Check;
- -----------------------------
- -- Initialize_Project_Path --
- -----------------------------
-
- procedure Initialize_Project_Path (Tree : Prj.Tree.Project_Node_Tree_Ref) is
- Add_Default_Dir : Boolean := True;
- First : Positive;
- Last : Positive;
- New_Len : Positive;
- New_Last : Positive;
-
- Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
- Gpr_Project_Path : constant String := "GPR_PROJECT_PATH";
- -- Name of alternate env. variable that contain path name(s) of
- -- directories where project files may reside. GPR_PROJECT_PATH has
- -- precedence over ADA_PROJECT_PATH.
-
- Gpr_Prj_Path : String_Access := Getenv (Gpr_Project_Path);
- Ada_Prj_Path : String_Access := Getenv (Ada_Project_Path);
- -- The path name(s) of directories where project files may reside.
- -- May be empty.
-
- begin
- -- The current directory is always first in the search path. Since the
- -- Project_Path currently starts with '#:' as a sign that it isn't
- -- initialized, we simply replace '#' with '.'
-
- if Tree.Project_Path = null then
- Tree.Project_Path := new String'('.' & Path_Separator);
- else
- Tree.Project_Path (Tree.Project_Path'First) := '.';
- end if;
-
- -- Then the reset of the project path (if any) currently contains the
- -- directories added through Add_Search_Project_Directory
-
- -- If environment variables are defined and not empty, add their content
-
- if Gpr_Prj_Path.all /= "" then
- Add_Search_Project_Directory (Tree, Gpr_Prj_Path.all);
- end if;
-
- Free (Gpr_Prj_Path);
-
- if Ada_Prj_Path.all /= "" then
- Add_Search_Project_Directory (Tree, Ada_Prj_Path.all);
- end if;
-
- Free (Ada_Prj_Path);
-
- -- Copy to Name_Buffer, since we will need to manipulate the path
-
- Name_Len := Tree.Project_Path'Length;
- Name_Buffer (1 .. Name_Len) := Tree.Project_Path.all;
-
- -- Scan the directory path to see if "-" is one of the directories.
- -- Remove each occurrence of "-" and set Add_Default_Dir to False.
- -- Also resolve relative paths and symbolic links.
-
- First := 3;
- loop
- while First <= Name_Len
- and then (Name_Buffer (First) = Path_Separator)
- loop
- First := First + 1;
- end loop;
-
- exit when First > Name_Len;
-
- Last := First;
-
- while Last < Name_Len
- and then Name_Buffer (Last + 1) /= Path_Separator
- loop
- Last := Last + 1;
- end loop;
-
- -- If the directory is "-", set Add_Default_Dir to False and
- -- remove from path.
-
- if Name_Buffer (First .. Last) = No_Project_Default_Dir then
- Add_Default_Dir := False;
-
- for J in Last + 1 .. Name_Len loop
- Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
- Name_Buffer (J);
- end loop;
-
- Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
-
- -- After removing the '-', go back one character to get the next
- -- directory correctly.
-
- Last := Last - 1;
-
- elsif not Hostparm.OpenVMS
- or else not Is_Absolute_Path (Name_Buffer (First .. Last))
- then
- -- On VMS, only expand relative path names, as absolute paths
- -- may correspond to multi-valued VMS logical names.
-
- declare
- New_Dir : constant String :=
- Normalize_Pathname
- (Name_Buffer (First .. Last),
- Resolve_Links => Opt.Follow_Links_For_Dirs);
-
- begin
- -- If the absolute path was resolved and is different from
- -- the original, replace original with the resolved path.
-
- if New_Dir /= Name_Buffer (First .. Last)
- and then New_Dir'Length /= 0
- then
- New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
- New_Last := First + New_Dir'Length - 1;
- Name_Buffer (New_Last + 1 .. New_Len) :=
- Name_Buffer (Last + 1 .. Name_Len);
- Name_Buffer (First .. New_Last) := New_Dir;
- Name_Len := New_Len;
- Last := New_Last;
- end if;
- end;
- end if;
-
- First := Last + 1;
- end loop;
-
- Free (Tree.Project_Path);
-
- -- Set the initial value of Current_Project_Path
-
- if Add_Default_Dir then
- declare
- Prefix : String_Ptr := Sdefault.Search_Dir_Prefix;
-
- begin
- if Prefix = null then
- Prefix := new String'(Executable_Prefix_Path);
-
- if Prefix.all /= "" then
- if Tree.Target_Name /= null
- and then Tree.Target_Name.all /= ""
- then
- Add_Str_To_Name_Buffer
- (Path_Separator & Prefix.all &
- "lib" & Directory_Separator & "gpr" &
- Directory_Separator & Tree.Target_Name.all);
- end if;
-
- Add_Str_To_Name_Buffer
- (Path_Separator & Prefix.all &
- "share" & Directory_Separator & "gpr");
- Add_Str_To_Name_Buffer
- (Path_Separator & Prefix.all &
- "lib" & Directory_Separator & "gnat");
- end if;
-
- else
- Tree.Project_Path :=
- new String'(Name_Buffer (1 .. Name_Len) & Path_Separator &
- Prefix.all &
- ".." & Directory_Separator &
- ".." & Directory_Separator &
- ".." & Directory_Separator & "gnat");
- end if;
-
- Free (Prefix);
- end;
- end if;
-
- if Tree.Project_Path = null then
- Tree.Project_Path := new String'(Name_Buffer (1 .. Name_Len));
- end if;
- end Initialize_Project_Path;
-
- ------------------
- -- Project_Path --
- ------------------
-
- function Project_Path (Tree : Project_Node_Tree_Ref) return String is
- begin
- if Tree.Project_Path = null
- or else Tree.Project_Path (Tree.Project_Path'First) = '#'
- then
- Initialize_Project_Path (Tree);
- end if;
-
- return Tree.Project_Path.all;
- end Project_Path;
-
-----------
-- Reset --
-----------
@@ -309,18 +84,6 @@ package body Prj.Ext is
Name_To_Name_HTable.Reset (Tree.External_References);
end Reset;
- ----------------------
- -- Set_Project_Path --
- ----------------------
-
- procedure Set_Project_Path
- (Tree : Project_Node_Tree_Ref;
- New_Path : String) is
- begin
- Free (Tree.Project_Path);
- Tree.Project_Path := new String'(New_Path);
- end Set_Project_Path;
-
--------------
-- Value_Of --
--------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 2000-2010, 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- --
@@ -30,34 +30,6 @@ with Prj.Tree;
package Prj.Ext is
- ------------------
- -- Project Path --
- ------------------
-
- procedure Add_Search_Project_Directory
- (Tree : Prj.Tree.Project_Node_Tree_Ref;
- Path : String);
- -- Add a directory to the project path. Directories added with this
- -- procedure are added in order after the current directory and before
- -- the path given by the environment variable GPR_PROJECT_PATH. A value
- -- of "-" will remove the default project directory from the project path.
- --
- -- Calls to this subprogram must be performed before the first call to
- -- Project_Path below, or PATH will be added at the end of the search
- -- path.
-
- function Project_Path (Tree : Prj.Tree.Project_Node_Tree_Ref) return String;
- -- Return the current value of the project path, either the value set
- -- during elaboration of the package or, if procedure Set_Project_Path has
- -- been called, the value set by the last call to Set_Project_Path.
-
- procedure Set_Project_Path
- (Tree : Prj.Tree.Project_Node_Tree_Ref;
- New_Path : String);
- -- Give a new value to the project path. The new value New_Path should
- -- always start with the current directory (".") and the path separators
- -- should be the correct ones for the platform.
-
-------------------------
-- External References --
-------------------------
===================================================================
@@ -28,7 +28,7 @@ with Makeutl; use Makeutl;
with Osint; use Osint;
with Opt; use Opt;
with Prj; use Prj;
-with Prj.Ext; use Prj.Ext;
+with Prj.Env; use Prj.Env;
with Table;
package body Switch.M is
@@ -664,8 +664,8 @@ package body Switch.M is
elsif Switch_Chars'Length > 3
and then Switch_Chars (Ptr .. Ptr + 1) = "aP"
then
- Add_Search_Project_Directory
- (Project_Node_Tree,
+ Add_Directories
+ (Project_Node_Tree.Project_Path,
Switch_Chars (Ptr + 2 .. Switch_Chars'Last));
elsif C = 'v' and then Switch_Chars'Length = 3 then
@@ -813,7 +813,7 @@ package body Switch.M is
-- Processing for C switch
when 'C' =>
- Create_Mapping_File := True;
+ Opt.Create_Mapping_File := True;
-- Processing for D switch
===================================================================
@@ -1692,8 +1692,9 @@ package body Clean is
Add_Lib_Search_Dir (Arg (4 .. Arg'Last));
elsif Arg (3) = 'P' then
- Prj.Ext.Add_Search_Project_Directory
- (Project_Node_Tree, Arg (4 .. Arg'Last));
+ Prj.Env.Add_Directories
+ (Project_Node_Tree.Project_Path,
+ Arg (4 .. Arg'Last));
else
Bad_Argument;
===================================================================
@@ -149,6 +149,7 @@ package body Prj.Nmsc is
type Tree_Processing_Data is record
Tree : Project_Tree_Ref;
+ Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
File_To_Source : Files_Htable.Instance;
Flags : Prj.Processing_Flags;
end record;
@@ -173,9 +174,10 @@ package body Prj.Nmsc is
-- projects do not have the same library names.
procedure Initialize
- (Data : out Tree_Processing_Data;
- Tree : Project_Tree_Ref;
- Flags : Prj.Processing_Flags);
+ (Data : out Tree_Processing_Data;
+ Tree : Project_Tree_Ref;
+ Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
+ Flags : Prj.Processing_Flags);
-- Initialize Data
procedure Free (Data : in out Tree_Processing_Data);
@@ -6574,14 +6576,16 @@ package body Prj.Nmsc is
----------------
procedure Initialize
- (Data : out Tree_Processing_Data;
- Tree : Project_Tree_Ref;
- Flags : Prj.Processing_Flags)
+ (Data : out Tree_Processing_Data;
+ Tree : Project_Tree_Ref;
+ Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
+ Flags : Prj.Processing_Flags)
is
begin
Files_Htable.Reset (Data.File_To_Source);
- Data.Tree := Tree;
- Data.Flags := Flags;
+ Data.Tree := Tree;
+ Data.Node_Tree := Node_Tree;
+ Data.Flags := Flags;
end Initialize;
----------
@@ -7611,6 +7615,7 @@ package body Prj.Nmsc is
procedure Process_Naming_Scheme
(Tree : Project_Tree_Ref;
Root_Project : Project_Id;
+ Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
Flags : Processing_Flags)
is
procedure Recursive_Check
@@ -7644,7 +7649,7 @@ package body Prj.Nmsc is
-- Start of processing for Process_Naming_Scheme
begin
Lib_Data_Table.Init;
- Initialize (Data, Tree => Tree, Flags => Flags);
+ Initialize (Data, Tree => Tree, Node_Tree => Node_Tree, Flags => Flags);
Check_All_Projects (Root_Project, Data, Imported_First => True);
Free (Data);
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 2000-2010, 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- --
@@ -25,11 +25,14 @@
-- Find source dirs and source files for a project
+with Prj.Tree;
+
private package Prj.Nmsc is
procedure Process_Naming_Scheme
(Tree : Project_Tree_Ref;
Root_Project : Project_Id;
+ Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
Flags : Processing_Flags);
-- Perform consistency and semantic checks on all the projects in the tree.
-- This procedure interprets the various case statements in the project
===================================================================
@@ -24,10 +24,14 @@
------------------------------------------------------------------------------
with Fmap;
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with Hostparm;
+with Makeutl; use Makeutl;
with Opt;
-with Osint; use Osint;
-with Output; use Output;
-with Prj.Com; use Prj.Com;
+with Osint; use Osint;
+with Output; use Output;
+with Prj.Com; use Prj.Com;
+with Sdefault;
with Tempdir;
package body Prj.Env is
@@ -35,6 +39,14 @@ package body Prj.Env is
Buffer_Initial : constant := 1_000;
-- Initial size of Buffer
+ Uninitialized_Prefix : constant String := '#' & Path_Separator;
+ -- Prefix to indicate that the project path has not been initilized yet.
+ -- Must be two characters long
+
+ No_Project_Default_Dir : constant String := "-";
+ -- Indicator in the project path to indicate that the default search
+ -- directories should not be added to the path
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -97,6 +109,11 @@ package body Prj.Env is
-- Return a project that is either Project or an extended ancestor of
-- Project that itself is not extended.
+ procedure Initialize_Project_Path
+ (Self : in out Project_Search_Path; Target_Name : String);
+ -- Initialize Current_Project_Path.
+ -- Does nothing if the path has already been initialized properly
+
----------------------
-- Ada_Include_Path --
----------------------
@@ -1739,4 +1756,435 @@ package body Prj.Env is
return Result;
end Ultimate_Extension_Of;
+ ---------------------
+ -- Add_Directories --
+ ---------------------
+
+ procedure Add_Directories
+ (Self : in out Project_Search_Path;
+ Path : String)
+ is
+ Tmp : String_Access;
+ begin
+ if Self.Path = null then
+ Self.Path := new String'(Uninitialized_Prefix & Path);
+ else
+ Tmp := Self.Path;
+ Self.Path := new String'(Tmp.all & Path_Separator & Path);
+ Free (Tmp);
+ end if;
+ end Add_Directories;
+
+ -----------------------------
+ -- Initialize_Project_Path --
+ -----------------------------
+
+ procedure Initialize_Project_Path
+ (Self : in out Project_Search_Path; Target_Name : String)
+ is
+ Add_Default_Dir : Boolean := True;
+ First : Positive;
+ Last : Positive;
+ New_Len : Positive;
+ New_Last : Positive;
+
+ Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
+ Gpr_Project_Path : constant String := "GPR_PROJECT_PATH";
+ -- Name of alternate env. variable that contain path name(s) of
+ -- directories where project files may reside. GPR_PROJECT_PATH has
+ -- precedence over ADA_PROJECT_PATH.
+
+ Gpr_Prj_Path : String_Access;
+ Ada_Prj_Path : String_Access;
+ -- The path name(s) of directories where project files may reside.
+ -- May be empty.
+
+ begin
+ -- If already initialized, nothing else to do
+ if Self.Path /= null
+ and then Self.Path (Self.Path'First) /= '#'
+ then
+ return;
+ end if;
+
+ -- The current directory is always first in the search path. Since the
+ -- Project_Path currently starts with '#:' as a sign that it isn't
+ -- initialized, we simply replace '#' with '.'
+
+ if Self.Path = null then
+ Self.Path := new String'('.' & Path_Separator);
+ else
+ Self.Path (Self.Path'First) := '.';
+ end if;
+
+ -- Then the reset of the project path (if any) currently contains the
+ -- directories added through Add_Search_Project_Directory
+
+ -- If environment variables are defined and not empty, add their content
+
+ Gpr_Prj_Path := Getenv (Gpr_Project_Path);
+ Ada_Prj_Path := Getenv (Ada_Project_Path);
+
+ if Gpr_Prj_Path.all /= "" then
+ Add_Directories (Self, Gpr_Prj_Path.all);
+ end if;
+
+ Free (Gpr_Prj_Path);
+
+ if Ada_Prj_Path.all /= "" then
+ Add_Directories (Self, Ada_Prj_Path.all);
+ end if;
+
+ Free (Ada_Prj_Path);
+
+ -- Copy to Name_Buffer, since we will need to manipulate the path
+
+ Name_Len := Self.Path'Length;
+ Name_Buffer (1 .. Name_Len) := Self.Path.all;
+
+ -- Scan the directory path to see if "-" is one of the directories.
+ -- Remove each occurrence of "-" and set Add_Default_Dir to False.
+ -- Also resolve relative paths and symbolic links.
+
+ First := 3;
+ loop
+ while First <= Name_Len
+ and then (Name_Buffer (First) = Path_Separator)
+ loop
+ First := First + 1;
+ end loop;
+
+ exit when First > Name_Len;
+
+ Last := First;
+
+ while Last < Name_Len
+ and then Name_Buffer (Last + 1) /= Path_Separator
+ loop
+ Last := Last + 1;
+ end loop;
+
+ -- If the directory is "-", set Add_Default_Dir to False and
+ -- remove from path.
+
+ if Name_Buffer (First .. Last) = No_Project_Default_Dir then
+ Add_Default_Dir := False;
+
+ for J in Last + 1 .. Name_Len loop
+ Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
+ Name_Buffer (J);
+ end loop;
+
+ Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
+
+ -- After removing the '-', go back one character to get the next
+ -- directory correctly.
+
+ Last := Last - 1;
+
+ elsif not Hostparm.OpenVMS
+ or else not Is_Absolute_Path (Name_Buffer (First .. Last))
+ then
+ -- On VMS, only expand relative path names, as absolute paths
+ -- may correspond to multi-valued VMS logical names.
+
+ declare
+ New_Dir : constant String :=
+ Normalize_Pathname
+ (Name_Buffer (First .. Last),
+ Resolve_Links => Opt.Follow_Links_For_Dirs);
+
+ begin
+ -- If the absolute path was resolved and is different from
+ -- the original, replace original with the resolved path.
+
+ if New_Dir /= Name_Buffer (First .. Last)
+ and then New_Dir'Length /= 0
+ then
+ New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
+ New_Last := First + New_Dir'Length - 1;
+ Name_Buffer (New_Last + 1 .. New_Len) :=
+ Name_Buffer (Last + 1 .. Name_Len);
+ Name_Buffer (First .. New_Last) := New_Dir;
+ Name_Len := New_Len;
+ Last := New_Last;
+ end if;
+ end;
+ end if;
+
+ First := Last + 1;
+ end loop;
+
+ Free (Self.Path);
+
+ -- Set the initial value of Current_Project_Path
+
+ if Add_Default_Dir then
+ declare
+ Prefix : String_Ptr := Sdefault.Search_Dir_Prefix;
+
+ begin
+ if Prefix = null then
+ Prefix := new String'(Executable_Prefix_Path);
+
+ if Prefix.all /= "" then
+ if Target_Name /= "" then
+ Add_Str_To_Name_Buffer
+ (Path_Separator & Prefix.all &
+ "lib" & Directory_Separator & "gpr" &
+ Directory_Separator & Target_Name);
+ end if;
+
+ Add_Str_To_Name_Buffer
+ (Path_Separator & Prefix.all &
+ "share" & Directory_Separator & "gpr");
+ Add_Str_To_Name_Buffer
+ (Path_Separator & Prefix.all &
+ "lib" & Directory_Separator & "gnat");
+ end if;
+
+ else
+ Self.Path :=
+ new String'(Name_Buffer (1 .. Name_Len) & Path_Separator &
+ Prefix.all &
+ ".." & Directory_Separator &
+ ".." & Directory_Separator &
+ ".." & Directory_Separator & "gnat");
+ end if;
+
+ Free (Prefix);
+ end;
+ end if;
+
+ if Self.Path = null then
+ Self.Path := new String'(Name_Buffer (1 .. Name_Len));
+ end if;
+ end Initialize_Project_Path;
+
+ --------------
+ -- Get_Path --
+ --------------
+
+ procedure Get_Path
+ (Self : in out Project_Search_Path;
+ Path : out String_Access)
+ is
+ begin
+ Initialize_Project_Path (Self, ""); -- ??? Target_Name unspecified
+ Path := Self.Path;
+ end Get_Path;
+
+ ---------------
+ -- Deep_Copy --
+ ---------------
+
+ function Deep_Copy
+ (Self : Project_Search_Path) return Project_Search_Path is
+ begin
+ if Self.Path = null then
+ return Project_Search_Path'
+ (Path => null, Cache => Projects_Paths.Nil);
+ else
+ return Project_Search_Path'
+ (Path => new String'(Self.Path.all),
+ Cache => Projects_Paths.Nil);
+ end if;
+ end Deep_Copy;
+
+ ------------------
+ -- Find_Project --
+ ------------------
+
+ procedure Find_Project
+ (Self : in out Project_Search_Path;
+ Project_File_Name : String;
+ Directory : String;
+ Path : out Namet.Path_Name_Type)
+ is
+ File : constant String := Project_File_Name;
+ -- Have to do a copy, in case the parameter is Name_Buffer, which we
+ -- modify below
+
+ function Try_Path_Name (Path : String) return String_Access;
+ pragma Inline (Try_Path_Name);
+ -- Try the specified Path
+
+ -------------------
+ -- Try_Path_Name --
+ -------------------
+
+ function Try_Path_Name (Path : String) return String_Access is
+ First : Natural;
+ Last : Natural;
+ Result : String_Access := null;
+
+ begin
+ if Current_Verbosity = High then
+ Write_Str (" Trying ");
+ Write_Line (Path);
+ end if;
+
+ if Is_Absolute_Path (Path) then
+ if Is_Regular_File (Path) then
+ Result := new String'(Path);
+ end if;
+
+ else
+ -- Because we don't want to resolve symbolic links, we cannot use
+ -- Locate_Regular_File. So, we try each possible path
+ -- successively.
+
+ First := Self.Path'First;
+ while First <= Self.Path'Last loop
+ while First <= Self.Path'Last
+ and then Self.Path (First) = Path_Separator
+ loop
+ First := First + 1;
+ end loop;
+
+ exit when First > Self.Path'Last;
+
+ Last := First;
+ while Last < Self.Path'Last
+ and then Self.Path (Last + 1) /= Path_Separator
+ loop
+ Last := Last + 1;
+ end loop;
+
+ Name_Len := 0;
+
+ if not Is_Absolute_Path (Self.Path (First .. Last)) then
+ Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call
+ Add_Char_To_Name_Buffer (Directory_Separator);
+ end if;
+
+ Add_Str_To_Name_Buffer (Self.Path (First .. Last));
+ Add_Char_To_Name_Buffer (Directory_Separator);
+ Add_Str_To_Name_Buffer (Path);
+
+ if Current_Verbosity = High then
+ Write_Str (" Testing file ");
+ Write_Line (Name_Buffer (1 .. Name_Len));
+ end if;
+
+ if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
+ Result := new String'(Name_Buffer (1 .. Name_Len));
+ exit;
+ end if;
+
+ First := Last + 1;
+ end loop;
+ end if;
+
+ return Result;
+ end Try_Path_Name;
+
+ -- Local Declarations
+
+ Result : String_Access;
+ Has_Dot : Boolean := False;
+ Key : Name_Id;
+
+ -- Start of processing for Project_Path_Name_Of
+
+ begin
+ Initialize_Project_Path (Self, "");
+
+ if Current_Verbosity = High then
+ Write_Str ("Searching for project (""");
+ Write_Str (File);
+ Write_Str (""", """);
+ Write_Str (Directory);
+ Write_Line (""");");
+ end if;
+
+ -- Check the project cache
+
+ Name_Len := File'Length;
+ Name_Buffer (1 .. Name_Len) := File;
+ Key := Name_Find;
+ Path := Projects_Paths.Get (Self.Cache, Key);
+
+ if Path /= No_Path then
+ return;
+ end if;
+
+ -- Check if File contains an extension (a dot before a
+ -- directory separator). If it is the case we do not try project file
+ -- with an added extension as it is not possible to have multiple dots
+ -- on a project file name.
+
+ Check_Dot : for K in reverse File'Range loop
+ if File (K) = '.' then
+ Has_Dot := True;
+ exit Check_Dot;
+ end if;
+
+ exit Check_Dot when File (K) = Directory_Separator
+ or else File (K) = '/';
+ end loop Check_Dot;
+
+ if not Is_Absolute_Path (File) then
+
+ -- First we try <directory>/<file_name>.<extension>
+
+ if not Has_Dot then
+ Result := Try_Path_Name
+ (Directory & Directory_Separator &
+ File & Project_File_Extension);
+ end if;
+
+ -- Then we try <directory>/<file_name>
+
+ if Result = null then
+ Result := Try_Path_Name (Directory & Directory_Separator & File);
+ end if;
+ end if;
+
+ -- Then we try <file_name>.<extension>
+
+ if Result = null and then not Has_Dot then
+ Result := Try_Path_Name (File & Project_File_Extension);
+ end if;
+
+ -- Then we try <file_name>
+
+ if Result = null then
+ Result := Try_Path_Name (File);
+ end if;
+
+ -- If we cannot find the project file, we return an empty string
+
+ if Result = null then
+ Path := Namet.No_Path;
+ return;
+
+ else
+ declare
+ Final_Result : constant String :=
+ GNAT.OS_Lib.Normalize_Pathname
+ (Result.all,
+ Directory => Directory,
+ Resolve_Links => Opt.Follow_Links_For_Files,
+ Case_Sensitive => True);
+ begin
+ Free (Result);
+ Name_Len := Final_Result'Length;
+ Name_Buffer (1 .. Name_Len) := Final_Result;
+ Path := Name_Find;
+ Projects_Paths.Set (Self.Cache, Key, Path);
+ end;
+ end if;
+ end Find_Project;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (Self : in out Project_Search_Path) is
+ begin
+ Free (Self.Path);
+ Projects_Paths.Reset (Self.Cache);
+ end Free;
+
end Prj.Env;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 2001-2010, 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- --
@@ -26,6 +26,9 @@
-- This package implements services for Project-aware tools, mostly related
-- to the environment (configuration pragma files, path files, mapping files).
+with GNAT.Dynamic_HTables;
+with System.OS_Lib;
+
package Prj.Env is
procedure Initialize (In_Tree : Project_Tree_Ref);
@@ -152,4 +155,72 @@ package Prj.Env is
-- Iterate through all the object directories of a project, including
-- those of imported or modified projects.
+ ------------------
+ -- Project Path --
+ ------------------
+
+ type Project_Search_Path is private;
+ -- An abstraction of the project path. This object provides subprograms to
+ -- search for projects on the path (and caches the results for more
+ -- efficiency).
+
+ procedure Free (Self : in out Project_Search_Path);
+ -- Free the memory used by Self
+
+ procedure Add_Directories
+ (Self : in out Project_Search_Path;
+ Path : String);
+ -- Add one or more directories to the path.
+ -- Directories added with this procedure are added in order after the
+ -- current directory and before the path given by the environment variable
+ -- GPR_PROJECT_PATH. A value of "-" will remove the default project
+ -- directory from the project path.
+ --
+ -- Calls to this subprogram must be performed before the first call to
+ -- Find_Project below, or PATH will be added at the end of the search
+ -- path.
+
+ procedure Get_Path
+ (Self : in out Project_Search_Path;
+ Path : out String_Access);
+ -- Return the current value of the project path, either the value set
+ -- during elaboration of the package or, if procedure Set_Project_Path has
+ -- been called, the value set by the last call to Set_Project_Path.
+ -- The returned value must not be modified.
+
+ procedure Find_Project
+ (Self : in out Project_Search_Path;
+ Project_File_Name : String;
+ Directory : String;
+ Path : out Namet.Path_Name_Type);
+ -- Search for a the project with the given name either in Directory (which
+ -- often will be the directory contain the project we are currently
+ -- parsing and which we found a reference to another project), or in the
+ -- project path. Extra_Project_Path contains additional directories to
+ -- search.
+ -- Project_File_Name can optionally contain directories, and the extension
+ -- (.gpr) for the file name is optional.
+ -- Returns No_Name if no such project was found.
+
+ function Deep_Copy (Self : Project_Search_Path) return Project_Search_Path;
+ -- Return a deep copy of Self. The result can be modified independently of
+ -- Self, and must be freed by the caller
+
+private
+ package Projects_Paths is new GNAT.Dynamic_HTables.Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Path_Name_Type,
+ No_Element => No_Path,
+ Key => Name_Id,
+ Hash => Hash,
+ Equal => "=");
+
+ type Project_Search_Path is record
+ Path : System.OS_Lib.String_Access;
+ -- As a special case, if the first character is '#:" or this variable is
+ -- unset, this means that the PATH has not been fully initialized yet
+ -- (although subprograms above will properly take care of that).
+
+ Cache : Projects_Paths.Instance;
+ end record;
end Prj.Env;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 2001-2010, 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- --
@@ -24,6 +24,7 @@
------------------------------------------------------------------------------
with Osint; use Osint;
+with Prj.Env; use Prj.Env;
with Prj.Err;
with Ada.Unchecked_Deallocation;
===================================================================
@@ -31,6 +31,7 @@ with GNAT.Dynamic_Tables;
with Table;
with Prj.Attr; use Prj.Attr;
+with Prj.Env;
package Prj.Tree is
@@ -1474,12 +1475,7 @@ package Prj.Tree is
-- The target name, if any, specified with the gprbuild or gprclean
-- switch --target=.
- Project_Path : String_Access := null;
- -- The project path, manipulated through subprograms in prj-ext.ads.
- -- As a special case, if the first character is '#:" or this variable is
- -- unset, this means that the PATH has not been fully initialized yet
- -- (although subprograms prj-ext.ads will properly take care of that).
- --
+ Project_Path : Prj.Env.Project_Search_Path;
-- The project path is tree specific, since we might want to load
-- simultaneously multiple projects, each with its own search path, in
-- particular when using different compilers with different default