------------------------------------------------------------------------------
-- --
-- GPR PROJECT MANAGER --
-- --
-- Copyright (C) 2001-2022, Free Software Foundation, Inc. --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- . --
-- --
------------------------------------------------------------------------------
with Ada.Calendar;
with Ada.Calendar.Time_Zones; use Ada.Calendar.Time_Zones;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Containers.Ordered_Sets;
with Ada.Containers.Vectors;
with Ada.Directories; use Ada.Directories;
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Strings.Maps; use Ada.Strings.Maps;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Streams.Stream_IO; use Ada.Streams;
with Ada.Exceptions;
with GNAT.Calendar.Time_IO; use GNAT.Calendar.Time_IO;
with GNAT.Case_Util; use GNAT.Case_Util;
with GNAT.HTable;
with GNAT.Regexp; use GNAT.Regexp;
with GNAT.Table;
with GNAT.Calendar; use GNAT.Calendar;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with Interfaces.C.Strings;
with System; use System;
with GPR.ALI; use GPR.ALI;
with GPR.Com;
with GPR.Conf;
with GPR.Debug;
with GPR.Env;
with GPR.Err;
with GPR.Jobserver;
with GPR.Names; use GPR.Names;
with GPR.Opt; use GPR.Opt;
with GPR.Output; use GPR.Output;
with GPR.Sdefault;
with GPR.Sinput;
with GPR.Snames; use GPR.Snames;
with GPR.Version; use GPR.Version;
with Gpr_Build_Util; use Gpr_Build_Util;
package body GPR.Util is
use Ada.Containers;
Program_Name : String_Access := null;
type File_Stamp_Record is record
Known : Boolean := False;
TS : Time_Stamp_Type := Empty_Time_Stamp;
end record;
Unknow_File_Stamp : constant File_Stamp_Record := (False, Empty_Time_Stamp);
package File_Stamp_HTable is new GNAT.HTable.Simple_HTable
(Header_Num => GPR.Header_Num,
Element => File_Stamp_Record,
No_Element => Unknow_File_Stamp,
Key => Path_Name_Type,
Hash => GPR.Hash,
Equal => "=");
-- A hash table to cache time stamps of files
package Source_Info_Table is new GNAT.Table
(Table_Component_Type => Source_Info_Iterator,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100);
package Source_Info_Project_HTable is new GNAT.HTable.Simple_HTable
(Header_Num => GPR.Header_Num,
Element => Natural,
No_Element => 0,
Key => Name_Id,
Hash => GPR.Hash,
Equal => "=");
procedure Free is new Ada.Unchecked_Deallocation
(Text_File_Data, Text_File);
package Processed_ALIs is new GNAT.HTable.Simple_HTable
(Header_Num => GPR.Header_Num,
Element => Boolean,
No_Element => False,
Key => File_Name_Type,
Hash => GPR.Hash,
Equal => "=");
True_Checksum : constant File_Name_Type := File_Name_Type (First_Name_Id);
-- Special constant to declare that checksum in Source record is calculated
-- from source file content.
function To_Path_String_Access
(Path_Addr : Address;
Path_Len : Integer) return String_Access;
-- Converts a C String to an Ada String.
function Locate_Directory
(Dir_Name : C_File_Name;
Path : C_File_Name) return String_Access;
function C_String_Length (S : Address) return Integer;
-- Returns the length of C (null-terminated) string at S, or 0 for
-- Null_Address.
function File_Stamp (Path : Path_Name_Type) return Time_Stamp_Type;
-- Get the time stamp of Path. Take it from File_Stamp_HTable if it is
-- already there, otherwise get it from OS and put into File_Stamp_HTable
-- to be able to get it next time.
---------------------
-- C_String_Length --
---------------------
function C_String_Length (S : Address) return Integer is
function strlen (A : Address) return size_t;
pragma Import (Intrinsic, strlen, "strlen");
begin
if S = Null_Address then
return 0;
else
return Integer (strlen (S));
end if;
end C_String_Length;
------------------------
-- Calculate_Checksum --
------------------------
function Calculate_Checksum (Source : Source_Id) return Boolean is
Source_Index : Source_File_Index;
begin
if Source.Checksum_Src = True_Checksum then
-- Checksum already calculated
return True;
end if;
Source_Index :=
Sinput.Load_File (Get_Name_String (Source.Path.Display_Name));
if Source_Index /= No_Source_File then
Err.Scanner.Initialize_Scanner (Source_Index, Err.Scanner.Ada);
-- Scan the complete file to compute its
-- checksum.
loop
Err.Scanner.Scan;
exit when Token = Tok_EOF;
end loop;
Source.Checksum := Scans.Checksum;
Source.Checksum_Src := True_Checksum;
-- If there were errors we can't Clear_Source_File_Table because the
-- error messages refer to this table content.
if Total_Errors_Detected = 0 then
-- To avoid using too much memory, free the
-- memory allocated.
Sinput.Clear_Source_File_Table;
end if;
return True;
end if;
return False;
end Calculate_Checksum;
------------------------
-- Calculate_Checksum --
------------------------
function Calculate_Checksum (File : Path_Name_Type) return Word is
Source_Index : Source_File_Index;
Checksum : Word := 0;
begin
Source_Index :=
Sinput.Load_File (Get_Name_String (File));
if Source_Index /= No_Source_File then
Err.Scanner.Initialize_Scanner (Source_Index, Err.Scanner.Ada);
-- Scan the complete file to compute its
-- checksum.
loop
Err.Scanner.Scan;
exit when Token = Tok_EOF;
end loop;
Checksum := Scans.Checksum;
-- If there were errors we can't Clear_Source_File_Table because the
-- error messages refer to this table content.
if Total_Errors_Detected = 0 then
-- To avoid using too much memory, free the
-- memory allocated.
Sinput.Clear_Source_File_Table;
end if;
return Checksum;
end if;
return Checksum;
end Calculate_Checksum;
----------------------------
-- Clear_Time_Stamp_Cache --
----------------------------
procedure Clear_Time_Stamp_Cache is
begin
File_Stamp_HTable.Reset;
end Clear_Time_Stamp_Cache;
----------------
-- File_Stamp --
----------------
function File_Stamp (Path : Path_Name_Type) return Time_Stamp_Type is
begin
if Path = No_Path then
return Empty_Time_Stamp;
else
declare
FSR : File_Stamp_Record := File_Stamp_HTable.Get (Path);
begin
if FSR.Known then
return FSR.TS;
else
declare
Result : constant Time_Stamp_Type := Osint.File_Stamp (Path);
begin
FSR := (True, Result);
File_Stamp_HTable.Set (Path, FSR);
return Result;
end;
end if;
end;
end if;
end File_Stamp;
-----------------------
-- Update_File_Stamp --
-----------------------
procedure Update_File_Stamp
(Path : Path_Name_Type;
Stamp : Time_Stamp_Type)
is
begin
if Path = No_Path then
null;
else
File_Stamp_HTable.Set (Path, (True, Stamp));
end if;
end Update_File_Stamp;
----------------------
-- Locate_Directory --
----------------------
function Locate_Directory
(Dir_Name : C_File_Name;
Path : C_File_Name) return String_Access
is
function Is_Dir (Name : Address) return Integer;
pragma Import (C, Is_Dir, "__gnat_is_directory");
function Locate_File_With_Predicate
(File_Name, Path_Val, Predicate : Address) return Address;
pragma Import
(C, Locate_File_With_Predicate, "__gnat_locate_file_with_predicate");
Result_Addr : Address;
Result_Len : Integer;
Result : String_Access := null;
begin
Result_Addr :=
Locate_File_With_Predicate
(Dir_Name, Path, Is_Dir'Address);
Result_Len := C_String_Length (Result_Addr);
if Result_Len /= 0 then
Result := To_Path_String_Access (Result_Addr, Result_Len);
end if;
return Result;
end Locate_Directory;
function Locate_Directory
(Dir_Name : String;
Path : String) return String_Access
is
C_Dir_Name : String (1 .. Dir_Name'Length + 1);
C_Path : String (1 .. Path'Length + 1);
Result : String_Access;
begin
C_Dir_Name (1 .. Dir_Name'Length) := Dir_Name;
C_Dir_Name (C_Dir_Name'Last) := ASCII.NUL;
C_Path (1 .. Path'Length) := Path;
C_Path (C_Path'Last) := ASCII.NUL;
Result := Locate_Directory (C_Dir_Name'Address, C_Path'Address);
if Result /= null and then not Is_Absolute_Path (Result.all) then
declare
Absolute_Path : constant String := Normalize_Pathname (Result.all);
begin
Free (Result);
Result := new String'(Absolute_Path);
end;
end if;
return Result;
end Locate_Directory;
---------------------------
-- To_Path_String_Access --
---------------------------
function To_Path_String_Access
(Path_Addr : Address;
Path_Len : Integer) return String_Access
is
subtype Path_String is String (1 .. Path_Len);
type Path_String_Access is access Path_String;
function Address_To_Access is new Ada.Unchecked_Conversion
(Source => Address, Target => Path_String_Access);
Path_Access : constant Path_String_Access :=
Address_To_Access (Path_Addr);
Return_Val : String_Access;
begin
Return_Val := new String (1 .. Path_Len);
for J in 1 .. Path_Len loop
Return_Val (J) := Path_Access (J);
end loop;
return Return_Val;
end To_Path_String_Access;
--------------
-- Closures --
--------------
type Project_And_Tree is record
Project : Project_Id;
Tree : Project_Tree_Ref;
end record;
function "<" (Left, Right : Project_And_Tree) return Boolean;
package Projects_And_Trees_Sets is
new Ada.Containers.Indefinite_Ordered_Sets
(Element_Type => Project_And_Tree);
type Main_Project_Tree is record
Main : Source_Id;
Project : Project_Id;
Tree : Project_Tree_Ref;
end record;
function "<" (Left, Right : Main_Project_Tree) return Boolean;
package MPT_Sets is new Ada.Containers.Indefinite_Ordered_Sets
(Element_Type => Main_Project_Tree);
package File_Name_Vectors is new Ada.Containers.Vectors
(Positive, File_Name_Type);
subtype File_Names is File_Name_Vectors.Vector;
package Path_Sets renames String_Sets;
---------
-- "<" --
---------
function "<" (Left, Right : Project_And_Tree) return Boolean is
begin
return Left.Project.Name < Right.Project.Name;
end "<";
function "<" (Left, Right : Main_Project_Tree) return Boolean is
begin
if Left.Project.Name /= Right.Project.Name then
return Left.Project.Name < Right.Project.Name;
else
return Left.Main.File < Right.Main.File;
end if;
end "<";
-----------
-- Close --
-----------
procedure Close (File : in out Text_File) is
Len : Integer;
Status : Boolean;
begin
if File = null then
GPR.Com.Fail ("Close attempted on an invalid Text_File");
end if;
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
GPR.Com.Fail ("Unable to write to an out Text_File");
end if;
end if;
Close (File.FD, Status);
if not Status then
GPR.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;
Free (File);
end Close;
------------------------------
-- Compilation_Phase_Failed --
------------------------------
procedure Compilation_Phase_Failed
(Project_Tree : Project_Tree_Ref;
Exit_Code : Exit_Code_Type := E_Fatal;
No_Message : Boolean := False) is
begin
Fail_Program
(Project_Tree, "*** compilation phase failed", Exit_Code,
No_Message => No_Message);
end Compilation_Phase_Failed;
------------
-- 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;
-------------------------------
-- Common_Path_Prefix_Length --
-------------------------------
function Common_Path_Prefix_Length (A, B : String) return Integer is
Slash : Integer := A'First; -- At the last slash seen in A
At_A : Integer := A'First;
At_B : Integer := B'First;
begin
loop
if At_A > A'Last then
if At_B > B'Last or else B (At_B) = '/' then
return A'Length;
else
return Slash - A'First;
end if;
elsif At_B > B'Last then
if A (At_A) = '/' then -- A cannot be shorter than B here
return B'Length;
else
return Slash - A'First;
end if;
elsif A (At_A) /= B (At_B) then
return Slash - A'First;
elsif A (At_A) = '/' then
Slash := At_A;
end if;
At_A := At_A + 1;
At_B := At_B + 1;
end loop;
end Common_Path_Prefix_Length;
-------------------
-- Common_Prefix --
-------------------
function Common_Prefix (Pathname1, Pathname2 : String) return String is
P1 : constant String := Normalize_Pathname (Pathname1);
P2 : constant String := Normalize_Pathname (Pathname2);
I1 : Positive := P1'First;
I2 : Positive := P2'First;
begin
while I1 <= P1'Last
and then I2 <= P2'Last
and then P1 (I1) = P2 (I2)
loop
I1 := I1 + 1;
I2 := I2 + 1;
end loop;
if I1 <= P1'Last or else I2 <= P2'Last then
return P1 (P1'First .. I1 - 1);
elsif I1 > P1'Last then
return P2;
else
return P1;
end if;
end Common_Prefix;
---------------
-- Duplicate --
---------------
procedure Duplicate
(This : in out Name_List_Index;
Shared : Shared_Project_Tree_Data_Access)
is
Old_Current : Name_List_Index;
New_Current : Name_List_Index;
begin
if This /= No_Name_List then
Old_Current := This;
Name_List_Table.Increment_Last (Shared.Name_Lists);
New_Current := Name_List_Table.Last (Shared.Name_Lists);
This := New_Current;
Shared.Name_Lists.Table (New_Current) :=
(Shared.Name_Lists.Table (Old_Current).Name, No_Name_List);
loop
Old_Current := Shared.Name_Lists.Table (Old_Current).Next;
exit when Old_Current = No_Name_List;
Shared.Name_Lists.Table (New_Current).Next := New_Current + 1;
Name_List_Table.Increment_Last (Shared.Name_Lists);
New_Current := New_Current + 1;
Shared.Name_Lists.Table (New_Current) :=
(Shared.Name_Lists.Table (Old_Current).Name, No_Name_List);
end loop;
end if;
end Duplicate;
-----------------
-- End_Of_File --
-----------------
function End_Of_File (File : Text_File) return Boolean is
begin
if File = null then
GPR.Com.Fail ("End_Of_File attempted on an invalid Text_File");
end if;
return File.End_Of_File_Reached;
end End_Of_File;
-------------------
-- Executable_Of --
-------------------
function Executable_Of
(Project : Project_Id;
Shared : Shared_Project_Tree_Data_Access;
Main : File_Name_Type;
Index : Int;
Language : String := "";
Include_Suffix : Boolean := True) return File_Name_Type
is
pragma Assert (Project /= No_Project);
The_Packages : constant Package_Id := Project.Decl.Packages;
Builder_Package : constant GPR.Package_Id :=
GPR.Util.Value_Of
(Name => Name_Builder,
In_Packages => The_Packages,
Shared => Shared);
Executable : Variable_Value :=
GPR.Util.Value_Of
(Name => Name_Id (Main),
Index => Index,
Attribute_Or_Array_Name => Name_Executable,
In_Package => Builder_Package,
Shared => Shared);
Lang : Language_Ptr;
Spec_Suffix : Name_Id := No_Name;
Body_Suffix : Name_Id := No_Name;
Spec_Suffix_Length : Natural := 0;
Body_Suffix_Length : Natural := 0;
procedure Get_Suffixes
(B_Suffix : File_Name_Type;
S_Suffix : File_Name_Type);
-- Get the non empty suffixes in variables Spec_Suffix and Body_Suffix
function Add_Suffix (File : File_Name_Type) return File_Name_Type;
-- Return the name of the executable, based on File, and adding the
-- executable suffix if needed
------------------
-- Get_Suffixes --
------------------
procedure Get_Suffixes
(B_Suffix : File_Name_Type;
S_Suffix : File_Name_Type) is
begin
if B_Suffix /= No_File then
Body_Suffix := Name_Id (B_Suffix);
Body_Suffix_Length := Natural (Length_Of_Name (Body_Suffix));
end if;
if S_Suffix /= No_File then
Spec_Suffix := Name_Id (S_Suffix);
Spec_Suffix_Length := Natural (Length_Of_Name (Spec_Suffix));
end if;
end Get_Suffixes;
----------------
-- Add_Suffix --
----------------
function Add_Suffix (File : File_Name_Type) return File_Name_Type is
Saved_EEOT : constant Name_Id := Executable_Extension_On_Target;
Result : File_Name_Type;
begin
if Include_Suffix then
if Project.Config.Executable_Suffix /= No_Name then
Executable_Extension_On_Target :=
Project.Config.Executable_Suffix;
end if;
Result := Executable_Name (File);
Executable_Extension_On_Target := Saved_EEOT;
return Result;
end if;
return File;
end Add_Suffix;
-- Start of processing for Executable_Of
begin
if Language /= "" then
Lang := Get_Language_From_Name (Project, Language);
end if;
if Lang /= null then
Get_Suffixes
(B_Suffix => Lang.Config.Naming_Data.Body_Suffix,
S_Suffix => Lang.Config.Naming_Data.Spec_Suffix);
end if;
if Builder_Package /= No_Package then
if Executable = Nil_Variable_Value then
Get_Name_String (Main);
-- Try as index the name minus the implementation suffix or minus
-- the specification suffix.
declare
Name : constant String (1 .. Name_Len) :=
Name_Buffer (1 .. Name_Len);
Last : Positive := Name_Len;
Truncated : Boolean := False;
begin
if Body_Suffix /= No_Name
and then Last > Natural (Length_Of_Name (Body_Suffix))
and then Name (Last - Body_Suffix_Length + 1 .. Last) =
Get_Name_String (Body_Suffix)
then
Truncated := True;
Last := Last - Body_Suffix_Length;
end if;
if Spec_Suffix /= No_Name
and then not Truncated
and then Last > Spec_Suffix_Length
and then Name (Last - Spec_Suffix_Length + 1 .. Last) =
Get_Name_String (Spec_Suffix)
then
Truncated := True;
Last := Last - Spec_Suffix_Length;
end if;
if Truncated then
Name_Len := Last;
Name_Buffer (1 .. Name_Len) := Name (1 .. Last);
Executable :=
GPR.Util.Value_Of
(Name => Name_Find,
Index => 0,
Attribute_Or_Array_Name => Name_Executable,
In_Package => Builder_Package,
Shared => Shared);
end if;
end;
end if;
-- If we have found an Executable attribute, return its value,
-- possibly suffixed by the executable suffix.
if Executable /= Nil_Variable_Value
and then Executable.Value /= No_Name
and then Length_Of_Name (Executable.Value) /= 0
then
return Add_Suffix (File_Name_Type (Executable.Value));
end if;
end if;
Get_Name_String (Main);
-- If there is a body suffix or a spec suffix, remove this suffix,
-- otherwise remove any suffix ('.' followed by other characters), if
-- there is one.
if Body_Suffix /= No_Name
and then Name_Len > Body_Suffix_Length
and then Name_Buffer (Name_Len - Body_Suffix_Length + 1 .. Name_Len) =
Get_Name_String (Body_Suffix)
then
-- Found the body termination, remove it
Name_Len := Name_Len - Body_Suffix_Length;
elsif Spec_Suffix /= No_Name
and then Name_Len > Spec_Suffix_Length
and then
Name_Buffer (Name_Len - Spec_Suffix_Length + 1 .. Name_Len) =
Get_Name_String (Spec_Suffix)
then
-- Found the spec termination, remove it
Name_Len := Name_Len - Spec_Suffix_Length;
else
-- Remove any suffix, if there is one
Get_Name_String (Strip_Suffix (Main));
end if;
return Add_Suffix (Name_Find);
end Executable_Of;
----------------------------
-- Executable_Prefix_Path --
----------------------------
function Executable_Prefix_Path return String is
Exec_Name : constant String := Command_Name;
function Get_Install_Dir (S : String) return String;
-- S is the executable name preceded by the absolute or relative path,
-- e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory where "bin"
-- lies (in the example "C:\usr"). If the executable is not in a "bin"
-- directory, return "".
---------------------
-- Get_Install_Dir --
---------------------
function Get_Install_Dir (S : String) return String is
Exec : String := Normalize_Pathname (S, Resolve_Links => True);
Path_Last : Integer := 0;
begin
for J in reverse Exec'Range loop
if Is_Directory_Separator (Exec (J)) then
Path_Last := J - 1;
exit;
end if;
end loop;
if Path_Last >= Exec'First + 2 then
To_Lower (Exec (Path_Last - 2 .. Path_Last));
end if;
if Path_Last < Exec'First + 2
or else Exec (Path_Last - 2 .. Path_Last) /= "bin"
or else (Path_Last - 3 >= Exec'First
and then not Is_Directory_Separator (Exec (Path_Last - 3)))
then
return "";
end if;
return (Exec (Exec'First .. Path_Last - 4)) & Directory_Separator;
end Get_Install_Dir;
-- Beginning of Executable_Prefix_Path
begin
-- First determine if a path prefix was placed in front of the
-- executable name.
for J in reverse Exec_Name'Range loop
if Is_Directory_Separator (Exec_Name (J)) then
return Get_Install_Dir (Exec_Name);
end if;
end loop;
-- If we get here, the user has typed the executable name with no
-- directory prefix.
declare
Path : String_Access := Locate_Exec_On_Path (Exec_Name);
begin
if Path = null then
return "";
else
declare
Dir : constant String := Get_Install_Dir (Path.all);
begin
Free (Path);
return Dir;
end;
end if;
end;
end Executable_Prefix_Path;
------------
-- Expect --
------------
procedure Expect (The_Token : Token_Type; Token_Image : String) is
begin
if Token /= The_Token then
-- ??? Should pass user flags here instead
Err.Error_Msg
(Gprbuild_Flags, Token_Image & " expected", Token_Ptr,
One_Line => True);
end if;
end Expect;
------------------
-- Fail_Program --
------------------
procedure Fail_Program
(Project_Tree : Project_Tree_Ref;
Message : String;
Exit_Code : Exit_Code_Type := E_Fatal;
Flush_Messages : Boolean := True;
No_Message : Boolean := False;
Command : String := "") is
begin
if Flush_Messages and not No_Message then
if Total_Errors_Detected /= 0 or else Warnings_Detected /= 0 then
Err.Finalize;
end if;
end if;
GPR.Jobserver.Unregister_All_Token_Id;
Finish_Program
(Project_Tree,
Exit_Code => Exit_Code,
Message => Message,
No_Message => No_Message,
Command => Command);
end Fail_Program;
--------------------
-- Finish_Program --
--------------------
procedure Finish_Program
(Project_Tree : Project_Tree_Ref;
Exit_Code : Exit_Code_Type := E_Success;
Message : String := "";
No_Message : Boolean := False;
Command : String := "") is
begin
if not Opt.Keep_Temporary_Files then
Delete_All_Temp_Files
(if Project_Tree = null then null else Project_Tree.Shared);
end if;
if Message'Length > 0 and then not No_Message then
if Exit_Code not in E_Success | E_Subtool then
Set_Standard_Error;
end if;
Write_Program_Name;
Write_Line (Message);
if Command /= "" then
Write_Program_Name;
Write_Line (Command);
end if;
end if;
Exit_Program (Exit_Code);
end Finish_Program;
---------------------------
-- For_Interface_Sources --
---------------------------
procedure For_Interface_Sources
(Tree : Project_Tree_Ref;
Project : Project_Id)
is
package Dep_Names renames String_Sets;
function Less_Than (Left, Right : Source_Id) return Boolean is
(Get_Name_String (Left.File) < Get_Name_String (Right.File));
package Interface_Source_Ids is
new Ada.Containers.Ordered_Sets
(Element_Type => Source_Id,
"<" => Less_Than,
"=" => "=");
function Load_ALI (Filename : String) return ALI_Id;
-- Load an ALI file and return its id
--------------
-- Load_ALI --
--------------
function Load_ALI (Filename : String) return ALI_Id is
Result : ALI_Id := No_ALI_Id;
Text : Text_Buffer_Ptr;
Lib_File : File_Name_Type;
begin
if Ada.Directories.Exists (Filename) then
Lib_File := Get_File_Name_Id (Filename);
Text := Osint.Read_Library_Info (Lib_File);
Result :=
ALI.Scan_ALI
(Lib_File,
Text,
Ignore_ED => False,
Err => True,
Read_Lines => "UD");
Free (Text);
end if;
return Result;
end Load_ALI;
-- Local declarations
Iter : Source_Iterator;
Sid : Source_Id;
ALI : ALI_Id;
First_Unit : Unit_Id;
Second_Unit : Unit_Id;
Body_Needed : Boolean;
Deps : Dep_Names.Set;
Sids : Interface_Source_Ids.Set;
-- Start of processing for For_Interface_Sources
begin
if Project.Qualifier = Aggregate_Library then
Iter := For_Each_Source (Tree);
else
Iter := For_Each_Source (Tree, Project);
end if;
-- First look at each spec, check if the body is needed
loop
Sid := Element (Iter);
exit when Sid = No_Source;
-- Skip sources that are removed/excluded and sources not part of
-- the interface for standalone libraries.
if Sid.Kind = Spec
and then (not Sid.Project.Externally_Built
or else Sid.Project = Project)
and then not Sid.Locally_Removed
and then (Project.Standalone_Library = No
or else Sid.Declared_In_Interfaces)
-- Handle case of non-compilable languages
and then Sid.Dep_Name /= No_File
then
Sids.Include (Sid);
-- Check ALI for dependencies on body and sep
ALI :=
Load_ALI
(Get_Name_String (Get_Object_Directory (Sid.Project, True))
& Get_Name_String (Sid.Dep_Name));
if ALI /= No_ALI_Id then
First_Unit := ALIs.Table (ALI).First_Unit;
Second_Unit := No_Unit_Id;
Body_Needed := True;
-- If there is both a spec and a body, check if both needed
if Units.Table (First_Unit).Utype = Is_Body then
Second_Unit := ALIs.Table (ALI).Last_Unit;
-- If the body is not needed, then reset First_Unit
if not Units.Table (Second_Unit).Body_Needed_For_SAL then
Body_Needed := False;
end if;
elsif Units.Table (First_Unit).Utype = Is_Spec_Only then
Body_Needed := False;
end if;
-- Handle all the separates, if any
if Body_Needed then
if Other_Part (Sid) /= null then
Deps.Include (Get_Name_String (Other_Part (Sid).File));
end if;
for Dep in ALIs.Table (ALI).First_Sdep ..
ALIs.Table (ALI).Last_Sdep
loop
if Sdep.Table (Dep).Subunit_Name /= No_Name then
Deps.Include
(Get_Name_String (Sdep.Table (Dep).Sfile));
end if;
end loop;
end if;
end if;
end if;
Next (Iter);
end loop;
-- Now handle the bodies and separates if needed
if Deps.Length /= 0 then
if Project.Qualifier = Aggregate_Library then
Iter := For_Each_Source (Tree);
else
Iter := For_Each_Source (Tree, Project);
end if;
loop
Sid := Element (Iter);
exit when Sid = No_Source;
if Sid.Kind /= Spec
and then Deps.Contains (Get_Name_String (Sid.File))
then
Sids.Include (Sid);
end if;
Next (Iter);
end loop;
end if;
-- Call Action for all the sources, in order
for E of Sids loop
Action (E);
end loop;
end For_Interface_Sources;
------------------
-- Get_Closures --
------------------
procedure Get_Closures
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Mains : String_Vectors.Vector;
All_Projects : Boolean := True;
Include_Externally_Built : Boolean := False;
Status : out Status_Type;
Result : out String_Vectors.Vector)
is
Closures : Path_Sets.Set;
Projects_And_Trees : Projects_And_Trees_Sets.Set;
Mains_Projects_Trees : MPT_Sets.Set;
The_File_Names : File_Names := File_Name_Vectors.Empty_Vector;
procedure Add_To_Projects (Proj : Project_Id; Tree : Project_Tree_Ref);
-- Add project Proc with its Tree to the list of projects
procedure Add_To_Mains
(Main : Source_Id;
Project : Project_Id;
Tree : Project_Tree_Ref);
-- Add main Main with its Project and Tree to the list of mains
procedure Add_To_Closures (Source : Source_Id; Added : out Boolean);
-- Add Source to the list of closures. Added is True when Source is
-- effectively added. If Source was already in the list of closures, it
-- is not added again and Added is False.
procedure Look_For_Mains;
-- Look for mains in the project trees. Status is Success only if
-- all mains have been found.
procedure Get_Aggregated (Proj : Project_Id);
-- Get the non aggregated projects from Aggregate project Proj
procedure Cleanup;
-- Deallocate the local lists
procedure Initialize_Sources;
-- Initialize all the source records in all the trees
procedure Process
(Source : Source_Id;
Project : Project_Id;
Tree : Project_Tree_Ref);
-- Get the sources in the closure of Main and add them to the list of
-- closures.
---------------------
-- Add_To_Closures --
---------------------
procedure Add_To_Closures (Source : Source_Id; Added : out Boolean) is
Position : Path_Sets.Cursor;
begin
Added := False;
if Source /= No_Source then
Path_Sets.Insert
(Container => Closures,
New_Item => Get_Name_String (Source.Path.Display_Name),
Position => Position,
Inserted => Added);
end if;
end Add_To_Closures;
------------------
-- Add_To_Mains --
------------------
procedure Add_To_Mains
(Main : Source_Id;
Project : Project_Id;
Tree : Project_Tree_Ref)
is
Position : MPT_Sets.Cursor;
Inserted : Boolean;
begin
Mains_Projects_Trees.Insert
(New_Item => (Main, Project, Tree),
Position => Position,
Inserted => Inserted);
end Add_To_Mains;
---------------------
-- Add_To_Projects --
---------------------
procedure Add_To_Projects (Proj : Project_Id; Tree : Project_Tree_Ref) is
begin
Projects_And_Trees.Insert ((Proj, Tree));
end Add_To_Projects;
-------------
-- Cleanup --
-------------
procedure Cleanup is
begin
Closures.Clear;
Projects_And_Trees.Clear;
Mains_Projects_Trees.Clear;
The_File_Names.Clear;
end Cleanup;
--------------------
-- Get_Aggregated --
--------------------
procedure Get_Aggregated (Proj : Project_Id) is
List : Aggregated_Project_List := null;
Prj : Project_Id;
begin
if Proj.Qualifier = Aggregate then
List := Proj.Aggregated_Projects;
end if;
while List /= null loop
Prj := List.Project;
case Prj.Qualifier is
when Library | Configuration |
Abstract_Project | Aggregate_Library =>
null;
when Unspecified | Standard =>
if not Prj.Library and then not Prj.Externally_Built then
Add_To_Projects (Prj, List.Tree);
end if;
when Aggregate =>
Get_Aggregated (Prj);
end case;
List := List.Next;
end loop;
end Get_Aggregated;
------------------------
-- Initialize_Sources --
------------------------
procedure Initialize_Sources is
Last : constant Projects_And_Trees_Sets.Cursor :=
Projects_And_Trees_Sets.Last (Projects_And_Trees);
Position : Projects_And_Trees_Sets.Cursor :=
Projects_And_Trees_Sets.First (Projects_And_Trees);
Iter : Source_Iterator;
Src : Source_Id;
The_Project_And_Tree : Project_And_Tree;
use type Projects_And_Trees_Sets.Cursor;
begin
loop
The_Project_And_Tree := Projects_And_Trees_Sets.Element (Position);
-- Initialize all the Ada sources of the project tree, even if
-- All_Projects is False.
Iter := For_Each_Source
(In_Tree => The_Project_And_Tree.Tree,
Language => Name_Ada,
Encapsulated_Libs => True,
Locally_Removed => False);
loop
Src := Element (Iter);
exit when Src = No_Source;
Initialize_Source_Record (Src);
Next (Iter);
end loop;
exit when Position = Last;
Projects_And_Trees_Sets.Next (Position);
end loop;
end Initialize_Sources;
--------------------
-- Look_For_Mains --
--------------------
procedure Look_For_Mains is
begin
for FName of The_File_Names loop
declare
Saved_Mains_Length : constant Ada.Containers.Count_Type :=
Mains_Projects_Trees.Length;
Position : Projects_And_Trees_Sets.Cursor :=
Projects_And_Trees_Sets.First (Projects_And_Trees);
Last : constant Projects_And_Trees_Sets.Cursor :=
Projects_And_Trees_Sets.Last (Projects_And_Trees);
use type Projects_And_Trees_Sets.Cursor;
The_PT : Project_And_Tree;
begin
loop
The_PT := Projects_And_Trees_Sets.Element (Position);
-- find the main in the project tree
declare
Source : Source_Id;
The_Tree : constant Project_Tree_Ref := The_PT.Tree;
The_Project : constant Project_Id := The_PT.Project;
Sources : constant Source_Ids :=
Find_All_Sources
(In_Tree => The_Tree,
Project => The_Project,
In_Imported_Only => False,
In_Extended_Only => False,
Base_Name => FName);
begin
for L in Sources'Range loop
Source := Sources (L);
if Source.Language.Config.Kind /= Unit_Based then
Status := Invalid_Main;
return;
elsif Source.Project = The_Project then
Add_To_Mains
(Main => Source,
Project => The_Project,
Tree => The_Tree);
elsif All_Projects then
if not Source.Project.Externally_Built
or else Include_Externally_Built
then
Add_To_Mains
(Main => Source,
Project => The_Project,
Tree => The_Tree);
end if;
end if;
end loop;
end;
exit when Position = Last;
Projects_And_Trees_Sets.Next (Position);
end loop;
if Mains_Projects_Trees.Length = Saved_Mains_Length then
Status := Invalid_Main;
return;
end if;
end;
end loop;
end Look_For_Mains;
-------------
-- Process --
-------------
procedure Process
(Source : Source_Id;
Project : Project_Id;
Tree : Project_Tree_Ref)
is
-- Add Source to the closures, if not there yet, and continue with
-- the sources it imports.
Text : Text_Buffer_Ptr;
Idread : ALI_Id;
First_Unit : Unit_Id;
Last_Unit : Unit_Id;
Unit_Data : Unit_Record;
The_ALI : File_Name_Type;
Added : Boolean;
procedure Find_Unit (Uname : String);
-- Find the sources for this unit name
---------------
-- Find_Unit --
---------------
procedure Find_Unit (Uname : String) is
Iter : Source_Iterator;
Src : Source_Id;
Unit_Name : constant String :=
Uname (Uname'First .. Uname'Last - 2);
Proj : Project_Id;
begin
if All_Projects then
Proj := No_Project;
else
Proj := Project;
end if;
Iter := For_Each_Source
(In_Tree => Tree,
Project => Proj,
Language => Name_Ada,
Encapsulated_Libs => True,
Locally_Removed => False);
loop
Src := Element (Iter);
exit when Src = No_Source;
if Src.Unit /= No_Unit_Index
and then Get_Name_String (Src.Unit.Name) = Unit_Name
then
Process (Src, Src.Project, Tree);
end if;
Next (Iter);
end loop;
end Find_Unit;
begin
-- Nothing to do if the project is externally built and
-- Include_Externally_Built is False.
if Project.Externally_Built and then not Include_Externally_Built then
return;
end if;
Add_To_Closures (Source, Added);
if not Added then
return;
end if;
The_ALI := File_Name_Type (Source.Dep_Path);
if not Processed_ALIs.Get (The_ALI) then
Processed_ALIs.Set (The_ALI, True);
Text := Read_Library_Info (The_ALI);
if Text = null then
Status := Incomplete_Closure;
else
Idread :=
Scan_ALI
(F => The_ALI,
T => Text,
Ignore_ED => False,
Err => True,
Read_Lines => "WD");
Free (Text);
if Idread = No_ALI_Id then
Status := Incomplete_Closure;
else
First_Unit := ALI.ALIs.Table (Idread).First_Unit;
Last_Unit := ALI.ALIs.Table (Idread).Last_Unit;
for Unit in First_Unit .. Last_Unit loop
Unit_Data := ALI.Units.Table (Unit);
if Unit = First_Unit then
declare
Uname : constant String :=
Get_Name_String (Unit_Data.Uname);
begin
Find_Unit (Uname);
-- For a body, check if there are subunits
if Uname (Uname'Last - 1 .. Uname'Last) = "%b" then
for D in ALI.ALIs.Table (Idread).First_Sdep ..
ALI.ALIs.Table (Idread).Last_Sdep
loop
declare
Sdep : constant Sdep_Record :=
ALI.Sdep.Table (D);
begin
if Sdep.Subunit_Name /= No_Name then
declare
Subunit_Name : constant String :=
Get_Name_String
(Sdep.Subunit_Name);
File_Name :
constant File_Name_Type :=
Sdep.Sfile;
Iter : Source_Iterator;
Src : Source_Id;
begin
if
Subunit_Name'Length >=
Uname'Length - 2
and then Subunit_Name
(Subunit_Name'First ..
Subunit_Name'First +
Uname'Length - 3) =
Uname (Uname'First ..
Uname'Last - 2)
and then Subunit_Name
(Subunit_Name'First +
Uname'Length - 2) = '.'
then
-- Add the subunit to the closure
-- First, find the source
Iter := For_Each_Source
(In_Tree => Tree,
Project => Project,
Language => Name_Ada,
Encapsulated_Libs => True,
Locally_Removed => False);
loop
Src := Element (Iter);
exit when Src = No_Source;
exit when Src.File = File_Name;
Next (Iter);
end loop;
-- If the source has been found,
-- add it to the closure.
if Src /= No_Source then
Add_To_Closures (Src, Added);
end if;
end if;
end;
end if;
end;
end loop;
end if;
end;
end if;
for W in Unit_Data.First_With ..
Unit_Data.Last_With
loop
Find_Unit (Get_Name_String (Withs.Table (W).Uname));
end loop;
end loop;
end if;
end if;
end if;
end Process;
begin
Status := Success;
Result := String_Vectors.Empty_Vector;
-- Fail immediately if there are no Mains
if Mains.Is_Empty then
Status := No_Main;
Cleanup;
return;
else
The_File_Names.Clear;
for Src of Mains loop
if Src'Length = 0 then
Status := No_Main;
Cleanup;
return;
else
Name_Len := Src'Length;
Name_Buffer (1 .. Name_Len) := Src;
The_File_Names.Append (Name_Find);
end if;
end loop;
end if;
-- First check if there are any valid project or projects
if Project = No_Project or else In_Tree = No_Project_Tree then
Err.Error_Msg
(Gprbuild_Flags, "Project not found", Token_Ptr,
Project => Project);
Status := Invalid_Project;
Cleanup;
return;
end if;
if Project.Externally_Built then
Err.Error_Msg
(Gprbuild_Flags, "No closures for external projects", Token_Ptr,
Project => Project);
Status := Invalid_Project;
Cleanup;
return;
end if;
case Project.Qualifier is
when Configuration | Abstract_Project =>
Err.Error_Msg
(Gprbuild_Flags, "No closures for abstract or configuration",
Token_Ptr, Project => Project);
Status := Invalid_Project;
Cleanup;
return;
when Standard | Library | Unspecified =>
Add_To_Projects (Project, In_Tree);
when Aggregate | Aggregate_Library =>
if not All_Projects then
Err.Error_Msg
(Gprbuild_Flags, "Aggregate closure must be recursive",
Token_Ptr, Project => Project);
Status := Invalid_Project;
Cleanup;
return;
end if;
Get_Aggregated (Project);
end case;
if Projects_And_Trees.Length = 0 then
Err.Error_Msg
(Gprbuild_Flags, "No projects to closure", Token_Ptr,
Project => Project);
Status := Invalid_Project;
Cleanup;
return;
end if;
-- Initialize the source records for all sources in the project trees
Initialize_Sources;
-- Now that we have the valid project(s), look for the mains
Look_For_Mains;
if Status /= Success then
Cleanup;
return;
end if;
-- Now that we have the main sources, get their closures
Processed_ALIs.Reset;
declare
Position : MPT_Sets.Cursor := MPT_Sets.First (Mains_Projects_Trees);
Last : constant MPT_Sets.Cursor :=
MPT_Sets.Last (Mains_Projects_Trees);
The_MPT : Main_Project_Tree;
use type MPT_Sets.Cursor;
begin
loop
The_MPT := MPT_Sets.Element (Position);
Process (The_MPT.Main, The_MPT.Project, The_MPT.Tree);
exit when Position = Last;
MPT_Sets.Next (Position);
end loop;
end;
for Closure of Closures loop
Result.Append (Closure);
end loop;
Cleanup;
exception
when Ex : others =>
Debug_Output (Ada.Exceptions.Exception_Information (Ex));
Result.Clear;
Status := Unknown_Error;
end Get_Closures;
--------------
-- Get_Line --
--------------
procedure Get_Line
(File : Text_File;
Line : out String;
Last : out Natural)
is
C : Character;
procedure Advance;
-------------
-- Advance --
-------------
procedure Advance is
begin
if File.Cursor = File.Buffer_Len then
File.Buffer_Len :=
Read
(FD => File.FD,
A => File.Buffer'Address,
N => File.Buffer'Length);
if File.Buffer_Len = 0 then
File.End_Of_File_Reached := True;
return;
else
File.Cursor := 1;
end if;
else
File.Cursor := File.Cursor + 1;
end if;
end Advance;
-- Start of processing for Get_Line
begin
if File = null then
GPR.Com.Fail ("Get_Line attempted on an invalid Text_File");
elsif File.Out_File then
GPR.Com.Fail ("Get_Line attempted on an out file");
end if;
Last := Line'First - 1;
if not File.End_Of_File_Reached then
loop
C := File.Buffer (File.Cursor);
exit when C = ASCII.CR or else C = ASCII.LF;
Last := Last + 1;
Line (Last) := C;
Advance;
if File.End_Of_File_Reached then
return;
end if;
exit when Last = Line'Last;
end loop;
if C = ASCII.CR or else C = ASCII.LF then
Advance;
if File.End_Of_File_Reached then
return;
end if;
end if;
if C = ASCII.CR
and then File.Buffer (File.Cursor) = ASCII.LF
then
Advance;
end if;
end if;
end Get_Line;
--------------
-- Get_Line --
--------------
function Get_Line
(File : Text_File; Max_Length : Positive := 4096) return String
is
Result : String (1 .. Max_Length);
Last : Natural;
begin
Get_Line (File, Result, Last);
return Result (1 .. Last);
end Get_Line;
------------------
-- Get_Switches --
------------------
procedure Get_Switches
(Source : GPR.Source_Id;
Pkg_Name : Name_Id;
Project_Tree : Project_Tree_Ref;
Value : out Variable_Value;
Is_Default : out Boolean) is
begin
Get_Switches
(Source_File => Source.File,
Source_Lang => Source.Language.Name,
Source_Prj => Source.Project,
Pkg_Name => Pkg_Name,
Project_Tree => Project_Tree,
Value => Value,
Is_Default => Is_Default);
end Get_Switches;
procedure Get_Switches
(Source_File : File_Name_Type;
Source_Lang : Name_Id;
Source_Prj : Project_Id;
Pkg_Name : Name_Id;
Project_Tree : Project_Tree_Ref;
Value : out Variable_Value;
Is_Default : out Boolean;
Test_Without_Suffix : Boolean := False;
Check_ALI_Suffix : Boolean := False)
is
Project : constant Project_Id :=
Ultimate_Extending_Project_Of (Source_Prj);
Pkg : constant Package_Id :=
GPR.Util.Value_Of
(Name => Pkg_Name,
In_Packages => Project.Decl.Packages,
Shared => Project_Tree.Shared);
Lang : Language_Ptr;
begin
Is_Default := False;
if Source_File /= No_File then
Value := GPR.Util.Value_Of
(Name => Name_Id (Source_File),
Attribute_Or_Array_Name => Name_Switches,
In_Package => Pkg,
Shared => Project_Tree.Shared,
Allow_Wildcards => True);
end if;
if Value = Nil_Variable_Value and then Test_Without_Suffix then
Lang :=
Get_Language_From_Name (Project, Get_Name_String (Source_Lang));
if Lang /= null then
declare
Naming : Lang_Naming_Data renames Lang.Config.Naming_Data;
SF_Name : constant String := Get_Name_String (Source_File);
Last : Positive := SF_Name'Length;
Name : String (1 .. Last + 3);
Spec_Suffix : String := Get_Name_String (Naming.Spec_Suffix);
Body_Suffix : String := Get_Name_String (Naming.Body_Suffix);
Truncated : Boolean := False;
begin
Canonical_Case_File_Name (Spec_Suffix);
Canonical_Case_File_Name (Body_Suffix);
Name (1 .. Last) := SF_Name;
if Last > Body_Suffix'Length
and then
Name (Last - Body_Suffix'Length + 1 .. Last) = Body_Suffix
then
Truncated := True;
Last := Last - Body_Suffix'Length;
end if;
if not Truncated
and then Last > Spec_Suffix'Length
and then
Name (Last - Spec_Suffix'Length + 1 .. Last) = Spec_Suffix
then
Truncated := True;
Last := Last - Spec_Suffix'Length;
end if;
if Truncated then
Value := GPR.Util.Value_Of
(Name => Get_Name_Id (Name (1 .. Last)),
Attribute_Or_Array_Name => Name_Switches,
In_Package => Pkg,
Shared => Project_Tree.Shared,
Allow_Wildcards => True);
end if;
if Value = Nil_Variable_Value and then Check_ALI_Suffix then
Last := SF_Name'Length;
while Name (Last) /= '.' loop
Last := Last - 1;
end loop;
Value := GPR.Util.Value_Of
(Get_Name_Id (Name (1 .. Last) & "ali"),
Attribute_Or_Array_Name => Name_Switches,
In_Package => Pkg,
Shared => Project_Tree.Shared,
Allow_Wildcards => True);
end if;
end;
end if;
end if;
if Value = Nil_Variable_Value then
Is_Default := True;
Value :=
GPR.Util.Value_Of
(Name => Source_Lang,
Attribute_Or_Array_Name => Name_Switches,
In_Package => Pkg,
Shared => Project_Tree.Shared,
Force_Lower_Case_Index => True);
end if;
if Value = Nil_Variable_Value then
Value :=
GPR.Util.Value_Of
(Name => All_Other_Names,
Attribute_Or_Array_Name => Name_Switches,
In_Package => Pkg,
Shared => Project_Tree.Shared,
Force_Lower_Case_Index => True);
end if;
if Value = Nil_Variable_Value then
Value :=
GPR.Util.Value_Of
(Name => Source_Lang,
Attribute_Or_Array_Name => Name_Default_Switches,
In_Package => Pkg,
Shared => Project_Tree.Shared);
end if;
end Get_Switches;
----------------
-- 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;
------------------------------
-- Initialize_Source_Record --
------------------------------
procedure Initialize_Source_Record
(Source : GPR.Source_Id;
Always : Boolean := False)
is
Main_Source_File : File_Name_Type := Source.File;
procedure Set_Object_Project
(Obj_Dir : String;
Obj_Proj : Project_Id;
Obj_Path : Path_Name_Type;
Stamp : Time_Stamp_Type);
-- Update information about object file, switches file,...
------------------------
-- Set_Object_Project --
------------------------
procedure Set_Object_Project
(Obj_Dir : String;
Obj_Proj : Project_Id;
Obj_Path : Path_Name_Type;
Stamp : Time_Stamp_Type) is
begin
Source.Object_Project := Obj_Proj;
Source.Object_Path := Obj_Path;
Source.Object_TS := Stamp;
if Source.Language.Config.Dependency_Kind /= None then
declare
Dep_Path : constant String :=
Normalize_Pathname
(Get_Name_String (Source.Dep_Name),
Resolve_Links => Opt.Follow_Links_For_Files,
Directory => Obj_Dir);
begin
if not Gprls_Mode
or else Obj_Proj.Extends = No_Project
or else Is_Regular_File (Dep_Path)
then
Source.Dep_Path := Create_Name (Dep_Path);
Source.Dep_TS := Unknown_Attributes;
end if;
end;
end if;
-- Get the path of the switches file, even if Opt.Check_Switches is
-- not set, as switch -s may be in the Builder switches that have not
-- been scanned yet.
declare
Switches_Path : constant String :=
Normalize_Pathname
(Get_Name_String (Source.Switches),
Resolve_Links => Opt.Follow_Links_For_Files,
Directory => Obj_Dir);
begin
Source.Switches_Path := Create_Name (Switches_Path);
if Stamp /= Empty_Time_Stamp then
Source.Switches_TS := File_Stamp (Source.Switches_Path);
end if;
end;
end Set_Object_Project;
Obj_Proj : Project_Id;
begin
-- Nothing to do if source record has already been fully initialized
if Source.Initialized and not Always then
return;
end if;
-- Systematically recompute the time stamp
Source.Source_TS := File_Stamp (Source.Path.Display_Name);
-- Parse the source file to check whether we have a subunit
if Source.Language.Config.Kind = Unit_Based
and then Source.Kind = Impl
and then Is_Subunit (Source)
then
Source.Kind := Sep;
end if;
if Source.Language.Config.Object_Generated
and then Is_Compilable (Source)
then
-- First, get the correct object file name and dependency file
if Source.Unit /= No_Unit_Index
and then Source.Kind = Spec
and then Other_Part (Source) /= No_Source
then
Main_Source_File := Other_Part (Source).File;
Source.Object :=
Object_Name
(Main_Source_File, Source.Language.Config.Object_File_Suffix);
Source.Dep_Name :=
Dependency_Name
(Source.Object, Source.Language.Config.Dependency_Kind);
end if;
if Source.Index /= 0 then
Source.Object :=
Object_Name
(Source_File_Name => Main_Source_File,
Source_Index => Source.Index,
Index_Separator =>
Source.Language.Config.Multi_Unit_Object_Separator,
Object_File_Suffix =>
Source.Language.Config.Object_File_Suffix);
Source.Dep_Name :=
Dependency_Name
(Source.Object, Source.Language.Config.Dependency_Kind);
end if;
-- Find the object file for that source. It could be either in the
-- current project or in an extended project (it might actually not
-- exist yet in the ultimate extending project, but if not found
-- elsewhere that's where we'll expect to find it).
Obj_Proj := Source.Project;
while Obj_Proj /= No_Project loop
if Obj_Proj.Object_Directory /= No_Path_Information then
declare
Dir : constant String :=
Get_Name_String (Obj_Proj.Object_Directory.Display_Name);
Object_Path : constant String :=
Normalize_Pathname
(Name => Get_Name_String (Source.Object),
Resolve_Links => Opt.Follow_Links_For_Files,
Directory => Dir);
Obj_Path : constant Path_Name_Type :=
Create_Name (Object_Path);
Stamp : Time_Stamp_Type := Empty_Time_Stamp;
begin
-- For specs, we do not check object files if there is a
-- body. This saves a system call. On the other hand, we do
-- need to know the object_path, in case the user has passed
-- the .ads on the command line to compile the spec only.
if Source.Kind /= Spec
or else Source.Unit = No_Unit_Index
or else Source.Unit.File_Names (Impl) = No_Source
then
Stamp := File_Stamp (Obj_Path);
end if;
if Stamp /= Empty_Time_Stamp
or else (Obj_Proj.Extended_By = No_Project
and then Source.Object_Project = No_Project)
then
Set_Object_Project (Dir, Obj_Proj, Obj_Path, Stamp);
end if;
end;
end if;
Obj_Proj := Obj_Proj.Extended_By;
end loop;
if Source.Language.Config.Dependency_Kind /= None
and then Source.Dep_Path = No_Path
then
-- If we have not found a dependency file in the object
-- project, it means that the Source.Project is extended and that
-- we are in gprls node. We need to look for an actual dependency
-- file in the extended projects. If none is found, the dependency
-- file is set in the ultimate extending project.
Obj_Proj := Source.Project;
while Obj_Proj /= No_Project loop
if Obj_Proj.Object_Directory /= No_Path_Information then
declare
Dir : constant String :=
Get_Name_String
(Obj_Proj.Object_Directory.Display_Name);
Dep_Path_Name : constant String :=
Normalize_Pathname
(Name => Get_Name_String (Source.Dep_Name),
Resolve_Links => Opt.Follow_Links_For_Files,
Directory => Dir);
Dep_Path : constant Path_Name_Type :=
Create_Name (Dep_Path_Name);
Stamp : Time_Stamp_Type := Empty_Time_Stamp;
begin
if Source.Kind /= Spec
or else Source.Unit = No_Unit_Index
or else Source.Unit.File_Names (Impl) = No_Source
then
Stamp := File_Stamp (Dep_Path);
end if;
if Stamp /= Empty_Time_Stamp
or else
(Source.Dep_Path = No_Path
and then Obj_Proj.Extended_By = No_Project)
then
Source.Dep_Path := Dep_Path;
Source.Dep_TS := Unknown_Attributes;
end if;
end;
end if;
Obj_Proj := Obj_Proj.Extended_By;
end loop;
end if;
elsif Source.Language.Config.Dependency_Kind = Makefile then
declare
Object_Dir : constant String :=
Get_Name_String (Source.Project.Object_Directory.Display_Name);
Dep_Path : constant String :=
Normalize_Pathname
(Name => Get_Name_String (Source.Dep_Name),
Resolve_Links => Opt.Follow_Links_For_Files,
Directory => Object_Dir);
begin
Source.Dep_Path := Create_Name (Dep_Path);
Source.Dep_TS := Unknown_Attributes;
end;
end if;
Source.Initialized := True;
end Initialize_Source_Record;
---------------------------------
-- Is_Ada_Predefined_File_Name --
---------------------------------
function Is_Ada_Predefined_File_Name
(Fname : File_Name_Type) return Boolean
is
subtype Str8 is String (1 .. 8);
Predef_Names : constant array (1 .. 12) of Str8 :=
("ada ", -- Ada
"interfac", -- Interfaces
"system ", -- System
"gnat ", -- GNAT
"calendar", -- Calendar
"machcode", -- Machine_Code
"unchconv", -- Unchecked_Conversion
"unchdeal", -- Unchecked_Deallocation
"directio", -- Direct_IO
"ioexcept", -- IO_Exceptions
"sequenio", -- Sequential_IO
"text_io "); -- Text_IO
begin
Get_Name_String (Fname);
-- Remove extension (.ads/.adb) if present
if Name_Len > 4 and then Name_Buffer (Name_Len - 3) = '.' then
Name_Len := Name_Len - 4;
end if;
-- Definitely predefined if prefix is a- i- or s- followed by letter
if Name_Len >= 3
and then Name_Buffer (2) = '-'
and then (Name_Buffer (1) = 'a'
or else
Name_Buffer (1) = 'g'
or else
Name_Buffer (1) = 'i'
or else
Name_Buffer (1) = 's')
and then (Name_Buffer (3) in 'a' .. 'z'
or else
Name_Buffer (3) in 'A' .. 'Z')
then
return True;
-- Definitely false if longer than 12 characters (8.3)
elsif Name_Len > 8 then
return False;
end if;
-- Otherwise check against special list, first padding to 8 characters
while Name_Len < 8 loop
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ' ';
end loop;
for J in Predef_Names'Range loop
if Name_Buffer (1 .. 8) = Predef_Names (J) then
return True;
end if;
end loop;
return False;
end Is_Ada_Predefined_File_Name;
----------------------------
-- Is_Ada_Predefined_Unit --
----------------------------
function Is_Ada_Predefined_Unit (Unit : String) return Boolean is
Lower_Unit : String := Unit;
begin
To_Lower (Lower_Unit);
return Lower_Unit in "ada"
| "gnat"
| "interfaces"
| "system"
| "calendar"
| "machine_code"
| "unchecked_conversion"
| "unchecked_deallocation"
| "direct_io"
| "io_exceptions"
| "sequential_io"
| "text_io"
or else Starts_With (Lower_Unit, "ada.")
or else Starts_With (Lower_Unit, "gnat.")
or else Starts_With (Lower_Unit, "system.")
or else Starts_With (Lower_Unit, "interfaces.");
end Is_Ada_Predefined_Unit;
----------------------------
-- Is_Pragmas_Config_File --
----------------------------
function Is_Pragmas_Config_File (Fname : File_Name_Type) return Boolean is
Filename : constant String := Get_Name_String (Fname);
Pragma_Config_File_Suffix : constant String := ".adc";
E_First : constant Integer :=
Filename'Last - Pragma_Config_File_Suffix'Length + 1;
E_Last : constant Integer := Filename'Last;
begin
if Filename'Length > Pragma_Config_File_Suffix'Length then
return (Filename (E_First .. E_Last) = Pragma_Config_File_Suffix);
else
return False;
end if;
end Is_Pragmas_Config_File;
----------------
-- Is_Subunit --
----------------
function Is_Subunit (Source : GPR.Source_Id) return Boolean is
Src_Ind : Source_File_Index;
begin
if Source.Kind = Sep then
return True;
-- A Spec, a file based language source or a body with a spec cannot be
-- a subunit.
elsif Source.Kind = Spec
or else Source.Unit = No_Unit_Index
or else Other_Part (Source) /= No_Source
then
return False;
end if;
-- Here, we are assuming that the language is Ada, as it is the only
-- unit based language that we know.
pragma Assert
(Source.Path /= No_Path_Information,
"no path information for "
& Get_Name_String (Source.File) & ' ' & Source.Locally_Removed'Img);
Src_Ind :=
Sinput.Load_File (Get_Name_String (Source.Path.Display_Name));
return Sinput.Source_File_Is_Subunit (Src_Ind);
end Is_Subunit;
--------------
-- Is_Valid --
--------------
function Is_Valid (File : Text_File) return Boolean is
begin
return File /= null;
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;
--------------------
-- Object_Project --
--------------------
function Object_Project
(Project : Project_Id;
Must_Be_Writable : Boolean := False) return Project_Id
is
Result : Project_Id := No_Project;
procedure Check_Project (P : Project_Id);
-- Find a project with an object dir
-------------------
-- Check_Project --
-------------------
procedure Check_Project (P : Project_Id) is
begin
if P.Qualifier = Aggregate
or else P.Qualifier = Aggregate_Library
then
declare
List : Aggregated_Project_List := P.Aggregated_Projects;
begin
-- Look for a non aggregate project until one is found
while Result = No_Project and then List /= null loop
Check_Project (List.Project);
List := List.Next;
end loop;
end;
elsif P.Object_Directory.Name /= No_Path then
if not Must_Be_Writable
or else Is_Writable_File
(Get_Name_String (P.Object_Directory.Display_Name))
then
Result := P;
end if;
end if;
end Check_Project;
begin
Check_Project (Project);
return Result;
end Object_Project;
----------
-- Open --
----------
procedure Open (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 := Open_Read (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.Buffer_Len :=
Read (FD => FD,
A => File.Buffer'Address,
N => File.Buffer'Length);
if File.Buffer_Len = 0 then
File.End_Of_File_Reached := True;
else
File.Cursor := 1;
end if;
end if;
end Open;
---------
-- Put --
---------
procedure Put
(Into_List : in out Name_List_Index;
From_List : String_List_Id;
In_Tree : Project_Tree_Ref;
Lower_Case : Boolean := False)
is
Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared;
Current_Name : Name_List_Index;
List : String_List_Id;
Element : String_Element;
Last : Name_List_Index :=
Name_List_Table.Last (Shared.Name_Lists);
Value : Name_Id;
begin
Current_Name := Into_List;
while Current_Name /= No_Name_List
and then Shared.Name_Lists.Table (Current_Name).Next /= No_Name_List
loop
Current_Name := Shared.Name_Lists.Table (Current_Name).Next;
end loop;
List := From_List;
while List /= Nil_String loop
Element := Shared.String_Elements.Table (List);
Value := Element.Value;
if Lower_Case then
Get_Name_String (Value);
To_Lower (Name_Buffer (1 .. Name_Len));
Value := Name_Find;
end if;
Name_List_Table.Append
(Shared.Name_Lists, (Name => Value, Next => No_Name_List));
Last := Last + 1;
if Current_Name = No_Name_List then
Into_List := Last;
else
Shared.Name_Lists.Table (Current_Name).Next := Last;
end if;
Current_Name := Last;
List := Element.Next;
end loop;
end Put;
procedure Put (File : Text_File; S : String) is
Len : Integer;
begin
if File = null then
GPR.Com.Fail ("Attempted to write on an invalid Text_File");
elsif not File.Out_File then
GPR.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
GPR.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.Verbosity_Level > Opt.Low 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.Verbosity_Level > Opt.Low 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=Y" then
Info.Info.Naming_Exception := Yes;
elsif Name_Buffer (1 .. Name_Len) = "N=I" then
Info.Info.Naming_Exception := Inherited;
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;
-------------------
-- Relative_Path --
-------------------
function Relative_Path
(Pathname : String;
To : String;
Directory : Boolean := True) return String
is
function Ensure_Directory (Path : String) return String;
-- Returns Path with an added directory separator if needed
----------------------
-- Ensure_Directory --
----------------------
function Ensure_Directory (Path : String) return String is
begin
if Path'Length = 0 then
return "./";
elsif not Directory or else Is_Directory_Separator (Path (Path'Last))
then
return Path;
else
return Path & Directory_Separator;
end if;
end Ensure_Directory;
-- Local variables
Dir_Sep_Map : constant Character_Mapping := To_Mapping ("\", "/");
P : String (1 .. Pathname'Length) := Pathname;
T : String (1 .. To'Length) := To;
Pi : Natural; -- common prefix ending
N : Natural := 0;
-- Start of processing for Relative_Path
begin
pragma Assert (Is_Absolute_Path (Pathname));
pragma Assert (Is_Absolute_Path (To));
-- Use canonical directory separator
Translate (Source => P, Mapping => Dir_Sep_Map);
Translate (Source => T, Mapping => Dir_Sep_Map);
-- First check for common prefix
Pi := 1;
while Pi < P'Last and then Pi < T'Last and then P (Pi) = T (Pi) loop
Pi := Pi + 1;
end loop;
-- Cut common prefix at a directory separator
while Pi > P'First and then P (Pi) /= '/' loop
Pi := Pi - 1;
end loop;
-- Count directory under prefix in P, these will be replaced by the
-- corresponding number of "..".
N := Ada.Strings.Fixed.Count (T (Pi + 1 .. T'Last), "/");
if T (T'Last) /= '/' then
N := N + 1;
end if;
return N * "../" & Ensure_Directory (P (Pi + 1 .. P'Last));
end Relative_Path;
----------------------
-- Set_Program_Name --
----------------------
procedure Set_Program_Name (N : String) is
begin
Program_Name := new String'(N);
end Set_Program_Name;
-------------------
-- Source_Dir_Of --
-------------------
function Source_Dir_Of (Source : Source_Id) return String is
Path : constant String := Get_Name_String (Source.Path.Name);
begin
return Path (Path'First
.. Path'Last - Natural (Length_Of_Name (Source.File)));
end Source_Dir_Of;
--------------------
-- Source_Info_Of --
--------------------
function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info is
begin
return Iter.Info;
end Source_Info_Of;
-----------
-- Split --
-----------
function Split
(Source : String; Separator : String) return Name_Array_Type
is
Start : Positive := Source'First;
Finish : Positive;
package Name_Ids is new Ada.Containers.Vectors (Positive, Name_Id);
List : Name_Ids.Vector;
procedure Add_String (S : String);
----------------
-- Add_String --
----------------
procedure Add_String (S : String) is
begin
if S'Length > 0 then
List.Append (Get_Name_Id (S));
end if;
end Add_String;
begin
if Separator'Length = 0 or else Index (Source, Separator) = 0 then
-- List with one string = Argument
Add_String (Source);
else
if Index (Source, Separator) = Start then
Start := Start + Separator'Length;
end if;
loop
if Index (Source (Start .. Source'Last), Separator) = 0 then
Add_String (Source (Start .. Source'Last));
exit;
else
Finish := Index (Source (Start .. Source'Last), Separator) - 1;
Add_String (Source (Start .. Finish));
Start := Finish + 1 + Separator'Length;
exit when Start > Source'Last;
end if;
end loop;
end if;
return Result : Name_Array_Type (1 .. Integer (List.Length)) do
for J in Result'Range loop
Result (J) := List.Element (J);
end loop;
end return;
end Split;
-------------------
-- To_Time_Stamp --
-------------------
function To_Time_Stamp
(Time : Calendar.Time) return Stamps.Time_Stamp_Type is
begin
return Time_Stamp_Type (Image (Time, "%Y%m%d%H%M%S"));
end To_Time_Stamp;
----------------------
-- To_UTC_Timestamp --
----------------------
function To_UTC_Time_Stamp
(Time : Calendar.Time) return Stamps.Time_Stamp_Type
is
use type Ada.Calendar.Time;
begin
return To_Time_Stamp (Time - Duration (UTC_Time_Offset (Time)) * 60);
end To_UTC_Time_Stamp;
--------------
-- UTC_Time --
--------------
function UTC_Time return Time_Stamp_Type is
begin
return To_UTC_Time_Stamp (Ada.Calendar.Clock);
end UTC_Time;
--------------
-- Value_Of --
--------------
function Value_Of
(Variable : Variable_Value;
Default : String) return String is
begin
if Variable.Kind /= Single
or else Variable.Default
or else Variable.Value = No_Name
then
return Default;
else
return Get_Name_String (Variable.Value);
end if;
end Value_Of;
function Value_Of
(Index : Name_Id;
In_Array : Array_Element_Id;
Shared : Shared_Project_Tree_Data_Access) return Name_Id
is
Current : Array_Element_Id;
Element : Array_Element;
Real_Index : Name_Id := Index;
begin
Current := In_Array;
if Current = No_Array_Element then
return No_Name;
end if;
Element := Shared.Array_Elements.Table (Current);
if not Element.Index_Case_Sensitive then
Get_Name_String (Index);
To_Lower (Name_Buffer (1 .. Name_Len));
Real_Index := Name_Find;
end if;
while Current /= No_Array_Element loop
Element := Shared.Array_Elements.Table (Current);
if Real_Index = Element.Index then
exit when Element.Value.Kind /= Single;
exit when Element.Value.Value = Empty_String;
return Element.Value.Value;
else
Current := Element.Next;
end if;
end loop;
return No_Name;
end Value_Of;
function Value_Of
(Index : Name_Id;
Src_Index : Int := 0;
In_Array : Array_Element_Id;
Shared : Shared_Project_Tree_Data_Access;
Force_Lower_Case_Index : Boolean := False;
Allow_Wildcards : Boolean := False) return Variable_Value
is
Current : Array_Element_Id;
Element : Array_Element;
Real_Index_1 : Name_Id;
Real_Index_2 : Name_Id;
begin
Current := In_Array;
if Current = No_Array_Element then
return Nil_Variable_Value;
end if;
Element := Shared.Array_Elements.Table (Current);
Real_Index_1 := Index;
if (not Element.Index_Case_Sensitive or else Force_Lower_Case_Index)
and then Index /= All_Other_Names
then
Get_Name_String (Index);
To_Lower (Name_Buffer (1 .. Name_Len));
Real_Index_1 := Name_Find;
end if;
while Current /= No_Array_Element loop
Element := Shared.Array_Elements.Table (Current);
Real_Index_2 := Element.Index;
if (not Element.Index_Case_Sensitive or else Force_Lower_Case_Index)
and then Element.Index /= All_Other_Names
then
Get_Name_String (Element.Index);
To_Lower (Name_Buffer (1 .. Name_Len));
Real_Index_2 := Name_Find;
end if;
if Src_Index = Element.Src_Index
and then
(Real_Index_1 = Real_Index_2
or else (Real_Index_2 /= All_Other_Names
and then Allow_Wildcards
and then
Match
(Get_Name_String (Real_Index_1),
Compile
(Get_Name_String (Real_Index_2), Glob => True))))
then
return Element.Value;
else
Current := Element.Next;
end if;
end loop;
return Nil_Variable_Value;
end Value_Of;
function Value_Of
(Name : Name_Id;
Index : Int := 0;
Attribute_Or_Array_Name : Name_Id;
In_Package : Package_Id;
Shared : Shared_Project_Tree_Data_Access;
Force_Lower_Case_Index : Boolean := False;
Allow_Wildcards : Boolean := False) return Variable_Value
is
The_Array : Array_Element_Id;
The_Attribute : Variable_Value := Nil_Variable_Value;
begin
if In_Package /= No_Package then
-- First, look if there is an array element that fits
The_Array :=
Value_Of
(Name => Attribute_Or_Array_Name,
In_Arrays => Shared.Packages.Table (In_Package).Decl.Arrays,
Shared => Shared);
The_Attribute :=
Value_Of
(Index => Name,
Src_Index => Index,
In_Array => The_Array,
Shared => Shared,
Force_Lower_Case_Index => Force_Lower_Case_Index,
Allow_Wildcards => Allow_Wildcards);
-- If there is no array element, look for a variable
if The_Attribute = Nil_Variable_Value then
The_Attribute :=
Value_Of
(Variable_Name => Attribute_Or_Array_Name,
In_Variables => Shared.Packages.Table
(In_Package).Decl.Attributes,
Shared => Shared);
end if;
end if;
return The_Attribute;
end Value_Of;
function Value_Of
(Index : Name_Id;
In_Array : Name_Id;
In_Arrays : Array_Id;
Shared : Shared_Project_Tree_Data_Access) return Name_Id
is
Current : Array_Id;
The_Array : Array_Data;
begin
Current := In_Arrays;
while Current /= No_Array loop
The_Array := Shared.Arrays.Table (Current);
if The_Array.Name = In_Array then
return Value_Of
(Index, In_Array => The_Array.Value, Shared => Shared);
else
Current := The_Array.Next;
end if;
end loop;
return No_Name;
end Value_Of;
function Value_Of
(Name : Name_Id;
In_Arrays : Array_Id;
Shared : Shared_Project_Tree_Data_Access) return Array_Element_Id
is
Current : Array_Id;
The_Array : Array_Data;
begin
Current := In_Arrays;
while Current /= No_Array loop
The_Array := Shared.Arrays.Table (Current);
if The_Array.Name = Name then
return The_Array.Value;
else
Current := The_Array.Next;
end if;
end loop;
return No_Array_Element;
end Value_Of;
function Value_Of
(Name : Name_Id;
In_Packages : Package_Id;
Shared : Shared_Project_Tree_Data_Access) return Package_Id
is
Current : Package_Id;
The_Package : Package_Element;
begin
Current := In_Packages;
while Current /= No_Package loop
The_Package := Shared.Packages.Table (Current);
exit when The_Package.Name /= No_Name
and then The_Package.Name = Name;
Current := The_Package.Next;
end loop;
return Current;
end Value_Of;
function Value_Of
(Variable_Name : Name_Id;
In_Variables : Variable_Id;
Shared : Shared_Project_Tree_Data_Access) return Variable_Value
is
Current : Variable_Id;
The_Variable : Variable;
begin
Current := In_Variables;
while Current /= No_Variable loop
The_Variable := Shared.Variable_Elements.Table (Current);
if Variable_Name = The_Variable.Name then
return The_Variable.Value;
else
Current := The_Variable.Next;
end if;
end loop;
return Nil_Variable_Value;
end Value_Of;
------------------------
-- Write_Program_Name --
------------------------
procedure Write_Program_Name is
begin
if Program_Name /= null then
Write_Str (Program_Name.all & ": ");
end if;
end Write_Program_Name;
----------------------------
-- Write_Source_Info_File --
----------------------------
procedure Write_Source_Info_File (Tree : Project_Tree_Ref) is
Iter : Source_Iterator := For_Each_Source (Tree);
Source : GPR.Source_Id;
File : Text_File;
begin
if Opt.Verbosity_Level > Opt.Low 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 = Yes then
Put_Line (File, "N=Y");
elsif Source.Naming_Exception = Inherited then
Put_Line (File, "N=I");
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 --
---------------
procedure Write_Str
(S : String;
Max_Length : Positive;
Separator : Character)
is
First : Positive := S'First;
Last : Natural := S'Last;
begin
-- Nothing to do for empty strings
if S'Length > 0 then
-- Start on a new line if current line is already longer than
-- Max_Length.
if Positive (Column) >= Max_Length then
Write_Eol;
end if;
-- If length of remainder is longer than Max_Length, we need to
-- cut the remainder in several lines.
while Positive (Column) + S'Last - First > Max_Length loop
-- Try the maximum length possible
Last := First + Max_Length - Positive (Column);
-- Look for last Separator in the line
while Last >= First and then S (Last) /= Separator loop
Last := Last - 1;
end loop;
-- If we do not find a separator, we output the maximum length
-- possible.
if Last < First then
Last := First + Max_Length - Positive (Column);
end if;
Write_Line (S (First .. Last));
-- Set the beginning of the new remainder
First := Last + 1;
end loop;
-- What is left goes to the buffer, without EOL
Write_Str (S (First .. S'Last));
end if;
end Write_Str;
Libgcc_Subdir_Ptr : Interfaces.C.Strings.chars_ptr;
pragma Import (C, Libgcc_Subdir_Ptr, "__gnat_default_libgcc_subdir");
-- Pointer to string indicating the installation subdirectory where a
-- default shared libgcc might be found.
package Project_Name_Boolean_Htable is new Simple_HTable
(Header_Num => Header_Num,
Element => Boolean,
No_Element => False,
Key => Name_Id,
Hash => Hash,
Equal => "=");
Project_Failure : Project_Name_Boolean_Htable.Instance :=
Project_Name_Boolean_Htable.Nil;
-- Record a boolean for project having failed to compile cleanly
-------------------------------
-- Binder_Exchange_File_Name --
-------------------------------
function Binder_Exchange_File_Name
(Main_Base_Name : File_Name_Type; Prefix : Name_Id) return String_Access
is
File_Name : constant String := Get_Name_String (Main_Base_Name);
begin
Get_Name_String (Prefix);
Add_Str_To_Name_Buffer (File_Name);
Add_Str_To_Name_Buffer (Binder_Exchange_Suffix);
return new String'(Name_Buffer (1 .. Name_Len));
end Binder_Exchange_File_Name;
------------------------------
-- Check_Version_And_Help_G --
------------------------------
-- Common switches for GNU tools
Version_Switch : constant String := "--version";
Help_Switch : constant String := "--help";
procedure Check_Version_And_Help_G
(Tool_Name : String; Initial_Year : String)
is
Version_Switch_Present : Boolean := False;
Help_Switch_Present : Boolean := False;
Next_Arg : Natural;
begin
-- First check for --version or --help
Next_Arg := 1;
while Next_Arg <= Argument_Count loop
declare
Next_Argv : constant String := Argument (Next_Arg);
begin
if Next_Argv = Version_Switch then
Version_Switch_Present := True;
elsif Next_Argv = Help_Switch then
Help_Switch_Present := True;
end if;
Next_Arg := Next_Arg + 1;
end;
end loop;
-- If --version was used, display version and exit
if Version_Switch_Present then
Display_Version (Tool_Name, Initial_Year);
Put_Line (Free_Software);
New_Line;
OS_Exit (0);
end if;
-- If --help was used, display help and exit
if Help_Switch_Present then
Usage;
New_Line;
Put_Line ("Report bugs to report@adacore.com");
OS_Exit (0);
end if;
end Check_Version_And_Help_G;
---------------------
-- Create_Sym_Link --
---------------------
procedure Create_Sym_Link (From, To : String) is
function Symlink
(Oldpath : System.Address;
Newpath : System.Address) return Integer;
pragma Import (C, Symlink, "__gnat_symlink");
C_From : constant String := From & ASCII.NUL;
C_To : constant String :=
Relative_Path
(Containing_Directory (To), Containing_Directory (From))
& Ada.Directories.Simple_Name (To) & ASCII.NUL;
Result : Integer;
Success : Boolean;
pragma Unreferenced (Result);
begin
Delete_File (From, Success);
Result := Symlink (C_To'Address, C_From'Address);
end Create_Sym_Link;
----------------------
-- Create_Sym_Links --
----------------------
procedure Create_Sym_Links
(Lib_Path : String;
Lib_Version : String;
Lib_Dir : String;
Maj_Version : String)
is
function Symlink
(Oldpath : System.Address;
Newpath : System.Address) return Integer;
pragma Import (C, Symlink, "__gnat_symlink");
Version_Path : String_Access;
Success : Boolean;
Result : Integer;
pragma Unreferenced (Result);
begin
Version_Path := new String (1 .. Lib_Version'Length + 1);
Version_Path (1 .. Lib_Version'Length) := Lib_Version;
Version_Path (Version_Path'Last) := ASCII.NUL;
if Maj_Version'Length = 0 then
declare
Newpath : String (1 .. Lib_Path'Length + 1);
begin
Newpath (1 .. Lib_Path'Length) := Lib_Path;
Newpath (Newpath'Last) := ASCII.NUL;
Delete_File (Lib_Path, Success);
Result := Symlink (Version_Path (1)'Address, Newpath'Address);
end;
else
declare
Newpath1 : String (1 .. Lib_Path'Length + 1);
Maj_Path : constant String :=
Lib_Dir & Directory_Separator & Maj_Version;
Newpath2 : String (1 .. Maj_Path'Length + 1);
Maj_Ver : String (1 .. Maj_Version'Length + 1);
begin
Newpath1 (1 .. Lib_Path'Length) := Lib_Path;
Newpath1 (Newpath1'Last) := ASCII.NUL;
Newpath2 (1 .. Maj_Path'Length) := Maj_Path;
Newpath2 (Newpath2'Last) := ASCII.NUL;
Maj_Ver (1 .. Maj_Version'Length) := Maj_Version;
Maj_Ver (Maj_Ver'Last) := ASCII.NUL;
Delete_File (Maj_Path, Success);
Result := Symlink (Version_Path (1)'Address, Newpath2'Address);
Delete_File (Lib_Path, Success);
Result := Symlink (Maj_Ver'Address, Newpath1'Address);
end;
end if;
end Create_Sym_Links;
------------------------------------
-- Display_Usage_Version_And_Help --
------------------------------------
procedure Display_Usage_Version_And_Help is
begin
Put_Line (" --version Display version and exit");
Put_Line (" --help Display usage and exit");
New_Line;
end Display_Usage_Version_And_Help;
---------------------
-- Display_Version --
---------------------
procedure Display_Version
(Tool_Name : String; Initial_Year : String) is
begin
Put_Line (Tool_Name & " " & Gpr_Version_String);
Put ("Copyright (C) ");
Put (Initial_Year);
Put ('-');
Put (Current_Year);
Put (", ");
Put (Copyright_Holder);
New_Line;
end Display_Version;
----------------------
-- Ensure_Directory --
----------------------
function Ensure_Directory (Path : String) return String is
begin
if Path'Length = 0
or else Is_Directory_Separator (Path (Path'Last))
then
return Path;
else
return Path & Directory_Separator;
end if;
end Ensure_Directory;
----------------------
-- Ensure_Extension --
----------------------
function Ensure_Extension (Filename : String; Ext : String) return String is
begin
for Char of reverse Filename loop
if Char = '.' then
return Filename;
elsif Is_Directory_Separator (Char) then
exit;
end if;
end loop;
return Filename & Ext;
end Ensure_Extension;
-------------------
-- Ensure_Suffix --
-------------------
function Ensure_Suffix (Item : String; Suffix : String) return String is
begin
if Item'Length >= Suffix'Length
and then Item (Item'Last - Suffix'Length + 1 .. Item'Last) = Suffix
then
return Item;
else
return Item & Suffix;
end if;
end Ensure_Suffix;
-- ---------------
-- -- Error_Msg --
-- ---------------
--
-- procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
-- pragma Warnings (Off, Msg);
-- pragma Warnings (Off, Flag_Location);
-- begin
-- null;
-- end Error_Msg;
--
-- -----------------
-- -- Error_Msg_S --
-- -----------------
--
-- procedure Error_Msg_S (Msg : String) is
-- pragma Warnings (Off, Msg);
-- begin
-- null;
-- end Error_Msg_S;
--
-- ------------------
-- -- Error_Msg_SC --
-- ------------------
--
-- procedure Error_Msg_SC (Msg : String) is
-- pragma Warnings (Off, Msg);
-- begin
-- null;
-- end Error_Msg_SC;
--
-- ------------------
-- -- Error_Msg_SP --
-- ------------------
--
-- procedure Error_Msg_SP (Msg : String) is
-- pragma Warnings (Off, Msg);
-- begin
-- null;
-- end Error_Msg_SP;
--------------
-- File_MD5 --
--------------
function File_MD5 (Pathname : String) return Message_Digest is
use Stream_IO;
C : Context;
S : Stream_IO.File_Type;
B : Stream_Element_Array (1 .. 100 * 1024);
-- Buffer to read chunk of data
L : Stream_Element_Offset;
begin
Open (S, In_File, Pathname);
while not End_Of_File (S) loop
Read (S, B, L);
Update (C, B (1 .. L));
end loop;
Close (S);
return Digest (C);
end File_MD5;
--------------
-- As_RPath --
--------------
function As_RPath
(Path : String; Case_Sensitive : Boolean) return String
is
Dir_Sep_Map : constant Character_Mapping := To_Mapping ("\", "/");
begin
return Translate
(Normalize_Pathname
(Path,
Resolve_Links => Opt.Follow_Links_For_Dirs,
Case_Sensitive => Case_Sensitive),
Mapping => Dir_Sep_Map);
end As_RPath;
--------------------
-- Relative_RPath --
--------------------
function Relative_RPath (Dest, Src, Origin : String) return String is
-- Rpaths are always considered case sensitive, as it's a runtime
-- property of dynamic objects, so in case of cross compilation is
-- independent of the host's way of handling case sensitivity.
RP_Src : constant String := As_RPath (Src, False);
RP_Dest : constant String := As_RPath (Dest, True);
RP_Dest_Insensitive : constant String := As_RPath (Dest, False);
begin
declare
Len : constant Natural := Common_Path_Prefix_Length
(RP_Src, RP_Dest_Insensitive);
begin
if Len = 0 then
-- No common prefix: return an absolute path
return RP_Dest;
else
declare
Sep_Mode : Boolean := True;
Subdir_Count : Natural := 0;
begin
-- Compute the relative path from Src to Dest. For this we
-- need to find the number of subdirectories from the common
-- prefix to Src.
for I in RP_Src'First + Len .. RP_Src'Last loop
if RP_Src (I) = '/' then
Sep_Mode := True;
elsif Sep_Mode then
-- If the previous characters were separators, we are now
-- reading a new subdir. Sep_Mode is initialy True so
-- that we get here if the first character we see is not
-- a separator.
Subdir_Count := Subdir_Count + 1;
Sep_Mode := False;
end if;
end loop;
return Origin & "/" & Subdir_Count * "../"
& RP_Dest (RP_Dest'First + Len .. RP_Dest'Last);
end;
end if;
end;
end Relative_RPath;
------------------
-- Concat_Paths --
------------------
function Concat_Paths
(List : String_Vectors.Vector;
Separator : String) return String
is
Length : Natural := Natural (List.Length - 1) * Separator'Length;
begin
for Path of List loop
Length := Length + Path'Length;
end loop;
declare
Ret : String (1 .. Length);
Idx : Integer := 1;
begin
for Path of List loop
Ret (Idx .. Idx + Path'Length - 1) := Path;
Idx := Idx + Path'Length;
if Idx < Ret'Last then
Ret (Idx .. Idx + Separator'Length - 1) := Separator;
Idx := Idx + Separator'Length;
end if;
end loop;
return Ret;
end;
end Concat_Paths;
----------------------
-- To_Argument_List --
----------------------
function To_Argument_List
(List : String_Vectors.Vector) return Argument_List
is
Ret : Argument_List (1 .. Natural (List.Length));
begin
for J in 1 .. List.Last_Index loop
Ret (J) := new String'(List (J));
end loop;
return Ret;
end To_Argument_List;
-----------
-- Slice --
-----------
function Slice
(List : String_Vectors.Vector;
From, To : Positive) return String_Vectors.Vector
is
Ret : String_Vectors.Vector;
begin
for J in From .. To loop
Ret.Append (List (J));
end loop;
return Ret;
end Slice;
------------------------------
-- Get_Compiler_Driver_Path --
------------------------------
function Get_Compiler_Driver_Path
(Project : Project_Id;
Lang : Language_Ptr) return String_Access is
begin
if Lang.Config.Compiler_Driver_Path = null then
declare
CL : constant Language_Maps.Cursor :=
Compiler_Subst_HTable.Find (Lang.Name);
Compiler : constant Name_Id :=
(if Language_Maps.Has_Element (CL)
then Language_Maps.Element (CL)
else Name_Id (Lang.Config.Compiler_Driver));
-- If --compiler-subst was used to specify an alternate compiler,
-- then Language_Maps.Has_Element (CL). In other case set Compiler
-- to the Compiler_Driver from the config file.
begin
-- No compiler found, return now
if Compiler = No_Name then
return null;
end if;
declare
Compiler_Name : constant String :=
(if CodePeer_Mode then "codepeer-gcc"
elsif GnatProve_Mode
and then Lang.Name = Name_Ada
then "gnat2why"
else Get_Name_String (Compiler));
begin
if Compiler_Name = "" then
return null;
end if;
Lang.Config.Compiler_Driver_Path :=
Locate_Exec_On_Path (Compiler_Name);
if Lang.Config.Compiler_Driver_Path = null then
Err.Error_Msg
(Gprbuild_Flags,
"unable to locate """ & Compiler_Name & '"',
Project => Project);
return null;
end if;
end;
end;
end if;
return Lang.Config.Compiler_Driver_Path;
end Get_Compiler_Driver_Path;
----------------------------
-- Find_Binding_Languages --
----------------------------
procedure Find_Binding_Languages
(Tree : Project_Tree_Ref;
Root_Project : Project_Id)
is
Data : constant Builder_Data_Access := Builder_Data (Tree);
B_Index : Binding_Data;
Language_Name : Name_Id;
Binder_Driver_Name : File_Name_Type := No_File;
Binder_Driver_Path : String_Access;
Binder_Prefix : Name_Id;
Language : Language_Ptr;
Config : Language_Config;
Project : Project_List;
begin
-- Have we already processed this tree ?
if Data.There_Are_Binder_Drivers
and then Data.Binding /= null
then
return;
end if;
if Current_Verbosity = High then
Debug_Output ("Find_Binding_Languages for", Debug_Name (Tree));
end if;
Data.There_Are_Binder_Drivers := False;
Project := Tree.Projects;
while Project /= null loop
Language := Project.Project.Languages;
while Language /= No_Language_Index loop
Config := Language.Config;
Binder_Driver_Name := Config.Binder_Driver;
if Language.First_Source /= No_Source
and then Binder_Driver_Name /= No_File
then
Data.There_Are_Binder_Drivers := True;
Language_Name := Language.Name;
B_Index := Data.Binding;
while B_Index /= null
and then B_Index.Language_Name /= Language_Name
loop
B_Index := B_Index.Next;
end loop;
if B_Index = null then
Get_Name_String (Binder_Driver_Name);
Binder_Driver_Path :=
Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len));
if Binder_Driver_Path = null then
Fail_Program
(Tree,
"unable to find binder driver " &
Name_Buffer (1 .. Name_Len));
end if;
if Current_Verbosity = High then
Debug_Output
("Binder_Driver=" & Binder_Driver_Path.all
& " for Lang", Language_Name);
end if;
if Config.Binder_Prefix = No_Name then
Binder_Prefix := Empty_String;
else
Binder_Prefix := Config.Binder_Prefix;
end if;
B_Index := Data.Binding;
while B_Index /= null loop
if Binder_Prefix = B_Index.Binder_Prefix then
Fail_Program
(Tree,
"binding prefix cannot be the same for"
& " two languages",
Exit_Code => E_General);
end if;
B_Index := B_Index.Next;
end loop;
Data.Binding := new Binding_Data_Record'
(Language => Language,
Language_Name => Language_Name,
Binder_Driver_Name => Binder_Driver_Name,
Binder_Driver_Path => Binder_Driver_Path,
Binder_Prefix => Binder_Prefix,
Next => Data.Binding);
end if;
end if;
Language := Language.Next;
end loop;
Project := Project.Next;
end loop;
if Root_Project.Qualifier = Aggregate then
declare
Agg : Aggregated_Project_List := Root_Project.Aggregated_Projects;
begin
while Agg /= null loop
Find_Binding_Languages (Agg.Tree, Agg.Project);
Agg := Agg.Next;
end loop;
end;
end if;
end Find_Binding_Languages;
----------------
-- Get_Target --
----------------
function Get_Target return String is
begin
if Target_Name = null or else Target_Name.all = "" then
return Sdefault.Hostname;
else
return Target_Name.all;
end if;
end Get_Target;
--------------------
-- Locate_Runtime --
--------------------
procedure Locate_Runtime
(Project_Tree : Project_Tree_Ref;
Language : Name_Id)
is
function Is_RTS_Directory (Path : String) return Boolean;
-- Returns True if Path is a directory for a runtime. This simply check
-- that Path has a "adalib" subdirectoy, which is a property for
-- runtimes on the project path.
function Is_Base_Name (Path : String) return Boolean;
-- Returns True if Path has no directory separator
----------------------
-- Is_RTS_Directory --
----------------------
function Is_RTS_Directory (Path : String) return Boolean is
begin
return Is_Directory (Path & Directory_Separator & "adalib");
end Is_RTS_Directory;
-- Local declarations
function Find_Rts_In_Path is new GPR.Env.Find_Name_In_Path
(Check_Filename => Is_RTS_Directory);
------------------
-- Is_Base_Name --
------------------
function Is_Base_Name (Path : String) return Boolean is
begin
for I in Path'Range loop
if Is_Directory_Separator (Path (I)) then
return False;
end if;
end loop;
return True;
end Is_Base_Name;
RTS_Name : constant String := GPR.Conf.Runtime_Name_For (Language);
Full_Path : String_Access;
begin
Full_Path := Find_Rts_In_Path (Root_Environment.Project_Path, RTS_Name);
if Full_Path /= null then
GPR.Conf.Set_Runtime_For
(Language, Normalize_Pathname (Full_Path.all));
Free (Full_Path);
elsif not Is_Base_Name (RTS_Name) then
Fail_Program
(Project_Tree, "cannot find RTS " & RTS_Name,
Exit_Code => E_General);
end if;
end Locate_Runtime;
------------------------------
-- Look_For_Default_Project --
------------------------------
procedure Look_For_Default_Project (Never_Fail : Boolean := False) is
begin
if No_Project_File then
No_Project_File_Found := True;
else
No_Project_File_Found := False;
if Is_Regular_File (Default_Project_File_Name) then
Project_File_Name := new String'(Default_Project_File_Name);
else
-- Check if there is a single project file in the current
-- directory. If there is one and only one, use it.
declare
Dir : Dir_Type;
Str : String (1 .. 255);
Last : Natural;
Single : String_Access := null;
begin
No_Project_File_Found := True;
Open (Dir, ".");
loop
Read (Dir, Str, Last);
exit when Last = 0;
if Last > Project_File_Extension'Length
and then Is_Regular_File (Str (1 .. Last))
then
Canonical_Case_File_Name (Str (1 .. Last));
if Str (Last - Project_File_Extension'Length + 1 .. Last)
= Project_File_Extension
then
No_Project_File_Found := False;
if Single = null then
Single := new String'(Str (1 .. Last));
else
-- There are several project files in the current
-- directory. Reset Single to null and exit.
Single := null;
exit;
end if;
end if;
end if;
end loop;
Close (Dir);
Project_File_Name := Single;
end;
end if;
end if;
if No_Project_File_Found or else
(Never_Fail and then Project_File_Name = null)
then
Project_File_Name :=
new String'(Executable_Prefix_Path & Implicit_Project_File_Path);
if not Is_Regular_File (Project_File_Name.all) then
Project_File_Name := null;
end if;
end if;
if not Quiet_Output and then Project_File_Name /= null then
Put ("using project file ");
Put_Line (Project_File_Name.all);
end if;
end Look_For_Default_Project;
-------------------
-- Major_Id_Name --
-------------------
function Major_Id_Name
(Lib_Filename : String;
Lib_Version : String)
return String
is
Maj_Version : constant String := Lib_Version;
Last_Maj : Positive;
Last : Positive;
Ok_Maj : Boolean := False;
begin
Last_Maj := Maj_Version'Last;
while Last_Maj > Maj_Version'First loop
if Maj_Version (Last_Maj) in '0' .. '9' then
Last_Maj := Last_Maj - 1;
else
Ok_Maj := Last_Maj /= Maj_Version'Last and then
Maj_Version (Last_Maj) = '.';
if Ok_Maj then
Last_Maj := Last_Maj - 1;
end if;
exit;
end if;
end loop;
if Ok_Maj then
Last := Last_Maj;
while Last > Maj_Version'First loop
if Maj_Version (Last) in '0' .. '9' then
Last := Last - 1;
else
Ok_Maj := Last /= Last_Maj and then
Maj_Version (Last) = '.';
if Ok_Maj then
Last := Last - 1;
Ok_Maj :=
Maj_Version (Maj_Version'First .. Last) = Lib_Filename;
end if;
exit;
end if;
end loop;
end if;
if Ok_Maj then
return Maj_Version (Maj_Version'First .. Last_Maj);
else
return "";
end if;
end Major_Id_Name;
------------------
-- Partial_Name --
------------------
function Partial_Name
(Lib_Name : String;
Number : Natural;
Object_Suffix : String) return String
is
Img : constant String := Number'Img;
begin
return
Partial_Prefix & Lib_Name &
'_' & Img (Img'First + 1 .. Img'Last)
& Object_Suffix;
end Partial_Name;
------------------------
-- Put_Resource_Usage --
------------------------
procedure Put_Resource_Usage (Filename : String) is separate;
--------------------------------
-- Project_Compilation_Failed --
--------------------------------
function Project_Compilation_Failed
(Prj : Project_Id;
Recursive : Boolean := True) return Boolean
is
use Project_Name_Boolean_Htable;
begin
if Get (Project_Failure, Prj.Name) then
return True;
elsif not Recursive then
return False;
else
-- Check all imported projects directly or indirectly
declare
Plist : Project_List := Prj.All_Imported_Projects;
begin
while Plist /= null loop
if Get (Project_Failure, Plist.Project.Name) then
return True;
else
Plist := Plist.Next;
end if;
end loop;
return False;
end;
end if;
end Project_Compilation_Failed;
-----------------------------------
-- Set_Failed_Compilation_Status --
-----------------------------------
procedure Set_Failed_Compilation_Status (Prj : Project_Id) is
begin
Project_Name_Boolean_Htable.Set (Project_Failure, Prj.Name, True);
end Set_Failed_Compilation_Status;
-----------------------
-- Shared_Libgcc_Dir --
-----------------------
function Shared_Libgcc_Dir (Run_Time_Dir : String) return String is
Path : String (1 .. Run_Time_Dir'Length + 15);
Path_Last : constant Natural := Run_Time_Dir'Length;
GCC_Index : Natural := 0;
begin
Path (1 .. Path_Last) := Run_Time_Dir;
GCC_Index := Index (Path (1 .. Path_Last), "gcc-lib");
if GCC_Index /= 0 then
-- This is gcc 2.8.2: the shared version of libgcc is
-- located in the parent directory of "gcc-lib".
GCC_Index := GCC_Index - 1;
else
GCC_Index := Index (Path (1 .. Path_Last), "/lib/");
if GCC_Index = 0 then
GCC_Index :=
Index
(Path (1 .. Path_Last),
Directory_Separator & "lib" & Directory_Separator);
end if;
if GCC_Index /= 0 then
-- We have found "lib" as a subdirectory in the runtime dir path.
-- The
declare
Subdir : constant String :=
Interfaces.C.Strings.Value (Libgcc_Subdir_Ptr);
begin
Path
(GCC_Index + 1 ..
GCC_Index + Subdir'Length) :=
Subdir;
GCC_Index :=
GCC_Index + Subdir'Length;
end;
end if;
end if;
return Path (1 .. GCC_Index);
end Shared_Libgcc_Dir;
---------------------
-- Need_To_Compile --
---------------------
procedure Need_To_Compile
(Source : GPR.Source_Id;
Tree : Project_Tree_Ref;
In_Project : Project_Id;
Conf_Paths : Config_Paths;
Must_Compile : out Boolean;
The_ALI : out ALI.ALI_Id;
Object_Check : Boolean;
Always_Compile : Boolean)
is
Source_Path : constant String :=
Get_Name_String (Source.Path.Display_Name);
C_Source_Path : constant String :=
Get_Name_String (Source.Path.Name);
Runtime_Source_Dirs : constant Name_List_Index :=
Source.Language.Config.Runtime_Source_Dirs;
Stamp : Time_Stamp_Type;
Source_In_Dependencies : Boolean := False;
-- Set True if source was found in dependency file of its object file
C_Object_Name : String_Access := null;
-- The canonical file name for the object file
Switches_Name : String_Access := null;
-- The file name of the file that contains the switches that were used
-- in the last compilation.
Num_Ext : Natural;
-- Number of extending projects
ALI_Project : Project_Id;
-- If the ALI file is in the object directory of a project, this is
-- the project id.
Externally_Built : constant Boolean := In_Project.Externally_Built;
-- True if the project of the source is externally built
Processed : Name_Id_Set.Set;
-- Source files processed for ALI_Closure mode
function Process_Makefile_Deps
(Dep_Name, Obj_Dir : String) return Boolean;
function Process_ALI_Deps
(Source : Source_Id; Closure : Boolean) return Boolean;
-- Process the dependencies for the current source file for the various
-- dependency modes.
-- They return True if the file needs to be recompiled.
procedure Cleanup;
-- Cleanup local variables
function Check_Object_File (Source : Source_Id) return Boolean;
-- Check object file exists and consistent with source file
function Check_Time_Stamps
(Path : String; Stamp : Time_Stamp_Type) return Boolean;
-----------------------
-- Check_Object_File --
-----------------------
function Check_Object_File (Source : Source_Id) return Boolean is
function Obj_Path return String is
(Get_Name_String (Source.Object_Path));
begin
-- If object file does not exist, of course source needs to be
-- compiled.
if Source.Object_TS = Empty_Time_Stamp then
Source.Object_TS := File_Stamp (Obj_Path);
end if;
if Source.Object_TS = Empty_Time_Stamp then
if Opt.Verbosity_Level > Opt.Low then
Put (" -> object file ");
Put (Obj_Path);
Put_Line (" does not exist");
end if;
return False;
end if;
-- If the object file has been created before the last modification
-- of the source, the source needs to be recompiled.
if not Opt.Minimal_Recompilation
and then Source.Object_TS < Source.Source_TS
then
if Opt.Verbosity_Level > Opt.Low then
Put (" -> object file ");
Put (Obj_Path);
Put_Line (" has time stamp earlier than source");
end if;
return False;
end if;
if Opt.Verbosity_Level > Opt.Low and then Debug.Debug_Flag_T then
Put (" object file ");
Put (Obj_Path);
Put (": ");
Put_Line (String (Source.Object_TS));
Put (" source file: ");
Put_Line (String (Source.Source_TS));
end if;
return True;
end Check_Object_File;
-----------------------
-- Check_Time_Stamps --
-----------------------
function Check_Time_Stamps
(Path : String; Stamp : Time_Stamp_Type) return Boolean
is
TS : constant Time_Stamp_Type := File_Stamp (Get_Path_Name_Id (Path));
begin
if TS /= Empty_Time_Stamp and then TS /= Stamp then
if Opt.Verbosity_Level > Opt.Low then
Put_Line (" -> different time stamp for " & Path);
if Debug.Debug_Flag_T then
Put_Line (" in ALI file: " & String (Stamp));
Put_Line (" actual file: " & String (TS));
end if;
end if;
return True;
end if;
return False;
end Check_Time_Stamps;
---------------------------
-- Process_Makefile_Deps --
---------------------------
function Process_Makefile_Deps
(Dep_Name, Obj_Dir : String) return Boolean
is
Dep_File : GPR.Util.Text_File;
Last_Source : String_Access;
Last_TS : Time_Stamp_Type := Empty_Time_Stamp;
Last_Obj : Natural;
Start : Natural;
Finish : Natural;
Looping : Boolean := False;
-- Set to True at the end of the first Big_Loop for Makefile
-- fragments
function Is_Time_Stamp (S : String) return Boolean;
-- Return True iff S has the format of a Time_Stamp_Type
OK : Boolean;
-------------------
-- Is_Time_Stamp --
-------------------
function Is_Time_Stamp (S : String) return Boolean is
Result : Boolean := False;
begin
if S'Length = Time_Stamp_Length then
Result := True;
for J in S'Range loop
if S (J) not in '0' .. '9' then
Result := False;
exit;
end if;
end loop;
end if;
return Result;
end Is_Time_Stamp;
begin
Open (Dep_File, Dep_Name);
-- If dependency file cannot be open, we need to recompile
-- the source.
if not Is_Valid (Dep_File) then
if Opt.Verbosity_Level > Opt.Low then
Put (" -> could not open dependency file ");
Put_Line (Dep_Name);
end if;
return True;
end if;
-- Loop Big_Loop is executed several times only when the
-- dependency file contains several times
--