with Fmap; use Fmap;
with Gnatvsn; use Gnatvsn;
with Hostparm;
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
with Sdefault; use Sdefault;
with Table;
with System.Case_Util; use System.Case_Util;
with Unchecked_Conversion;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.HTable;
package body Osint is
Running_Program : Program_Type := Unspecified;
Program_Set : Boolean := False;
Std_Prefix : String_Ptr;
Empty : aliased String := "";
No_Dir : constant String_Ptr := Empty'Access;
function Append_Suffix_To_File_Name
(Name : Name_Id;
Suffix : String) return Name_Id;
function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type;
function Concat (String_One : String; String_Two : String) return String;
function Executable_Prefix return String_Ptr;
function Update_Path (Path : String_Ptr) return String_Ptr;
procedure Write_With_Check (A : Address; N : Integer);
function Locate_File
(N : File_Name_Type;
T : File_Type;
Dir : Natural;
Name : String) return File_Name_Type;
function C_String_Length (S : Address) return Integer;
function To_Path_String_Access
(Path_Addr : Address;
Path_Len : Integer) return String_Access;
EOL : constant Character := ASCII.LF;
Number_File_Names : Int := 0;
Look_In_Primary_Directory_For_Current_Main : Boolean := False;
Current_Full_Source_Name : File_Name_Type := No_File;
Current_Full_Source_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
Current_Full_Lib_Name : File_Name_Type := No_File;
Current_Full_Lib_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
Current_Full_Obj_Name : File_Name_Type := No_File;
Current_Full_Obj_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
Primary_Directory : constant := 0;
package Src_Search_Directories is new Table.Table (
Table_Component_Type => String_Ptr,
Table_Index_Type => Natural,
Table_Low_Bound => Primary_Directory,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Osint.Src_Search_Directories");
package Lib_Search_Directories is new Table.Table (
Table_Component_Type => String_Ptr,
Table_Index_Type => Natural,
Table_Low_Bound => Primary_Directory,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Osint.Lib_Search_Directories");
File_Cache_Enabled : Boolean := False;
type File_Hash_Num is range 0 .. 1020;
function File_Hash (F : File_Name_Type) return File_Hash_Num;
package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable (
Header_Num => File_Hash_Num,
Element => File_Name_Type,
No_Element => No_File,
Key => File_Name_Type,
Hash => File_Hash,
Equal => "=");
package File_Stamp_Hash_Table is new GNAT.HTable.Simple_HTable (
Header_Num => File_Hash_Num,
Element => Time_Stamp_Type,
No_Element => Empty_Time_Stamp,
Key => File_Name_Type,
Hash => File_Hash,
Equal => "=");
function Smart_Find_File
(N : File_Name_Type;
T : File_Type) return File_Name_Type;
function Smart_File_Stamp
(N : File_Name_Type;
T : File_Type) return Time_Stamp_Type;
procedure Add_Default_Search_Dirs is
Search_Dir : String_Access;
Search_Path : String_Access;
Path_File_Name : String_Access;
procedure Add_Search_Dir
(Search_Dir : String;
Additional_Source_Dir : Boolean);
procedure Add_Search_Dir
(Search_Dir : String_Access;
Additional_Source_Dir : Boolean);
procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean);
function Get_Libraries_From_Registry return String_Ptr;
procedure Add_Search_Dir
(Search_Dir : String;
Additional_Source_Dir : Boolean)
is
begin
if Additional_Source_Dir then
Add_Src_Search_Dir (Search_Dir);
else
Add_Lib_Search_Dir (Search_Dir);
end if;
end Add_Search_Dir;
procedure Add_Search_Dir
(Search_Dir : String_Access;
Additional_Source_Dir : Boolean)
is
begin
if Additional_Source_Dir then
Add_Src_Search_Dir (Search_Dir.all);
else
Add_Lib_Search_Dir (Search_Dir.all);
end if;
end Add_Search_Dir;
procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean) is
File_FD : File_Descriptor;
Buffer : String (1 .. Path_File_Name'Length + 1);
Len : Natural;
Actual_Len : Natural;
S : String_Access;
Curr : Natural;
First : Natural;
Ch : Character;
Status : Boolean;
begin
Buffer (1 .. Buffer'Last - 1) := Path_File_Name.all;
Buffer (Buffer'Last) := ASCII.NUL;
File_FD := Open_Read (Buffer'Address, Binary);
if File_FD = Invalid_FD then
return;
end if;
Len := Integer (File_Length (File_FD));
S := new String (1 .. Len);
Curr := 1;
Actual_Len := Len;
while Curr <= Len and then Actual_Len /= 0 loop
Actual_Len := Read (File_FD, S (Curr)'Address, Len);
Curr := Curr + Actual_Len;
end loop;
Close (File_FD, Status);
First := 1;
Curr := 0;
while Curr < Len loop
Ch := S (Curr + 1);
if Ch = ASCII.CR or else Ch = ASCII.LF
or else Ch = ASCII.FF or else Ch = ASCII.VT
then
if First <= Curr then
Add_Search_Dir (S (First .. Curr), Additional_Source_Dir);
end if;
First := Curr + 2;
end if;
Curr := Curr + 1;
end loop;
if First <= S'Last then
Add_Search_Dir (S (First .. S'Last), Additional_Source_Dir);
end if;
end Get_Dirs_From_File;
function Get_Libraries_From_Registry return String_Ptr is
function C_Get_Libraries_From_Registry return Address;
pragma Import (C, C_Get_Libraries_From_Registry,
"__gnat_get_libraries_from_registry");
function Strlen (Str : Address) return Integer;
pragma Import (C, Strlen, "strlen");
procedure Strncpy (X : Address; Y : Address; Length : Integer);
pragma Import (C, Strncpy, "strncpy");
Result_Ptr : Address;
Result_Length : Integer;
Out_String : String_Ptr;
begin
Result_Ptr := C_Get_Libraries_From_Registry;
Result_Length := Strlen (Result_Ptr);
Out_String := new String (1 .. Result_Length);
Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
return Out_String;
end Get_Libraries_From_Registry;
begin
for Additional_Source_Dir in False .. True loop
if Additional_Source_Dir then
Search_Path := Getenv (Ada_Include_Path);
if Search_Path'Length > 0 then
if Hostparm.OpenVMS then
Search_Path := To_Canonical_Path_Spec ("ADA_INCLUDE_PATH:");
else
Search_Path := To_Canonical_Path_Spec (Search_Path.all);
end if;
end if;
else
Search_Path := Getenv (Ada_Objects_Path);
if Search_Path'Length > 0 then
if Hostparm.OpenVMS then
Search_Path := To_Canonical_Path_Spec ("ADA_OBJECTS_PATH:");
else
Search_Path := To_Canonical_Path_Spec (Search_Path.all);
end if;
end if;
end if;
Get_Next_Dir_In_Path_Init (Search_Path);
loop
Search_Dir := Get_Next_Dir_In_Path (Search_Path);
exit when Search_Dir = null;
Add_Search_Dir (Search_Dir, Additional_Source_Dir);
end loop;
end loop;
Path_File_Name := Getenv (Project_Include_Path_File);
if Path_File_Name'Length > 0 then
Get_Dirs_From_File (Additional_Source_Dir => True);
end if;
Path_File_Name := Getenv (Project_Objects_Path_File);
if Path_File_Name'Length > 0 then
Get_Dirs_From_File (Additional_Source_Dir => False);
end if;
if RTS_Src_Path_Name /= null and then
RTS_Lib_Path_Name /= null
then
Add_Search_Dirs (RTS_Src_Path_Name, Include);
Add_Search_Dirs (RTS_Lib_Path_Name, Objects);
else
if not Opt.No_Stdinc then
Search_Path := String_Access (Get_Libraries_From_Registry);
Get_Next_Dir_In_Path_Init (Search_Path);
loop
Search_Dir := Get_Next_Dir_In_Path (Search_Path);
exit when Search_Dir = null;
Add_Search_Dir (Search_Dir, False);
Add_Search_Dir (Search_Dir, True);
end loop;
Search_Path :=
Read_Default_Search_Dirs
(String_Access (Update_Path (Search_Dir_Prefix)),
Include_Search_File,
String_Access (Update_Path (Include_Dir_Default_Name)));
Get_Next_Dir_In_Path_Init (Search_Path);
loop
Search_Dir := Get_Next_Dir_In_Path (Search_Path);
exit when Search_Dir = null;
Add_Search_Dir (Search_Dir, True);
end loop;
end if;
if not Opt.No_Stdlib and not Opt.RTS_Switch then
Search_Path :=
Read_Default_Search_Dirs
(String_Access (Update_Path (Search_Dir_Prefix)),
Objects_Search_File,
String_Access (Update_Path (Object_Dir_Default_Name)));
Get_Next_Dir_In_Path_Init (Search_Path);
loop
Search_Dir := Get_Next_Dir_In_Path (Search_Path);
exit when Search_Dir = null;
Add_Search_Dir (Search_Dir, False);
end loop;
end if;
end if;
end Add_Default_Search_Dirs;
procedure Add_File (File_Name : String; Index : Int := No_Index) is
begin
Number_File_Names := Number_File_Names + 1;
if Number_File_Names > File_Names'Last then
File_Names := new File_Name_Array'(File_Names.all & File_Names.all);
File_Indexes :=
new File_Index_Array'(File_Indexes.all & File_Indexes.all);
end if;
File_Names (Number_File_Names) := new String'(File_Name);
File_Indexes (Number_File_Names) := Index;
end Add_File;
procedure Add_Lib_Search_Dir (Dir : String) is
begin
if Dir'Length = 0 then
Fail ("missing library directory name");
end if;
Lib_Search_Directories.Increment_Last;
Lib_Search_Directories.Table (Lib_Search_Directories.Last) :=
Normalize_Directory_Name (Dir);
end Add_Lib_Search_Dir;
procedure Add_Search_Dirs
(Search_Path : String_Ptr;
Path_Type : Search_File_Type)
is
Current_Search_Path : String_Access;
begin
Get_Next_Dir_In_Path_Init (String_Access (Search_Path));
loop
Current_Search_Path :=
Get_Next_Dir_In_Path (String_Access (Search_Path));
exit when Current_Search_Path = null;
if Path_Type = Include then
Add_Src_Search_Dir (Current_Search_Path.all);
else
Add_Lib_Search_Dir (Current_Search_Path.all);
end if;
end loop;
end Add_Search_Dirs;
procedure Add_Src_Search_Dir (Dir : String) is
begin
if Dir'Length = 0 then
Fail ("missing source directory name");
end if;
Src_Search_Directories.Increment_Last;
Src_Search_Directories.Table (Src_Search_Directories.Last) :=
Normalize_Directory_Name (Dir);
end Add_Src_Search_Dir;
function Append_Suffix_To_File_Name
(Name : Name_Id;
Suffix : String) return Name_Id
is
begin
Get_Name_String (Name);
Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
Name_Len := Name_Len + Suffix'Length;
return Name_Find;
end Append_Suffix_To_File_Name;
function C_String_Length (S : Address) return Integer is
function Strlen (S : Address) return Integer;
pragma Import (C, Strlen, "strlen");
begin
if S = Null_Address then
return 0;
else
return Strlen (S);
end if;
end C_String_Length;
procedure Canonical_Case_File_Name (S : in out String) is
begin
if not File_Names_Case_Sensitive then
for J in S'Range loop
if S (J) in 'A' .. 'Z' then
S (J) := Character'Val (
Character'Pos (S (J)) +
Character'Pos ('a') -
Character'Pos ('A'));
end if;
end loop;
end if;
end Canonical_Case_File_Name;
function Concat (String_One : String; String_Two : String) return String is
Buffer : String (1 .. String_One'Length + String_Two'Length);
begin
Buffer (1 .. String_One'Length) := String_One;
Buffer (String_One'Length + 1 .. Buffer'Last) := String_Two;
return Buffer;
end Concat;
procedure Create_File_And_Check
(Fdesc : out File_Descriptor;
Fmode : Mode)
is
begin
Output_File_Name := Name_Enter;
Fdesc := Create_File (Name_Buffer'Address, Fmode);
if Fdesc = Invalid_FD then
Fail ("Cannot create: ", Name_Buffer (1 .. Name_Len));
end if;
end Create_File_And_Check;
function Current_File_Index return Int is
begin
return File_Indexes (Current_File_Name_Index);
end Current_File_Index;
function Current_Library_File_Stamp return Time_Stamp_Type is
begin
return Current_Full_Lib_Stamp;
end Current_Library_File_Stamp;
function Current_Object_File_Stamp return Time_Stamp_Type is
begin
return Current_Full_Obj_Stamp;
end Current_Object_File_Stamp;
function Current_Source_File_Stamp return Time_Stamp_Type is
begin
return Current_Full_Source_Stamp;
end Current_Source_File_Stamp;
function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is
begin
if Opt.Look_In_Primary_Dir then
return
Lib_Search_Directories.Table (Primary_Directory + Position - 1);
else
return Lib_Search_Directories.Table (Primary_Directory + Position);
end if;
end Dir_In_Obj_Search_Path;
function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is
begin
if Opt.Look_In_Primary_Dir then
return
Src_Search_Directories.Table (Primary_Directory + Position - 1);
else
return Src_Search_Directories.Table (Primary_Directory + Position);
end if;
end Dir_In_Src_Search_Path;
function Executable_Name (Name : File_Name_Type) return File_Name_Type is
Exec_Suffix : String_Access;
begin
if Name = No_File then
return No_File;
end if;
Get_Name_String (Name);
Exec_Suffix := Get_Executable_Suffix;
for J in Exec_Suffix'Range loop
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Exec_Suffix (J);
end loop;
Free (Exec_Suffix);
return Name_Enter;
end Executable_Name;
function Executable_Prefix return String_Ptr is
function Get_Install_Dir (Exec : String) return String_Ptr;
function Get_Install_Dir (Exec : String) return String_Ptr is
begin
for J in reverse Exec'Range loop
if Is_Directory_Separator (Exec (J)) then
if J < Exec'Last - 5 then
if (To_Lower (Exec (J + 1)) = 'l'
and then To_Lower (Exec (J + 2)) = 'i'
and then To_Lower (Exec (J + 3)) = 'b')
or else
(To_Lower (Exec (J + 1)) = 'b'
and then To_Lower (Exec (J + 2)) = 'i'
and then To_Lower (Exec (J + 3)) = 'n')
then
return new String'(Exec (Exec'First .. J));
end if;
end if;
end if;
end loop;
return new String'("");
end Get_Install_Dir;
begin
if Exec_Name = null then
Exec_Name := new String (1 .. Len_Arg (0));
Osint.Fill_Arg (Exec_Name (1)'Address, 0);
end if;
for J in reverse Exec_Name'Range loop
if Is_Directory_Separator (Exec_Name (J)) then
return Get_Install_Dir (Exec_Name.all);
end if;
end loop;
return Get_Install_Dir
(GNAT.OS_Lib.Locate_Exec_On_Path (Exec_Name.all).all);
end Executable_Prefix;
procedure Exit_Program (Exit_Code : Exit_Code_Type) is
begin
case Exit_Code is
when E_Success => OS_Exit (0);
when E_Warnings => OS_Exit (0);
when E_No_Compile => OS_Exit (1);
when E_Fatal => OS_Exit (4);
when E_Errors => OS_Exit (5);
when E_No_Code => OS_Exit (6);
when E_Abort => OS_Abort;
end case;
end Exit_Program;
procedure Fail (S1 : String; S2 : String := ""; S3 : String := "") is
begin
Set_Standard_Error;
Osint.Write_Program_Name;
Write_Str (": ");
Write_Str (S1);
Write_Str (S2);
Write_Str (S3);
Write_Eol;
Exit_Program (E_Fatal);
end Fail;
function File_Hash (F : File_Name_Type) return File_Hash_Num is
begin
return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
end File_Hash;
function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
begin
if Name = No_File then
return Empty_Time_Stamp;
end if;
Get_Name_String (Name);
if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
return Empty_Time_Stamp;
else
Name_Buffer (Name_Len + 1) := ASCII.NUL;
return OS_Time_To_GNAT_Time (File_Time_Stamp (Name_Buffer));
end if;
end File_Stamp;
function Find_File
(N : File_Name_Type;
T : File_Type) return File_Name_Type
is
begin
Get_Name_String (N);
declare
File_Name : String renames Name_Buffer (1 .. Name_Len);
File : File_Name_Type := No_File;
Last_Dir : Natural;
begin
if T = Config
or else (Debug_Generated_Code
and then Name_Len > 3
and then
(Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg"
or else
(Hostparm.OpenVMS and then
Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg")))
then
return N;
elsif Look_In_Primary_Directory_For_Current_Main
and then Current_Main = N
then
return Locate_File (N, T, Primary_Directory, File_Name);
else
File := Mapped_Path_Name (N);
if File /= No_File then
if File = Error_Name then
return No_File;
else
return File;
end if;
end if;
if Opt.Look_In_Primary_Dir then
File := Locate_File (N, T, Primary_Directory, File_Name);
if File /= No_File then
return File;
end if;
end if;
if T = Library then
Last_Dir := Lib_Search_Directories.Last;
else
Last_Dir := Src_Search_Directories.Last;
end if;
for D in Primary_Directory + 1 .. Last_Dir loop
File := Locate_File (N, T, D, File_Name);
if File /= No_File then
return File;
end if;
end loop;
return No_File;
end if;
end;
end Find_File;
procedure Find_Program_Name is
Command_Name : String (1 .. Len_Arg (0));
Cindex1 : Integer := Command_Name'First;
Cindex2 : Integer := Command_Name'Last;
begin
Fill_Arg (Command_Name'Address, 0);
for J in reverse Cindex1 .. Cindex2 loop
if Is_Directory_Separator (Command_Name (J)) then
Cindex1 := J + 1;
exit;
end if;
end loop;
if Command_Name (Cindex2) in '0' .. '9' then
for J in reverse Cindex1 .. Cindex2 loop
if Command_Name (J) = '.' or Command_Name (J) = ';' then
Cindex2 := J - 1;
exit;
end if;
exit when Command_Name (J) not in '0' .. '9';
end loop;
end if;
if Cindex2 - Cindex1 >= 4 then
if To_Lower (Command_Name (Cindex2 - 3)) = '.'
and then To_Lower (Command_Name (Cindex2 - 2)) = 'e'
and then To_Lower (Command_Name (Cindex2 - 1)) = 'x'
and then To_Lower (Command_Name (Cindex2)) = 'e'
then
Cindex2 := Cindex2 - 4;
end if;
end if;
Name_Len := Cindex2 - Cindex1 + 1;
Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
end Find_Program_Name;
function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
begin
return Find_File (N, Library);
end Full_Lib_File_Name;
function Full_Library_Info_Name return File_Name_Type is
begin
return Current_Full_Lib_Name;
end Full_Library_Info_Name;
function Full_Object_File_Name return File_Name_Type is
begin
return Current_Full_Obj_Name;
end Full_Object_File_Name;
function Full_Source_Name return File_Name_Type is
begin
return Current_Full_Source_Name;
end Full_Source_Name;
function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
begin
return Smart_Find_File (N, Source);
end Full_Source_Name;
function Get_Directory (Name : File_Name_Type) return File_Name_Type is
begin
Get_Name_String (Name);
for J in reverse 1 .. Name_Len loop
if Is_Directory_Separator (Name_Buffer (J)) then
Name_Len := J;
return Name_Find;
end if;
end loop;
Name_Len := Hostparm.Normalized_CWD'Length;
Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
return Name_Find;
end Get_Directory;
Search_Path_Pos : Integer;
function Get_Next_Dir_In_Path
(Search_Path : String_Access) return String_Access
is
Lower_Bound : Positive := Search_Path_Pos;
Upper_Bound : Positive;
begin
loop
while Lower_Bound <= Search_Path'Last
and then Search_Path.all (Lower_Bound) = Path_Separator
loop
Lower_Bound := Lower_Bound + 1;
end loop;
exit when Lower_Bound > Search_Path'Last;
Upper_Bound := Lower_Bound;
while Upper_Bound <= Search_Path'Last
and then Search_Path.all (Upper_Bound) /= Path_Separator
loop
Upper_Bound := Upper_Bound + 1;
end loop;
Search_Path_Pos := Upper_Bound;
return new String'(Search_Path.all (Lower_Bound .. Upper_Bound - 1));
end loop;
return null;
end Get_Next_Dir_In_Path;
procedure Get_Next_Dir_In_Path_Init (Search_Path : String_Access) is
begin
Search_Path_Pos := Search_Path'First;
end Get_Next_Dir_In_Path_Init;
function Get_Primary_Src_Search_Directory return String_Ptr is
begin
return Src_Search_Directories.Table (Primary_Directory);
end Get_Primary_Src_Search_Directory;
function Get_RTS_Search_Dir
(Search_Dir : String;
File_Type : Search_File_Type) return String_Ptr
is
procedure Get_Current_Dir
(Dir : System.Address;
Length : System.Address);
pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
Max_Path : Integer;
pragma Import (C, Max_Path, "__gnat_max_path_len");
Current_Dir : String_Ptr;
Default_Search_Dir : String_Access;
Default_Suffix_Dir : String_Access;
Local_Search_Dir : String_Access;
Norm_Search_Dir : String_Access;
Result_Search_Dir : String_Access;
Search_File : String_Access;
Temp_String : String_Ptr;
begin
if Search_Dir (Search_Dir'Last) /= Directory_Separator then
Local_Search_Dir := new String'
(Concat (Search_Dir, String'(1 => Directory_Separator)));
else
Local_Search_Dir := new String'(Search_Dir);
end if;
if File_Type = Include then
Search_File := Include_Search_File;
Default_Suffix_Dir := new String'("adainclude");
else
Search_File := Objects_Search_File;
Default_Suffix_Dir := new String'("adalib");
end if;
Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all);
if Is_Absolute_Path (Norm_Search_Dir.all) then
Result_Search_Dir
:= Read_Default_Search_Dirs (Norm_Search_Dir,
Search_File,
null);
Default_Search_Dir := new String'
(Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all));
Free (Norm_Search_Dir);
if Result_Search_Dir /= null then
return String_Ptr (Result_Search_Dir);
elsif Is_Directory (Default_Search_Dir.all) then
return String_Ptr (Default_Search_Dir);
else
return null;
end if;
else
declare
Buffer : String (1 .. Max_Path + 2);
Path_Len : Natural := Max_Path;
begin
Get_Current_Dir (Buffer'Address, Path_Len'Address);
if Buffer (Path_Len) /= Directory_Separator then
Path_Len := Path_Len + 1;
Buffer (Path_Len) := Directory_Separator;
end if;
Current_Dir := new String'(Buffer (1 .. Path_Len));
end;
Norm_Search_Dir :=
new String'(Concat (Current_Dir.all, Local_Search_Dir.all));
Result_Search_Dir :=
Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
Default_Search_Dir :=
new String'
(Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all));
Free (Norm_Search_Dir);
if Result_Search_Dir /= null then
return String_Ptr (Result_Search_Dir);
elsif Is_Directory (Default_Search_Dir.all) then
return String_Ptr (Default_Search_Dir);
else
Norm_Search_Dir :=
new String'
(Concat (Update_Path (Search_Dir_Prefix).all,
Local_Search_Dir.all));
Result_Search_Dir :=
Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
Default_Search_Dir :=
new String'
(Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all));
Free (Norm_Search_Dir);
if Result_Search_Dir /= null then
return String_Ptr (Result_Search_Dir);
elsif Is_Directory (Default_Search_Dir.all) then
return String_Ptr (Default_Search_Dir);
else
Temp_String :=
new String'
(Concat (Update_Path (Search_Dir_Prefix).all, "rts-"));
Norm_Search_Dir :=
new String'(Concat (Temp_String.all, Local_Search_Dir.all));
Result_Search_Dir :=
Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
Default_Search_Dir :=
new String'
(Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all));
Free (Norm_Search_Dir);
if Result_Search_Dir /= null then
return String_Ptr (Result_Search_Dir);
elsif Is_Directory (Default_Search_Dir.all) then
return String_Ptr (Default_Search_Dir);
else
return null;
end if;
end if;
end if;
end if;
end Get_RTS_Search_Dir;
function Include_Dir_Default_Prefix return String is
Include_Dir : String_Access :=
String_Access (Update_Path (Include_Dir_Default_Name));
begin
if Include_Dir = null then
return "";
else
declare
Result : constant String := Include_Dir.all;
begin
Free (Include_Dir);
return Result;
end;
end if;
end Include_Dir_Default_Prefix;
procedure Initialize is
begin
Number_File_Names := 0;
Current_File_Name_Index := 0;
Src_Search_Directories.Init;
Lib_Search_Directories.Init;
Suppress_Options := (others => False);
Src_Search_Directories.Set_Last (Primary_Directory);
Src_Search_Directories.Table (Primary_Directory) := new String'("");
Lib_Search_Directories.Set_Last (Primary_Directory);
Lib_Search_Directories.Table (Primary_Directory) := new String'("");
end Initialize;
function Is_Directory_Separator (C : Character) return Boolean is
begin
return
C = Directory_Separator
or else C = '/'
or else (Hostparm.OpenVMS
and then (C = ']' or else C = ':'));
end Is_Directory_Separator;
function Is_Readonly_Library (File : in File_Name_Type) return Boolean is
begin
Get_Name_String (File);
pragma Assert (Name_Buffer (Name_Len - 3 .. Name_Len) = ".ali");
return not Is_Writable_File (Name_Buffer (1 .. Name_Len));
end Is_Readonly_Library;
function Lib_File_Name
(Source_File : File_Name_Type;
Munit_Index : Nat := 0) return File_Name_Type
is
begin
Get_Name_String (Source_File);
for J in reverse 2 .. Name_Len loop
if Name_Buffer (J) = '.' then
Name_Len := J - 1;
exit;
end if;
end loop;
if Munit_Index /= 0 then
Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
Add_Nat_To_Name_Buffer (Munit_Index);
end if;
Add_Char_To_Name_Buffer ('.');
Add_Str_To_Name_Buffer (ALI_Suffix.all);
return Name_Find;
end Lib_File_Name;
function Library_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
begin
return File_Stamp (Find_File (N, Library));
end Library_File_Stamp;
function Locate_File
(N : File_Name_Type;
T : File_Type;
Dir : Natural;
Name : String) return File_Name_Type
is
Dir_Name : String_Ptr;
begin
if Is_Absolute_Path (Name) then
Dir_Name := No_Dir;
elsif T = Library then
Dir_Name := Lib_Search_Directories.Table (Dir);
else pragma Assert (T /= Config);
Dir_Name := Src_Search_Directories.Table (Dir);
end if;
declare
Full_Name : String (1 .. Dir_Name'Length + Name'Length);
begin
Full_Name (1 .. Dir_Name'Length) := Dir_Name.all;
Full_Name (Dir_Name'Length + 1 .. Full_Name'Length) := Name;
if not Is_Regular_File (Full_Name) then
return No_File;
else
if Dir_Name'Length = 0 then
return N;
else
Name_Len := Full_Name'Length;
Name_Buffer (1 .. Name_Len) := Full_Name;
return Name_Enter;
end if;
end if;
end;
end Locate_File;
function Matching_Full_Source_Name
(N : File_Name_Type;
T : Time_Stamp_Type) return File_Name_Type
is
begin
Get_Name_String (N);
declare
File_Name : constant String := Name_Buffer (1 .. Name_Len);
File : File_Name_Type := No_File;
Last_Dir : Natural;
begin
if Opt.Look_In_Primary_Dir then
File := Locate_File (N, Source, Primary_Directory, File_Name);
if File /= No_File and then T = File_Stamp (N) then
return File;
end if;
end if;
Last_Dir := Src_Search_Directories.Last;
for D in Primary_Directory + 1 .. Last_Dir loop
File := Locate_File (N, Source, D, File_Name);
if File /= No_File and then T = File_Stamp (File) then
return File;
end if;
end loop;
return No_File;
end;
end Matching_Full_Source_Name;
function More_Files return Boolean is
begin
return (Current_File_Name_Index < Number_File_Names);
end More_Files;
function Nb_Dir_In_Obj_Search_Path return Natural is
begin
if Opt.Look_In_Primary_Dir then
return Lib_Search_Directories.Last - Primary_Directory + 1;
else
return Lib_Search_Directories.Last - Primary_Directory;
end if;
end Nb_Dir_In_Obj_Search_Path;
function Nb_Dir_In_Src_Search_Path return Natural is
begin
if Opt.Look_In_Primary_Dir then
return Src_Search_Directories.Last - Primary_Directory + 1;
else
return Src_Search_Directories.Last - Primary_Directory;
end if;
end Nb_Dir_In_Src_Search_Path;
function Next_Main_File return File_Name_Type is
File_Name : String_Ptr;
Dir_Name : String_Ptr;
Fptr : Natural;
begin
pragma Assert (More_Files);
Current_File_Name_Index := Current_File_Name_Index + 1;
File_Name := File_Names (Current_File_Name_Index);
Fptr := File_Name'First;
for J in reverse File_Name'Range loop
if File_Name (J) = Directory_Separator
or else File_Name (J) = '/'
then
if J = File_Name'Last then
Fail ("File name missing");
end if;
Fptr := J + 1;
exit;
end if;
end loop;
Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1));
case Running_Program is
when Compiler =>
Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
Look_In_Primary_Directory_For_Current_Main := True;
when Make =>
Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
if Fptr > File_Name'First then
Look_In_Primary_Directory_For_Current_Main := True;
end if;
when Binder | Gnatls =>
Dir_Name := Normalize_Directory_Name (Dir_Name.all);
Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
when Unspecified =>
null;
end case;
Name_Len := File_Name'Last - Fptr + 1;
Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
Current_Main := File_Name_Type (Name_Find);
if Running_Program = Make then
declare
Orig_Main : constant File_Name_Type := Current_Main;
begin
if Strip_Suffix (Orig_Main) = Orig_Main then
Current_Main := Append_Suffix_To_File_Name (Orig_Main, ".adb");
if Full_Source_Name (Current_Main) = No_File then
Current_Main :=
Append_Suffix_To_File_Name (Orig_Main, ".ads");
if Full_Source_Name (Current_Main) = No_File then
Current_Main := Orig_Main;
end if;
end if;
end if;
end;
end if;
return Current_Main;
end Next_Main_File;
function Normalize_Directory_Name (Directory : String) return String_Ptr is
function Is_Quoted (Path : String) return Boolean;
pragma Inline (Is_Quoted);
function Is_Quoted (Path : String) return Boolean is
First : constant Character := Path (Path'First);
Last : constant Character := Path (Path'Last);
begin
if (First = ''' and then Last = ''')
or else
(First = '"' and then Last = '"')
then
return True;
else
return False;
end if;
end Is_Quoted;
Result : String_Ptr;
begin
if Directory'Length = 0 then
Result := new String'(Hostparm.Normalized_CWD);
elsif Is_Directory_Separator (Directory (Directory'Last)) then
Result := new String'(Directory);
elsif Is_Quoted (Directory) then
Result := new String (1 .. Directory'Length - 1);
Result (1 .. Directory'Length - 1) :=
Directory (Directory'First + 1 .. Directory'Last - 1);
Result (Result'Last) := Directory_Separator;
else
Result := new String (1 .. Directory'Length + 1);
Result (1 .. Directory'Length) := Directory;
Result (Directory'Length + 1) := Directory_Separator;
end if;
return Result;
end Normalize_Directory_Name;
function Number_Of_Files return Int is
begin
return Number_File_Names;
end Number_Of_Files;
function Object_Dir_Default_Prefix return String is
Object_Dir : String_Access :=
String_Access (Update_Path (Object_Dir_Default_Name));
begin
if Object_Dir = null then
return "";
else
declare
Result : constant String := Object_Dir.all;
begin
Free (Object_Dir);
return Result;
end;
end if;
end Object_Dir_Default_Prefix;
function Object_File_Name (N : File_Name_Type) return File_Name_Type is
begin
if N = No_File then
return No_File;
end if;
Get_Name_String (N);
Name_Len := Name_Len - ALI_Suffix'Length - 1;
for J in Object_Suffix'Range loop
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Object_Suffix (J);
end loop;
return Name_Enter;
end Object_File_Name;
function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
GNAT_Time : Time_Stamp_Type;
Y : Year_Type;
Mo : Month_Type;
D : Day_Type;
H : Hour_Type;
Mn : Minute_Type;
S : Second_Type;
begin
GM_Split (T, Y, Mo, D, H, Mn, S);
Make_Time_Stamp
(Year => Nat (Y),
Month => Nat (Mo),
Day => Nat (D),
Hour => Nat (H),
Minutes => Nat (Mn),
Seconds => Nat (S),
TS => GNAT_Time);
return GNAT_Time;
end OS_Time_To_GNAT_Time;
function Program_Name (Nam : String) return String_Access is
Res : String_Access;
begin
Find_Program_Name;
while Name_Len > 0 loop
if Name_Buffer (Name_Len) = '-' then
exit;
elsif Is_Directory_Separator (Name_Buffer (Name_Len)) then
Name_Len := 0;
exit;
end if;
Name_Len := Name_Len - 1;
end loop;
Res := new String (1 .. Name_Len + Nam'Length);
Res.all (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
Res.all (Name_Len + 1 .. Name_Len + Nam'Length) := Nam;
return Res;
end Program_Name;
function Read_Default_Search_Dirs
(Search_Dir_Prefix : String_Access;
Search_File : String_Access;
Search_Dir_Default_Name : String_Access) return String_Access
is
Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1);
File_FD : File_Descriptor;
S, S1 : String_Access;
Len : Integer;
Curr : Integer;
Actual_Len : Integer;
J1 : Integer;
Prev_Was_Separator : Boolean;
Nb_Relative_Dir : Integer;
function Is_Relative (S : String; K : Positive) return Boolean;
pragma Inline (Is_Relative);
function Is_Relative (S : String; K : Positive) return Boolean is
begin
return not Is_Absolute_Path (S (K .. S'Last));
end Is_Relative;
begin
Buffer (1 .. Search_Dir_Prefix.all'Length)
:= Search_Dir_Prefix.all;
Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1)
:= Search_File.all;
Buffer (Buffer'Last) := ASCII.NUL;
File_FD := Open_Read (Buffer'Address, Binary);
if File_FD = Invalid_FD then
return Search_Dir_Default_Name;
end if;
Len := Integer (File_Length (File_FD));
S := new String (1 .. Len + 1);
S (Len + 1) := Path_Separator;
Curr := 1;
Actual_Len := Len;
while Actual_Len /= 0 loop
Actual_Len := Read (File_FD, S (Curr)'Address, Len);
Curr := Curr + Actual_Len;
end loop;
Prev_Was_Separator := True;
Nb_Relative_Dir := 0;
for J in 1 .. Len loop
if S (J) in ASCII.NUL .. ASCII.US
or else S (J) = ' '
then
S (J) := Path_Separator;
end if;
if S (J) = Path_Separator then
Prev_Was_Separator := True;
else
if Prev_Was_Separator and then Is_Relative (S.all, J) then
Nb_Relative_Dir := Nb_Relative_Dir + 1;
end if;
Prev_Was_Separator := False;
end if;
end loop;
if Nb_Relative_Dir = 0 then
return S;
end if;
S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len);
J1 := 1;
Prev_Was_Separator := True;
for J in 1 .. Len + 1 loop
if S (J) = Path_Separator then
Prev_Was_Separator := True;
else
if Prev_Was_Separator and then Is_Relative (S.all, J) then
S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all;
J1 := J1 + Prefix_Len;
end if;
Prev_Was_Separator := False;
end if;
S1 (J1) := S (J);
J1 := J1 + 1;
end loop;
Free (S);
return S1;
end Read_Default_Search_Dirs;
function Read_Library_Info
(Lib_File : File_Name_Type;
Fatal_Err : Boolean := False) return Text_Buffer_Ptr
is
Lib_FD : File_Descriptor;
Text : Text_Buffer_Ptr;
Status : Boolean;
begin
Current_Full_Lib_Name := Find_File (Lib_File, Library);
Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name);
if Current_Full_Lib_Name = No_File then
if Fatal_Err then
Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
else
Current_Full_Obj_Stamp := Empty_Time_Stamp;
return null;
end if;
end if;
Get_Name_String (Current_Full_Lib_Name);
Name_Buffer (Name_Len + 1) := ASCII.NUL;
Lib_FD := Open_Read (Name_Buffer'Address, Binary);
if Lib_FD = Invalid_FD then
if Fatal_Err then
Fail ("Cannot open: ", Name_Buffer (1 .. Name_Len));
else
Current_Full_Obj_Stamp := Empty_Time_Stamp;
return null;
end if;
end if;
if Opt.Check_Object_Consistency then
Current_Full_Lib_Stamp := File_Stamp (Current_Full_Lib_Name);
Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name);
if Current_Full_Obj_Stamp (1) = ' ' then
if Is_Readonly_Library (Current_Full_Lib_Name) then
Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
elsif Fatal_Err then
Get_Name_String (Current_Full_Obj_Name);
Close (Lib_FD, Status);
Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
else
Current_Full_Obj_Stamp := Empty_Time_Stamp;
Close (Lib_FD, Status);
return null;
end if;
end if;
end if;
declare
Len : constant Integer := Integer (File_Length (Lib_FD));
Actual_Len : Integer := 0;
Lo : constant Text_Ptr := 0;
Hi : Text_Ptr := Text_Ptr (Len);
begin
Text := new Text_Buffer (Lo .. Hi);
Hi := Lo;
loop
Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len);
Hi := Hi + Text_Ptr (Actual_Len);
exit when Actual_Len = Len or Actual_Len <= 0;
end loop;
Text (Hi) := EOF;
end;
Close (Lib_FD, Status);
return Text;
end Read_Library_Info;
procedure Read_Source_File
(N : File_Name_Type;
Lo : Source_Ptr;
Hi : out Source_Ptr;
Src : out Source_Buffer_Ptr;
T : File_Type := Source)
is
Source_File_FD : File_Descriptor;
Len : Integer;
Actual_Len : Integer;
Status : Boolean;
begin
Current_Full_Source_Name := Find_File (N, T);
Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
if Current_Full_Source_Name = No_File then
if N = Current_Main then
Get_Name_String (N);
Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
end if;
Src := null;
Hi := No_Location;
return;
end if;
Get_Name_String (Current_Full_Source_Name);
Name_Buffer (Name_Len + 1) := ASCII.NUL;
Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
if Source_File_FD = Invalid_FD then
Src := null;
Hi := No_Location;
return;
end if;
Len := Integer (File_Length (Source_File_FD));
Hi := Lo + Source_Ptr (Len);
declare
subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
type Actual_Source_Ptr is access Actual_Source_Buffer;
Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
begin
Hi := Lo;
loop
Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
Hi := Hi + Source_Ptr (Actual_Len);
exit when Actual_Len = Len or Actual_Len <= 0;
end loop;
Actual_Ptr (Hi) := EOF;
declare
pragma Suppress (All_Checks);
pragma Warnings (Off);
function To_Source_Buffer_Ptr is new
Unchecked_Conversion (Address, Source_Buffer_Ptr);
pragma Warnings (On);
begin
Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
end;
end;
Close (Source_File_FD, Status);
end Read_Source_File;
function Relocate_Path
(Prefix : String;
Path : String) return String_Ptr
is
S : String_Ptr;
procedure set_std_prefix (S : String; Len : Integer);
pragma Import (C, set_std_prefix);
begin
if Std_Prefix = null then
Std_Prefix := Executable_Prefix;
if Std_Prefix.all /= "" then
set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1);
end if;
end if;
if Path (Prefix'Range) = Prefix then
if Std_Prefix.all /= "" then
S := new String
(1 .. Std_Prefix'Length + Path'Last - Prefix'Last);
S (1 .. Std_Prefix'Length) := Std_Prefix.all;
S (Std_Prefix'Length + 1 .. S'Last) :=
Path (Prefix'Last + 1 .. Path'Last);
return S;
end if;
end if;
return new String'(Path);
end Relocate_Path;
procedure Set_Program (P : Program_Type) is
begin
if Program_Set then
Fail ("Set_Program called twice");
end if;
Program_Set := True;
Running_Program := P;
end Set_Program;
function Shared_Lib (Name : String) return String is
Library : String (1 .. Name'Length + Library_Version'Length + 3);
begin
Library (1 .. 2) := "-l";
Library (3 .. 2 + Name'Length) := Name;
Library (3 + Name'Length) := '-';
Library (4 + Name'Length .. Library'Last) := Library_Version;
if Hostparm.OpenVMS then
for K in Library'First + 2 .. Library'Last loop
if Library (K) = '.' or else Library (K) = '-' then
Library (K) := '_';
end if;
end loop;
end if;
return Library;
end Shared_Lib;
function Smart_File_Stamp
(N : File_Name_Type;
T : File_Type) return Time_Stamp_Type
is
Time_Stamp : Time_Stamp_Type;
begin
if not File_Cache_Enabled then
return File_Stamp (Find_File (N, T));
end if;
Time_Stamp := File_Stamp_Hash_Table.Get (N);
if Time_Stamp (1) = ' ' then
Time_Stamp := File_Stamp (Smart_Find_File (N, T));
File_Stamp_Hash_Table.Set (N, Time_Stamp);
end if;
return Time_Stamp;
end Smart_File_Stamp;
function Smart_Find_File
(N : File_Name_Type;
T : File_Type) return File_Name_Type
is
Full_File_Name : File_Name_Type;
begin
if not File_Cache_Enabled then
return Find_File (N, T);
end if;
Full_File_Name := File_Name_Hash_Table.Get (N);
if Full_File_Name = No_File then
Full_File_Name := Find_File (N, T);
File_Name_Hash_Table.Set (N, Full_File_Name);
end if;
return Full_File_Name;
end Smart_Find_File;
procedure Source_File_Data (Cache : Boolean) is
begin
File_Cache_Enabled := Cache;
end Source_File_Data;
function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
begin
return Smart_File_Stamp (N, Source);
end Source_File_Stamp;
function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
begin
Get_Name_String (Name);
for J in reverse 1 .. Name_Len - 1 loop
if Is_Directory_Separator (Name_Buffer (J)) then
Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
Name_Len := Name_Len - J;
return Name_Find;
end if;
end loop;
return Name;
end Strip_Directory;
function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
begin
Get_Name_String (Name);
for J in reverse 2 .. Name_Len loop
if Name_Buffer (J) = '.' then
Name_Len := J - 1;
return Name_Enter;
end if;
end loop;
return Name;
end Strip_Suffix;
function To_Canonical_Dir_Spec
(Host_Dir : String;
Prefix_Style : Boolean) return String_Access
is
function To_Canonical_Dir_Spec
(Host_Dir : Address;
Prefix_Flag : Integer) return Address;
pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
C_Host_Dir : String (1 .. Host_Dir'Length + 1);
Canonical_Dir_Addr : Address;
Canonical_Dir_Len : Integer;
begin
C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir;
C_Host_Dir (C_Host_Dir'Last) := ASCII.NUL;
if Prefix_Style then
Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1);
else
Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
end if;
Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);
if Canonical_Dir_Len = 0 then
return null;
else
return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len);
end if;
exception
when others =>
Fail ("erroneous directory spec: ", Host_Dir);
return null;
end To_Canonical_Dir_Spec;
function To_Canonical_File_List
(Wildcard_Host_File : String;
Only_Dirs : Boolean) return String_Access_List_Access
is
function To_Canonical_File_List_Init
(Host_File : Address;
Only_Dirs : Integer) return Integer;
pragma Import (C, To_Canonical_File_List_Init,
"__gnat_to_canonical_file_list_init");
function To_Canonical_File_List_Next return Address;
pragma Import (C, To_Canonical_File_List_Next,
"__gnat_to_canonical_file_list_next");
procedure To_Canonical_File_List_Free;
pragma Import (C, To_Canonical_File_List_Free,
"__gnat_to_canonical_file_list_free");
Num_Files : Integer;
C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
begin
C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
Wildcard_Host_File;
C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
Num_Files := To_Canonical_File_List_Init
(C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
declare
Canonical_File_List : String_Access_List (1 .. Num_Files);
Canonical_File_Addr : Address;
Canonical_File_Len : Integer;
begin
for J in 1 .. Num_Files loop
Canonical_File_Addr := To_Canonical_File_List_Next;
Canonical_File_Len := C_String_Length (Canonical_File_Addr);
Canonical_File_List (J) := To_Path_String_Access
(Canonical_File_Addr, Canonical_File_Len);
end loop;
To_Canonical_File_List_Free;
return new String_Access_List'(Canonical_File_List);
end;
end To_Canonical_File_List;
function To_Canonical_File_Spec
(Host_File : String) return String_Access
is
function To_Canonical_File_Spec (Host_File : Address) return Address;
pragma Import
(C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
C_Host_File : String (1 .. Host_File'Length + 1);
Canonical_File_Addr : Address;
Canonical_File_Len : Integer;
begin
C_Host_File (1 .. Host_File'Length) := Host_File;
C_Host_File (C_Host_File'Last) := ASCII.NUL;
Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address);
Canonical_File_Len := C_String_Length (Canonical_File_Addr);
if Canonical_File_Len = 0 then
return null;
else
return To_Path_String_Access
(Canonical_File_Addr, Canonical_File_Len);
end if;
exception
when others =>
Fail ("erroneous file spec: ", Host_File);
return null;
end To_Canonical_File_Spec;
function To_Canonical_Path_Spec
(Host_Path : String) return String_Access
is
function To_Canonical_Path_Spec (Host_Path : Address) return Address;
pragma Import
(C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec");
C_Host_Path : String (1 .. Host_Path'Length + 1);
Canonical_Path_Addr : Address;
Canonical_Path_Len : Integer;
begin
C_Host_Path (1 .. Host_Path'Length) := Host_Path;
C_Host_Path (C_Host_Path'Last) := ASCII.NUL;
Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address);
Canonical_Path_Len := C_String_Length (Canonical_Path_Addr);
return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len);
exception
when others =>
Fail ("erroneous path spec: ", Host_Path);
return null;
end To_Canonical_Path_Spec;
function To_Host_Dir_Spec
(Canonical_Dir : String;
Prefix_Style : Boolean) return String_Access
is
function To_Host_Dir_Spec
(Canonical_Dir : Address;
Prefix_Flag : Integer) return Address;
pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
Host_Dir_Addr : Address;
Host_Dir_Len : Integer;
begin
C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir;
C_Canonical_Dir (C_Canonical_Dir'Last) := ASCII.NUL;
if Prefix_Style then
Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1);
else
Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0);
end if;
Host_Dir_Len := C_String_Length (Host_Dir_Addr);
if Host_Dir_Len = 0 then
return null;
else
return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len);
end if;
end To_Host_Dir_Spec;
function To_Host_File_Spec
(Canonical_File : String) return String_Access
is
function To_Host_File_Spec (Canonical_File : Address) return Address;
pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
C_Canonical_File : String (1 .. Canonical_File'Length + 1);
Host_File_Addr : Address;
Host_File_Len : Integer;
begin
C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File;
C_Canonical_File (C_Canonical_File'Last) := ASCII.NUL;
Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address);
Host_File_Len := C_String_Length (Host_File_Addr);
if Host_File_Len = 0 then
return null;
else
return To_Path_String_Access
(Host_File_Addr, Host_File_Len);
end if;
end To_Host_File_Spec;
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
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;
function Update_Path (Path : String_Ptr) return String_Ptr is
function C_Update_Path (Path, Component : Address) return Address;
pragma Import (C, C_Update_Path, "update_path");
function Strlen (Str : Address) return Integer;
pragma Import (C, Strlen, "strlen");
procedure Strncpy (X : Address; Y : Address; Length : Integer);
pragma Import (C, Strncpy, "strncpy");
In_Length : constant Integer := Path'Length;
In_String : String (1 .. In_Length + 1);
Component_Name : aliased String := "GCC" & ASCII.NUL;
Result_Ptr : Address;
Result_Length : Integer;
Out_String : String_Ptr;
begin
In_String (1 .. In_Length) := Path.all;
In_String (In_Length + 1) := ASCII.NUL;
Result_Ptr := C_Update_Path (In_String'Address,
Component_Name'Address);
Result_Length := Strlen (Result_Ptr);
Out_String := new String (1 .. Result_Length);
Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
return Out_String;
end Update_Path;
procedure Write_Info (Info : String) is
begin
Write_With_Check (Info'Address, Info'Length);
Write_With_Check (EOL'Address, 1);
end Write_Info;
procedure Write_Program_Name is
Save_Buffer : constant String (1 .. Name_Len) :=
Name_Buffer (1 .. Name_Len);
begin
Find_Program_Name;
for J in 1 .. Name_Len loop
if Name_Buffer (J) in 'A' .. 'Z' then
Name_Buffer (J) :=
Character'Val (Character'Pos (Name_Buffer (J)) + 32);
end if;
end loop;
Write_Str (Name_Buffer (1 .. Name_Len));
Name_Len := Save_Buffer'Last;
Name_Buffer (1 .. Name_Len) := Save_Buffer;
end Write_Program_Name;
procedure Write_With_Check (A : Address; N : Integer) is
Ignore : Boolean;
begin
if N = Write (Output_FD, A, N) then
return;
else
Write_Str ("error: disk full writing ");
Write_Name_Decoded (Output_File_Name);
Write_Eol;
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ASCII.NUL;
Delete_File (Name_Buffer'Address, Ignore);
Exit_Program (E_Fatal);
end if;
end Write_With_Check;
begin
Initialization : declare
function Get_Default_Identifier_Character_Set return Character;
pragma Import (C, Get_Default_Identifier_Character_Set,
"__gnat_get_default_identifier_character_set");
function Get_Maximum_File_Name_Length return Int;
pragma Import (C, Get_Maximum_File_Name_Length,
"__gnat_get_maximum_file_name_length");
begin
Identifier_Character_Set := Get_Default_Identifier_Character_Set;
Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
if Hostparm.OpenVMS then
Multi_Unit_Index_Character := '$';
end if;
if Maximum_File_Name_Length = -1 then
Maximum_File_Name_Length := Int'Last;
end if;
Src_Search_Directories.Set_Last (Primary_Directory);
Src_Search_Directories.Table (Primary_Directory) := new String'("");
Lib_Search_Directories.Set_Last (Primary_Directory);
Lib_Search_Directories.Table (Primary_Directory) := new String'("");
Osint.Initialize;
end Initialization;
end Osint;