-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2012, 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- --
-- Initial size of Buffer
Uninitialized_Prefix : constant String := '#' & Path_Separator;
- -- Prefix to indicate that the project path has not been initilized yet.
+ -- Prefix to indicate that the project path has not been initialized yet.
-- Must be two characters long
No_Project_Default_Dir : constant String := "-";
procedure Add_To_Path
(Source_Dirs : String_List_Id;
- In_Tree : Project_Tree_Ref;
+ Shared : Shared_Project_Tree_Data_Access;
Buffer : in out String_Access;
Buffer_Last : in out Natural);
-- Add to Ada_Path_Buffer all the source directories in string list
procedure Add_To_Source_Path
(Source_Dirs : String_List_Id;
- In_Tree : Project_Tree_Ref;
+ Shared : Shared_Project_Tree_Data_Access;
Source_Paths : in out Source_Path_Table.Instance);
-- Add to Ada_Path_B all the source directories in string list
-- Source_Dirs, if any. Increment Ada_Path_Length.
-- Add Object_Dir to object path table. Make sure it is not duplicate
-- and it is the last one in the current table.
- procedure Set_Path_File_Var (Name : String; Value : String);
- -- Call Setenv, after calling To_Host_File_Spec
-
- function Ultimate_Extension_Of
- (Project : Project_Id) return Project_Id;
- -- 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 --
----------------------
Buffer : String_Access;
Buffer_Last : Natural := 0;
- procedure Add (Project : Project_Id; Dummy : in out Boolean);
+ procedure Add
+ (Project : Project_Id;
+ In_Tree : Project_Tree_Ref;
+ Dummy : in out Boolean);
-- Add source dirs of Project to the path
---------
-- Add --
---------
- procedure Add (Project : Project_Id; Dummy : in out Boolean) is
+ procedure Add
+ (Project : Project_Id;
+ In_Tree : Project_Tree_Ref;
+ Dummy : in out Boolean)
+ is
pragma Unreferenced (Dummy);
begin
- Add_To_Path (Project.Source_Dirs, In_Tree, Buffer, Buffer_Last);
+ Add_To_Path
+ (Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last);
end Add;
procedure For_All_Projects is
if Project.Ada_Include_Path = null then
Buffer := new String (1 .. 4096);
- For_All_Projects (Project, Dummy);
+ For_All_Projects
+ (Project, In_Tree, Dummy, Include_Aggregated => True);
Project.Ada_Include_Path := new String'(Buffer (1 .. Buffer_Last));
Free (Buffer);
end if;
else
Buffer := new String (1 .. 4096);
- Add_To_Path (Project.Source_Dirs, In_Tree, Buffer, Buffer_Last);
+ Add_To_Path
+ (Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last);
declare
Result : constant String := Buffer (1 .. Buffer_Last);
function Ada_Objects_Path
(Project : Project_Id;
+ In_Tree : Project_Tree_Ref;
Including_Libraries : Boolean := True) return String_Access
is
Buffer : String_Access;
Buffer_Last : Natural := 0;
- procedure Add (Project : Project_Id; Dummy : in out Boolean);
+ procedure Add
+ (Project : Project_Id;
+ In_Tree : Project_Tree_Ref;
+ Dummy : in out Boolean);
-- Add all the object directories of a project to the path
---------
-- Add --
---------
- procedure Add (Project : Project_Id; Dummy : in out Boolean) is
- pragma Unreferenced (Dummy);
+ procedure Add
+ (Project : Project_Id;
+ In_Tree : Project_Tree_Ref;
+ Dummy : in out Boolean)
+ is
+ pragma Unreferenced (Dummy, In_Tree);
+
Path : constant Path_Name_Type :=
Get_Object_Directory
(Project,
if Project.Ada_Objects_Path = null then
Buffer := new String (1 .. 4096);
- For_All_Projects (Project, Dummy);
+ For_All_Projects (Project, In_Tree, Dummy);
Project.Ada_Objects_Path := new String'(Buffer (1 .. Buffer_Last));
Free (Buffer);
begin
-- Check if the directory is already in the table
- for Index in Object_Path_Table.First ..
- Object_Path_Table.Last (Object_Paths)
+ for Index in
+ Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths)
loop
-- If it is, remove it, and add it as the last one
if Object_Paths.Table (Index) = Object_Dir then
- for Index2 in Index + 1 ..
- Object_Path_Table.Last (Object_Paths)
+ for Index2 in
+ Index + 1 .. Object_Path_Table.Last (Object_Paths)
loop
Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2);
end loop;
procedure Add_To_Path
(Source_Dirs : String_List_Id;
- In_Tree : Project_Tree_Ref;
+ Shared : Shared_Project_Tree_Data_Access;
Buffer : in out String_Access;
Buffer_Last : in out Natural)
is
Source_Dir : String_Element;
begin
while Current /= Nil_String loop
- Source_Dir := In_Tree.String_Elements.Table (Current);
+ Source_Dir := Shared.String_Elements.Table (Current);
Add_To_Path (Get_Name_String (Source_Dir.Display_Value),
Buffer, Buffer_Last);
Current := Source_Dir.Next;
procedure Add_To_Source_Path
(Source_Dirs : String_List_Id;
- In_Tree : Project_Tree_Ref;
+ Shared : Shared_Project_Tree_Data_Access;
Source_Paths : in out Source_Path_Table.Instance)
is
Current : String_List_Id := Source_Dirs;
-- Add each source directory
while Current /= Nil_String loop
- Source_Dir := In_Tree.String_Elements.Table (Current);
+ Source_Dir := Shared.String_Elements.Table (Current);
Add_It := True;
-- Check if the source directory is already in the table
- for Index in Source_Path_Table.First ..
- Source_Path_Table.Last (Source_Paths)
+ for Index in
+ Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths)
loop
-- If it is already, no need to add it
Table_Low_Bound => 1,
Table_Initial => 5,
Table_Increment => 100);
+
Default_Naming : constant Naming_Id := Naming_Table.First;
Namings : Naming_Table.Instance;
-- Table storing the naming data for gnatmake/gprmake
File_Name : Path_Name_Type := No_Path;
File : File_Descriptor := Invalid_FD;
- Current_Naming : Naming_Id;
- Iter : Source_Iterator;
- Source : Source_Id;
+ Current_Naming : Naming_Id;
- procedure Check (Project : Project_Id; State : in out Integer);
+ procedure Check
+ (Project : Project_Id;
+ In_Tree : Project_Tree_Ref;
+ State : in out Integer);
-- Recursive procedure that put in the config pragmas file any non
-- standard naming schemes, if it is not already in the file, then call
-- itself for any imported project.
procedure Put (S : String);
procedure Put_Line (S : String);
-- Output procedures, analogous to normal Text_IO procs of same name.
- -- The text is put in Buffer, then it will be writen into a temporary
+ -- The text is put in Buffer, then it will be written into a temporary
-- file with procedure Write_Temp_File below.
procedure Write_Temp_File;
-- Check --
-----------
- procedure Check (Project : Project_Id; State : in out Integer) is
+ procedure Check
+ (Project : Project_Id;
+ In_Tree : Project_Tree_Ref;
+ State : in out Integer)
+ is
pragma Unreferenced (State);
+
Lang : constant Language_Ptr :=
Get_Language_From_Name (Project, "ada");
Naming : Lang_Naming_Data;
+ Iter : Source_Iterator;
+ Source : Source_Id;
begin
if Current_Verbosity = High then
- Write_Str ("Checking project file """);
- Write_Str (Namet.Get_Name_String (Project.Name));
- Write_Str (""".");
- Write_Eol;
+ Debug_Output ("Checking project file:", Project.Name);
end if;
if Lang = null then
if Current_Verbosity = High then
- Write_Line (" Languages does not contain Ada, nothing to do");
+ Debug_Output ("Languages does not contain Ada, nothing to do");
end if;
return;
end if;
+ -- Visit all the files and process those that need an SFN pragma
+
+ Iter := For_Each_Source (In_Tree, Project);
+ while Element (Iter) /= No_Source loop
+ Source := Element (Iter);
+
+ if not Source.Locally_Removed
+ and then Source.Unit /= null
+ and then
+ (Source.Index >= 1 or else Source.Naming_Exception /= No)
+ then
+ Put (Source);
+ end if;
+
+ Next (Iter);
+ end loop;
+
Naming := Lang.Config.Naming_Data;
-- Is the naming scheme of this project one that we know?
-- Check the naming schemes
- Check_Imported_Projects (For_Project, Dummy, Imported_First => False);
-
- -- Visit all the files and process those that need an SFN pragma
-
- Iter := For_Each_Source (In_Tree, For_Project);
- while Element (Iter) /= No_Source loop
- Source := Element (Iter);
-
- if Source.Index >= 1
- and then not Source.Locally_Removed
- and then Source.Unit /= null
- then
- Put (Source);
- end if;
-
- Next (Iter);
- end loop;
+ Check_Imported_Projects
+ (For_Project, In_Tree, Dummy, Imported_First => False);
-- If there are no non standard naming scheme, issue the GNAT
-- standard naming scheme. This will tell the compiler that
In_Tree : Project_Tree_Ref;
Name : out Path_Name_Type)
is
- File : File_Descriptor := Invalid_FD;
-
- Buffer : String_Access := new String (1 .. Buffer_Initial);
- Buffer_Last : Natural := 0;
+ File : File_Descriptor := Invalid_FD;
+ Buffer : String_Access := new String (1 .. Buffer_Initial);
+ Buffer_Last : Natural := 0;
procedure Put_Name_Buffer;
-- Put the line contained in the Name_Buffer in the global buffer
- procedure Process (Project : Project_Id; State : in out Integer);
+ procedure Process
+ (Project : Project_Id;
+ In_Tree : Project_Tree_Ref;
+ State : in out Integer);
-- Generate the mapping file for Project (not recursively)
---------------------
procedure Put_Name_Buffer is
begin
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := ASCII.LF;
-
if Current_Verbosity = High then
- Write_Str ("Mapping file: " & Name_Buffer (1 .. Name_Len));
+ Debug_Output (Name_Buffer (1 .. Name_Len));
end if;
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := ASCII.LF;
Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
end Put_Name_Buffer;
-- Process --
-------------
- procedure Process (Project : Project_Id; State : in out Integer) is
+ procedure Process
+ (Project : Project_Id;
+ In_Tree : Project_Tree_Ref;
+ State : in out Integer)
+ is
pragma Unreferenced (State);
+
Source : Source_Id;
Suffix : File_Name_Type;
Iter : Source_Iterator;
begin
+ Debug_Output ("Add mapping for project", Project.Name);
Iter := For_Each_Source (In_Tree, Project, Language => Language);
loop
if Source.Replaced_By = No_Source
and then Source.Path.Name /= No_Path
- and then
- (Source.Language.Config.Kind = File_Based
- or else Source.Unit /= No_Unit_Index)
+ and then (Source.Language.Config.Kind = File_Based
+ or else Source.Unit /= No_Unit_Index)
then
if Source.Unit /= No_Unit_Index then
- Get_Name_String (Source.Unit.Name);
+
+ -- Put the encoded unit name in the name buffer
+
+ declare
+ Uname : constant String :=
+ Get_Name_String (Source.Unit.Name);
+
+ begin
+ Name_Len := 0;
+ for J in Uname'Range loop
+ if Uname (J) in Upper_Half_Character then
+ Store_Encoded_Character (Get_Char_Code (Uname (J)));
+ else
+ Add_Char_To_Name_Buffer (Uname (J));
+ end if;
+ end loop;
+ end;
if Source.Language.Config.Kind = Unit_Based then
end case;
if Suffix /= No_File then
- Add_Str_To_Name_Buffer
- (Get_Name_String (Suffix));
+ Add_Str_To_Name_Buffer (Get_Name_String (Suffix));
end if;
end if;
procedure For_Every_Imported_Project is new
For_Every_Project_Imported (State => Integer, Action => Process);
+ -- Local variables
+
Dummy : Integer := 0;
-- Start of processing for Create_Mapping_File
begin
- For_Every_Imported_Project (Project, Dummy);
+ if Current_Verbosity = High then
+ Debug_Output ("Create mapping file for", Debug_Name (In_Tree));
+ end if;
+
+ Create_Temp_File (In_Tree.Shared, File, Name, "mapping");
+
+ if Current_Verbosity = High then
+ Debug_Increase_Indent ("Create mapping file ", Name_Id (Name));
+ end if;
+
+ For_Every_Imported_Project
+ (Project, In_Tree, Dummy, Include_Aggregated => False);
declare
Last : Natural;
Status : Boolean := False;
begin
- Create_Temp_File (In_Tree, File, Name, "mapping");
-
if File /= Invalid_FD then
Last := Write (File, Buffer (1)'Address, Buffer_Last);
end;
Free (Buffer);
+
+ Debug_Decrease_Indent ("Done create mapping file");
end Create_Mapping_File;
----------------------
----------------------
procedure Create_Temp_File
- (In_Tree : Project_Tree_Ref;
+ (Shared : Shared_Project_Tree_Data_Access;
Path_FD : out File_Descriptor;
Path_Name : out Path_Name_Type;
File_Use : String)
& Get_Name_String (Path_Name));
end if;
- Record_Temp_File (In_Tree, Path_Name);
+ Record_Temp_File (Shared, Path_Name);
else
Prj.Com.Fail
--------------------------
procedure Create_New_Path_File
- (In_Tree : Project_Tree_Ref;
+ (Shared : Shared_Project_Tree_Data_Access;
Path_FD : out File_Descriptor;
Path_Name : out Path_Name_Type)
is
begin
- Create_Temp_File (In_Tree, Path_FD, Path_Name, "path file");
+ Create_Temp_File (Shared, Path_FD, Path_Name, "path file");
end Create_New_Path_File;
------------------------------------
Main_Project_Only : Boolean := True;
Full_Path : Boolean := False) return String
is
+
+ Lang : constant Language_Ptr :=
+ Get_Language_From_Name (Project, "ada");
The_Project : Project_Id := Project;
Original_Name : String := Name;
- Lang : constant Language_Ptr :=
- Get_Language_From_Name (Project, "ada");
-
Unit : Unit_Index;
The_Original_Name : Name_Id;
The_Spec_Name : Name_Id;
-- Check for spec
if not Main_Project_Only
- or else
- (Unit.File_Names (Spec) /= null
- and then Unit.File_Names (Spec).Project =
- The_Project)
+ or else (Unit.File_Names (Spec) /= null
+ and then Unit.File_Names (Spec).Project = The_Project)
then
declare
Current_Name : File_Name_Type;
-- For_All_Object_Dirs --
-------------------------
- procedure For_All_Object_Dirs (Project : Project_Id) is
- procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
+ procedure For_All_Object_Dirs
+ (Project : Project_Id;
+ Tree : Project_Tree_Ref)
+ is
+ procedure For_Project
+ (Prj : Project_Id;
+ Tree : Project_Tree_Ref;
+ Dummy : in out Integer);
-- Get all object directories of Prj
-----------------
-- For_Project --
-----------------
- procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
- pragma Unreferenced (Dummy);
+ procedure For_Project
+ (Prj : Project_Id;
+ Tree : Project_Tree_Ref;
+ Dummy : in out Integer)
+ is
+ pragma Unreferenced (Dummy, Tree);
+
begin
-- ??? Set_Ada_Paths has a different behavior for library project
-- files, should we have the same ?
-- Start of processing for For_All_Object_Dirs
begin
- Get_Object_Dirs (Project, Dummy);
+ Get_Object_Dirs (Project, Tree, Dummy);
end For_All_Object_Dirs;
-------------------------
(Project : Project_Id;
In_Tree : Project_Tree_Ref)
is
- procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
+ procedure For_Project
+ (Prj : Project_Id;
+ In_Tree : Project_Tree_Ref;
+ Dummy : in out Integer);
-- Get all object directories of Prj
-----------------
-- For_Project --
-----------------
- procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
+ procedure For_Project
+ (Prj : Project_Id;
+ In_Tree : Project_Tree_Ref;
+ Dummy : in out Integer)
+ is
pragma Unreferenced (Dummy);
+
Current : String_List_Id := Prj.Source_Dirs;
The_String : String_Element;
-- If there are Ada sources, call action with the name of every
-- source directory.
- if Has_Ada_Sources (Project) then
+ if Has_Ada_Sources (Prj) then
while Current /= Nil_String loop
- The_String := In_Tree.String_Elements.Table (Current);
+ The_String := In_Tree.Shared.String_Elements.Table (Current);
Action (Get_Name_String (The_String.Display_Value));
Current := The_String.Next;
end loop;
-- Start of processing for For_All_Source_Dirs
begin
- Get_Source_Dirs (Project, Dummy);
+ Get_Source_Dirs (Project, In_Tree, Dummy);
end For_All_Source_Dirs;
-------------------
while Unit /= null loop
if Unit.File_Names (Spec) /= null
+ and then not Unit.File_Names (Spec).Locally_Removed
and then Unit.File_Names (Spec).File /= No_File
and then
(Namet.Get_Name_String
- (Unit.File_Names (Spec).File) = Original_Name
- or else (Unit.File_Names (Spec).Path /=
- No_Path_Information
+ (Unit.File_Names (Spec).File) = Original_Name
+ or else (Unit.File_Names (Spec).Path /= No_Path_Information
and then
Namet.Get_Name_String
- (Unit.File_Names (Spec).Path.Name) =
- Original_Name))
+ (Unit.File_Names (Spec).Path.Name) =
+ Original_Name))
then
- Project := Ultimate_Extension_Of
- (Project => Unit.File_Names (Spec).Project);
+ Project :=
+ Ultimate_Extending_Project_Of
+ (Unit.File_Names (Spec).Project);
Path := Unit.File_Names (Spec).Path.Display_Name;
if Current_Verbosity > Default then
elsif Unit.File_Names (Impl) /= null
and then Unit.File_Names (Impl).File /= No_File
+ and then not Unit.File_Names (Impl).Locally_Removed
and then
(Namet.Get_Name_String
(Unit.File_Names (Impl).File) = Original_Name
- or else (Unit.File_Names (Impl).Path /=
- No_Path_Information
- and then Namet.Get_Name_String
- (Unit.File_Names (Impl).Path.Name) =
- Original_Name))
+ or else (Unit.File_Names (Impl).Path /= No_Path_Information
+ and then Namet.Get_Name_String
+ (Unit.File_Names (Impl).Path.Name) =
+ Original_Name))
then
- Project := Ultimate_Extension_Of
- (Project => Unit.File_Names (Impl).Project);
+ Project :=
+ Ultimate_Extending_Project_Of
+ (Unit.File_Names (Impl).Project);
Path := Unit.File_Names (Impl).Path.Display_Name;
if Current_Verbosity > Default then
end if;
end Get_Reference;
+ ----------------------
+ -- Get_Runtime_Path --
+ ----------------------
+
+ function Get_Runtime_Path
+ (Self : Project_Search_Path;
+ Name : String) return String_Access
+ is
+ function Is_Base_Name (Path : String) return Boolean;
+ -- Returns True if Path has no directory separator
+
+ ------------------
+ -- Is_Base_Name --
+ ------------------
+
+ function Is_Base_Name (Path : String) return Boolean is
+ begin
+ for J in Path'Range loop
+ if Path (J) = Directory_Separator or else Path (J) = '/' then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end Is_Base_Name;
+
+ function Find_Rts_In_Path is new Prj.Env.Find_Name_In_Path
+ (Check_Filename => Is_Directory);
+
+ -- Start of processing for Get_Runtime_Path
+
+ begin
+ if not Is_Base_Name (Name) then
+ return Find_Rts_In_Path (Self, Name);
+ else
+ return null;
+ end if;
+ end Get_Runtime_Path;
+
----------------
-- Initialize --
----------------
procedure Initialize (In_Tree : Project_Tree_Ref) is
begin
- In_Tree.Private_Part.Current_Source_Path_File := No_Path;
- In_Tree.Private_Part.Current_Object_Path_File := No_Path;
+ In_Tree.Shared.Private_Part.Current_Source_Path_File := No_Path;
+ In_Tree.Shared.Private_Part.Current_Object_Path_File := No_Path;
end Initialize;
-------------------
Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
end loop;
- -- Get the ultimate extending project
-
- if Result /= No_Project then
- while Result.Extended_By /= No_Project loop
- Result := Result.Extended_By;
- end loop;
- end if;
-
- return Result;
+ return Ultimate_Extending_Project_Of (Result);
end Project_Of;
-------------------
Objects_Path : Boolean := True)
is
+ Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared;
+
Source_Paths : Source_Path_Table.Instance;
Object_Paths : Object_Path_Table.Instance;
-- List of source or object dirs. Only computed the first time this
Buffer : String_Access := new String (1 .. Buffer_Initial);
Buffer_Last : Natural := 0;
- procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean);
+ procedure Recursive_Add
+ (Project : Project_Id;
+ In_Tree : Project_Tree_Ref;
+ Dummy : in out Boolean);
-- Recursive procedure to add the source/object paths of extended/
-- imported projects.
-- Recursive_Add --
-------------------
- procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean) is
- pragma Unreferenced (Dummy);
+ procedure Recursive_Add
+ (Project : Project_Id;
+ In_Tree : Project_Tree_Ref;
+ Dummy : in out Boolean)
+ is
+ pragma Unreferenced (Dummy, In_Tree);
Path : Path_Name_Type;
-- Ada sources.
if Has_Ada_Sources (Project) then
- Add_To_Source_Path (Project.Source_Dirs, In_Tree, Source_Paths);
+ Add_To_Source_Path (Project.Source_Dirs, Shared, Source_Paths);
end if;
end if;
if Include_Path and then Project.Include_Path_File = No_Path then
Source_Path_Table.Init (Source_Paths);
Process_Source_Dirs := True;
- Create_New_Path_File
- (In_Tree, Source_FD, Project.Include_Path_File);
+ Create_New_Path_File (Shared, Source_FD, Project.Include_Path_File);
end if;
-- For the object path, we make a distinction depending on
Object_Path_Table.Init (Object_Paths);
Process_Object_Dirs := True;
Create_New_Path_File
- (In_Tree, Object_FD, Project.Objects_Path_File_With_Libs);
+ (Shared, Object_FD, Project.Objects_Path_File_With_Libs);
end if;
elsif Objects_Path then
Object_Path_Table.Init (Object_Paths);
Process_Object_Dirs := True;
Create_New_Path_File
- (In_Tree, Object_FD, Project.Objects_Path_File_Without_Libs);
+ (Shared, Object_FD, Project.Objects_Path_File_Without_Libs);
end if;
end if;
-- then call the recursive procedure Add for Project.
if Process_Source_Dirs or Process_Object_Dirs then
- For_All_Projects (Project, Dummy);
+ For_All_Projects (Project, In_Tree, Dummy);
end if;
-- Write and close any file that has been created. Source_FD is not set
if Source_FD /= Invalid_FD then
Buffer_Last := 0;
- for Index in Source_Path_Table.First ..
- Source_Path_Table.Last (Source_Paths)
+ for Index in
+ Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths)
loop
Get_Name_String (Source_Paths.Table (Index));
Name_Len := Name_Len + 1;
if Object_FD /= Invalid_FD then
Buffer_Last := 0;
- for Index in Object_Path_Table.First ..
- Object_Path_Table.Last (Object_Paths)
+ for Index in
+ Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths)
loop
Get_Name_String (Object_Paths.Table (Index));
Name_Len := Name_Len + 1;
-- Set the env vars, if they need to be changed, and set the
-- corresponding flags.
- if Include_Path and then
- In_Tree.Private_Part.Current_Source_Path_File /=
- Project.Include_Path_File
+ if Include_Path
+ and then
+ Shared.Private_Part.Current_Source_Path_File /=
+ Project.Include_Path_File
then
- In_Tree.Private_Part.Current_Source_Path_File :=
+ Shared.Private_Part.Current_Source_Path_File :=
Project.Include_Path_File;
Set_Path_File_Var
(Project_Include_Path_File,
- Get_Name_String (In_Tree.Private_Part.Current_Source_Path_File));
+ Get_Name_String (Shared.Private_Part.Current_Source_Path_File));
end if;
if Objects_Path then
if Including_Libraries then
- if In_Tree.Private_Part.Current_Object_Path_File /=
+ if Shared.Private_Part.Current_Object_Path_File /=
Project.Objects_Path_File_With_Libs
then
- In_Tree.Private_Part.Current_Object_Path_File :=
+ Shared.Private_Part.Current_Object_Path_File :=
Project.Objects_Path_File_With_Libs;
Set_Path_File_Var
(Project_Objects_Path_File,
Get_Name_String
- (In_Tree.Private_Part.Current_Object_Path_File));
+ (Shared.Private_Part.Current_Object_Path_File));
end if;
else
- if In_Tree.Private_Part.Current_Object_Path_File /=
+ if Shared.Private_Part.Current_Object_Path_File /=
Project.Objects_Path_File_Without_Libs
then
- In_Tree.Private_Part.Current_Object_Path_File :=
+ Shared.Private_Part.Current_Object_Path_File :=
Project.Objects_Path_File_Without_Libs;
Set_Path_File_Var
(Project_Objects_Path_File,
Get_Name_String
- (In_Tree.Private_Part.Current_Object_Path_File));
+ (Shared.Private_Part.Current_Object_Path_File));
end if;
end if;
end if;
Free (Buffer);
end Set_Ada_Paths;
- -----------------------
- -- Set_Path_File_Var --
- -----------------------
-
- procedure Set_Path_File_Var (Name : String; Value : String) is
- Host_Spec : String_Access := To_Host_File_Spec (Value);
- begin
- if Host_Spec = null then
- Prj.Com.Fail
- ("could not convert file name """ & Value & """ to host spec");
- else
- Setenv (Name, Host_Spec.all);
- Free (Host_Spec);
- end if;
- end Set_Path_File_Var;
-
- ---------------------------
- -- Ultimate_Extension_Of --
- ---------------------------
-
- function Ultimate_Extension_Of
- (Project : Project_Id) return Project_Id
- is
- Result : Project_Id;
-
- begin
- Result := Project;
- while Result.Extended_By /= No_Project loop
- Result := Result.Extended_By;
- end loop;
-
- return Result;
- end Ultimate_Extension_Of;
-
---------------------
-- Add_Directories --
---------------------
Self.Path := new String'(Tmp.all & Path_Separator & Path);
Free (Tmp);
end if;
+
+ if Current_Verbosity = High then
+ Debug_Output ("Adding directories to Project_Path: """
+ & Path & '"');
+ end if;
end Add_Directories;
- -----------------------------
- -- Initialize_Project_Path --
- -----------------------------
+ --------------------
+ -- Is_Initialized --
+ --------------------
+
+ function Is_Initialized (Self : Project_Search_Path) return Boolean is
+ begin
+ return Self.Path /= null
+ and then (Self.Path'Length = 0
+ or else Self.Path (Self.Path'First) /= '#');
+ end Is_Initialized;
- procedure Initialize_Project_Path
+ ----------------------
+ -- Initialize_Empty --
+ ----------------------
+
+ procedure Initialize_Empty (Self : in out Project_Search_Path) is
+ begin
+ Free (Self.Path);
+ Self.Path := new String'("");
+ end Initialize_Empty;
+
+ -------------------------------------
+ -- Initialize_Default_Project_Path --
+ -------------------------------------
+
+ procedure Initialize_Default_Project_Path
(Self : in out Project_Search_Path;
Target_Name : String)
is
-- May be empty.
begin
- -- If already initialized, nothing else to do
-
- if Self.Path /= null
- and then Self.Path (Self.Path'First) /= '#'
- then
+ if Is_Initialized (Self) then
return;
end if;
if Add_Default_Dir then
declare
- Prefix : String_Ptr := Sdefault.Search_Dir_Prefix;
+ Prefix : String_Ptr;
begin
- if Prefix = null then
+ if Sdefault.Search_Dir_Prefix = null then
+
+ -- gprbuild case
+
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;
+ else
+ Prefix := new String'(Sdefault.Search_Dir_Prefix.all
+ & ".." & Dir_Separator
+ & ".." & Dir_Separator
+ & ".." & Dir_Separator
+ & ".." & Dir_Separator);
+ end if;
+
+ if Prefix.all /= "" then
+ if Target_Name /= "" then
+
+ -- $prefix/$target/lib/gnat
Add_Str_To_Name_Buffer
(Path_Separator & Prefix.all &
- "share" & Directory_Separator & "gpr");
+ Target_Name);
+
+ -- Note: Target_Name has a trailing / when it comes from
+ -- Sdefault.
+
+ if Name_Buffer (Name_Len) /= '/' then
+ Add_Char_To_Name_Buffer (Directory_Separator);
+ end if;
+
Add_Str_To_Name_Buffer
- (Path_Separator & Prefix.all &
- "lib" & Directory_Separator & "gnat");
+ ("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");
+ -- $prefix/share/gpr
+
+ Add_Str_To_Name_Buffer
+ (Path_Separator & Prefix.all &
+ "share" & Directory_Separator & "gpr");
+
+ -- $prefix/lib/gnat
+
+ Add_Str_To_Name_Buffer
+ (Path_Separator & Prefix.all &
+ "lib" & 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;
+ Self.Path := new String'(Name_Buffer (1 .. Name_Len));
+ end Initialize_Default_Project_Path;
--------------
-- Get_Path --
--------------
- procedure Get_Path
- (Self : in out Project_Search_Path;
- Path : out String_Access)
- is
+ procedure Get_Path (Self : Project_Search_Path; Path : out String_Access) is
begin
- Initialize_Project_Path (Self, ""); -- ??? Target_Name unspecified
+ pragma Assert (Is_Initialized (Self));
Path := Self.Path;
end Get_Path;
-- Set_Path --
--------------
- procedure Set_Path
- (Self : in out Project_Search_Path; Path : String) is
+ procedure Set_Path (Self : in out Project_Search_Path; Path : String) is
begin
Free (Self.Path);
Self.Path := new String'(Path);
Projects_Paths.Reset (Self.Cache);
end Set_Path;
- ------------------
- -- Find_Project --
- ------------------
+ -----------------------
+ -- Find_Name_In_Path --
+ -----------------------
- procedure Find_Project
- (Self : in out Project_Search_Path;
- Project_File_Name : String;
- Directory : String;
- Path : out Namet.Path_Name_Type)
+ function Find_Name_In_Path
+ (Self : Project_Search_Path;
+ Path : String) return String_Access
is
- File : constant String := Project_File_Name;
- -- Have to do a copy, in case the parameter is Name_Buffer, which we
- -- modify below
+ First : Natural;
+ Last : Natural;
+
+ begin
+ if Current_Verbosity = High then
+ Debug_Output ("Trying " & Path);
+ end if;
- function Try_Path_Name (Path : String) return String_Access;
- pragma Inline (Try_Path_Name);
- -- Try the specified Path
+ if Is_Absolute_Path (Path) then
+ if Check_Filename (Path) then
+ return new String'(Path);
+ else
+ return null;
+ end if;
- -------------------
- -- Try_Path_Name --
- -------------------
+ else
+ -- Because we don't want to resolve symbolic links, we cannot use
+ -- Locate_Regular_File. So, we try each possible path successively.
- function Try_Path_Name (Path : String) return String_Access is
- First : Natural;
- Last : Natural;
- Result : String_Access := null;
+ 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;
- begin
- if Current_Verbosity = High then
- Write_Str (" Trying ");
- Write_Line (Path);
- end if;
+ exit when First > Self.Path'Last;
- if Is_Absolute_Path (Path) then
- if Is_Regular_File (Path) then
- Result := new String'(Path);
- end if;
+ Last := First;
+ while Last < Self.Path'Last
+ and then Self.Path (Last + 1) /= Path_Separator
+ loop
+ Last := Last + 1;
+ end loop;
- 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;
+ Name_Len := 0;
- Add_Str_To_Name_Buffer (Self.Path (First .. Last));
+ 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);
- Add_Str_To_Name_Buffer (Path);
+ end if;
- if Current_Verbosity = High then
- Write_Str (" Testing file ");
- Write_Line (Name_Buffer (1 .. Name_Len));
- 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 Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
- Result := new String'(Name_Buffer (1 .. Name_Len));
- exit;
- end if;
+ if Current_Verbosity = High then
+ Debug_Output ("Testing file " & Name_Buffer (1 .. Name_Len));
+ end if;
- First := Last + 1;
- end loop;
- end if;
+ if Check_Filename (Name_Buffer (1 .. Name_Len)) then
+ return new String'(Name_Buffer (1 .. Name_Len));
+ end if;
- return Result;
- end Try_Path_Name;
+ First := Last + 1;
+ end loop;
+ end if;
+
+ return null;
+ end Find_Name_In_Path;
+
+ ------------------
+ -- 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 is new Find_Name_In_Path
+ (Check_Filename => Is_Regular_File);
+ -- Find a file in the project search path.
-- Local Declarations
- Result : String_Access;
- Has_Dot : Boolean := False;
- Key : Name_Id;
+ Result : String_Access;
+ Has_Dot : Boolean := False;
+ Key : Name_Id;
-- Start of processing for Find_Project
begin
- Initialize_Project_Path (Self, "");
+ pragma Assert (Is_Initialized (Self));
if Current_Verbosity = High then
- Write_Str ("Searching for project (""");
- Write_Str (File);
- Write_Str (""", """);
- Write_Str (Directory);
- Write_Line (""");");
+ Debug_Increase_Indent
+ ("Searching for project """ & File & """ in """
+ & Directory & '"');
end if;
-- Check the project cache
Path := Projects_Paths.Get (Self.Cache, Key);
if Path /= No_Path then
+ Debug_Decrease_Indent;
return;
end if;
if not Has_Dot then
Result := Try_Path_Name
- (Directory & Directory_Separator &
+ (Self,
+ 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);
+ Result := Try_Path_Name
+ (Self, 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);
+ Result := Try_Path_Name (Self, File & Project_File_Extension);
end if;
-- Then we try <file_name>
if Result = null then
- Result := Try_Path_Name (File);
+ Result := Try_Path_Name (Self, File);
end if;
-- If we cannot find the project file, we return an empty string
Projects_Paths.Set (Self.Cache, Key, Path);
end;
end if;
+
+ Debug_Decrease_Indent;
end Find_Project;
----------
Projects_Paths.Reset (Self.Cache);
end Free;
+ ----------
+ -- Copy --
+ ----------
+
+ procedure Copy (From : Project_Search_Path; To : out Project_Search_Path) is
+ begin
+ Free (To);
+
+ if From.Path /= null then
+ To.Path := new String'(From.Path.all);
+ end if;
+
+ -- No need to copy the Cache, it will be recomputed as needed
+ end Copy;
+
end Prj.Env;