diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/s-os_lib.adb')
| -rwxr-xr-x | gcc-4.4.3/gcc/ada/s-os_lib.adb | 2648 |
1 files changed, 2648 insertions, 0 deletions
diff --git a/gcc-4.4.3/gcc/ada/s-os_lib.adb b/gcc-4.4.3/gcc/ada/s-os_lib.adb new file mode 100755 index 000000000..0e1c6c756 --- /dev/null +++ b/gcc-4.4.3/gcc/ada/s-os_lib.adb @@ -0,0 +1,2648 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . O S _ L I B -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2008, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Warnings (Off); +pragma Compiler_Unit; +pragma Warnings (On); + +with System.Case_Util; +with System.CRTL; +with System.Soft_Links; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with System; use System; + +package body System.OS_Lib is + + -- Imported procedures Dup and Dup2 are used in procedures Spawn and + -- Non_Blocking_Spawn. + + function Dup (Fd : File_Descriptor) return File_Descriptor; + pragma Import (C, Dup, "__gnat_dup"); + + procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); + pragma Import (C, Dup2, "__gnat_dup2"); + + On_Windows : constant Boolean := Directory_Separator = '\'; + -- An indication that we are on Windows. Used in Normalize_Pathname, to + -- deal with drive letters in the beginning of absolute paths. + + package SSL renames System.Soft_Links; + + -- The following are used by Create_Temp_File + + First_Temp_File_Name : constant String := "GNAT-TEMP-000000.TMP"; + -- Used to initialize Current_Temp_File_Name and Temp_File_Name_Last_Digit + + Current_Temp_File_Name : String := First_Temp_File_Name; + -- Name of the temp file last created + + Temp_File_Name_Last_Digit : constant Positive := + First_Temp_File_Name'Last - 4; + -- Position of the last digit in Current_Temp_File_Name + + Max_Attempts : constant := 100; + -- The maximum number of attempts to create a new temp file + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Args_Length (Args : Argument_List) return Natural; + -- Returns total number of characters needed to create a string + -- of all Args terminated by ASCII.NUL characters + + function C_String_Length (S : Address) return Integer; + -- Returns the length of a C string. Does check for null address + -- (returns 0). + + procedure Spawn_Internal + (Program_Name : String; + Args : Argument_List; + Result : out Integer; + Pid : out Process_Id; + Blocking : Boolean); + -- Internal routine to implement the two Spawn (blocking/non blocking) + -- routines. If Blocking is set to True then the spawn is blocking + -- otherwise it is non blocking. In this latter case the Pid contains the + -- process id number. The first three parameters are as in Spawn. Note that + -- Spawn_Internal normalizes the argument list before calling the low level + -- system spawn routines (see Normalize_Arguments). + -- + -- Note: Normalize_Arguments is designed to do nothing if it is called more + -- than once, so calling Normalize_Arguments before calling one of the + -- spawn routines is fine. + + function To_Path_String_Access + (Path_Addr : Address; + Path_Len : Integer) return String_Access; + -- Converts a C String to an Ada String. We could do this making use of + -- Interfaces.C.Strings but we prefer not to import that entire package + + --------- + -- "<" -- + --------- + + function "<" (X, Y : OS_Time) return Boolean is + begin + return Long_Integer (X) < Long_Integer (Y); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" (X, Y : OS_Time) return Boolean is + begin + return Long_Integer (X) <= Long_Integer (Y); + end "<="; + + --------- + -- ">" -- + --------- + + function ">" (X, Y : OS_Time) return Boolean is + begin + return Long_Integer (X) > Long_Integer (Y); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" (X, Y : OS_Time) return Boolean is + begin + return Long_Integer (X) >= Long_Integer (Y); + end ">="; + + ----------------- + -- Args_Length -- + ----------------- + + function Args_Length (Args : Argument_List) return Natural is + Len : Natural := 0; + + begin + for J in Args'Range loop + Len := Len + Args (J)'Length + 1; -- One extra for ASCII.NUL + end loop; + + return Len; + end Args_Length; + + ----------------------------- + -- Argument_String_To_List -- + ----------------------------- + + function Argument_String_To_List + (Arg_String : String) return Argument_List_Access + is + Max_Args : constant Integer := Arg_String'Length; + New_Argv : Argument_List (1 .. Max_Args); + New_Argc : Natural := 0; + Idx : Integer; + + begin + Idx := Arg_String'First; + + loop + exit when Idx > Arg_String'Last; + + declare + Quoted : Boolean := False; + Backqd : Boolean := False; + Old_Idx : Integer; + + begin + Old_Idx := Idx; + + loop + -- An unquoted space is the end of an argument + + if not (Backqd or Quoted) + and then Arg_String (Idx) = ' ' + then + exit; + + -- Start of a quoted string + + elsif not (Backqd or Quoted) + and then Arg_String (Idx) = '"' + then + Quoted := True; + + -- End of a quoted string and end of an argument + + elsif (Quoted and not Backqd) + and then Arg_String (Idx) = '"' + then + Idx := Idx + 1; + exit; + + -- Following character is backquoted + + elsif Arg_String (Idx) = '\' then + Backqd := True; + + -- Turn off backquoting after advancing one character + + elsif Backqd then + Backqd := False; + + end if; + + Idx := Idx + 1; + exit when Idx > Arg_String'Last; + end loop; + + -- Found an argument + + New_Argc := New_Argc + 1; + New_Argv (New_Argc) := + new String'(Arg_String (Old_Idx .. Idx - 1)); + + -- Skip extraneous spaces + + while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop + Idx := Idx + 1; + end loop; + end; + end loop; + + return new Argument_List'(New_Argv (1 .. New_Argc)); + end Argument_String_To_List; + + --------------------- + -- C_String_Length -- + --------------------- + + 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; + + ----------- + -- Close -- + ----------- + + procedure Close (FD : File_Descriptor) is + procedure C_Close (FD : File_Descriptor); + pragma Import (C, C_Close, "close"); + begin + C_Close (FD); + end Close; + + procedure Close (FD : File_Descriptor; Status : out Boolean) is + function C_Close (FD : File_Descriptor) return Integer; + pragma Import (C, C_Close, "close"); + begin + Status := (C_Close (FD) = 0); + end Close; + + --------------- + -- Copy_File -- + --------------- + + procedure Copy_File + (Name : String; + Pathname : String; + Success : out Boolean; + Mode : Copy_Mode := Copy; + Preserve : Attribute := Time_Stamps) + is + From : File_Descriptor; + To : File_Descriptor; + + Copy_Error : exception; + -- Internal exception raised to signal error in copy + + function Build_Path (Dir : String; File : String) return String; + -- Returns pathname Dir concatenated with File adding the directory + -- separator only if needed. + + procedure Copy (From, To : File_Descriptor); + -- Read data from From and place them into To. In both cases the + -- operations uses the current file position. Raises Constraint_Error + -- if a problem occurs during the copy. + + procedure Copy_To (To_Name : String); + -- Does a straight copy from source to designated destination file + + ---------------- + -- Build_Path -- + ---------------- + + function Build_Path (Dir : String; File : String) return String is + Res : String (1 .. Dir'Length + File'Length + 1); + + Base_File_Ptr : Integer; + -- The base file name is File (Base_File_Ptr + 1 .. File'Last) + + function Is_Dirsep (C : Character) return Boolean; + pragma Inline (Is_Dirsep); + -- Returns True if C is a directory separator. On Windows we + -- handle both styles of directory separator. + + --------------- + -- Is_Dirsep -- + --------------- + + function Is_Dirsep (C : Character) return Boolean is + begin + return C = Directory_Separator or else C = '/'; + end Is_Dirsep; + + -- Start of processing for Build_Path + + begin + -- Find base file name + + Base_File_Ptr := File'Last; + while Base_File_Ptr >= File'First loop + exit when Is_Dirsep (File (Base_File_Ptr)); + Base_File_Ptr := Base_File_Ptr - 1; + end loop; + + declare + Base_File : String renames + File (Base_File_Ptr + 1 .. File'Last); + + begin + Res (1 .. Dir'Length) := Dir; + + if Is_Dirsep (Dir (Dir'Last)) then + Res (Dir'Length + 1 .. Dir'Length + Base_File'Length) := + Base_File; + return Res (1 .. Dir'Length + Base_File'Length); + + else + Res (Dir'Length + 1) := Directory_Separator; + Res (Dir'Length + 2 .. Dir'Length + 1 + Base_File'Length) := + Base_File; + return Res (1 .. Dir'Length + 1 + Base_File'Length); + end if; + end; + end Build_Path; + + ---------- + -- Copy -- + ---------- + + procedure Copy (From, To : File_Descriptor) is + Buf_Size : constant := 200_000; + type Buf is array (1 .. Buf_Size) of Character; + type Buf_Ptr is access Buf; + + Buffer : Buf_Ptr; + R : Integer; + W : Integer; + + Status_From : Boolean; + Status_To : Boolean; + -- Statuses for the calls to Close + + procedure Free is new Ada.Unchecked_Deallocation (Buf, Buf_Ptr); + + begin + -- Check for invalid descriptors, making sure that we do not + -- accidentally leave an open file descriptor around. + + if From = Invalid_FD then + if To /= Invalid_FD then + Close (To, Status_To); + end if; + + raise Copy_Error; + + elsif To = Invalid_FD then + Close (From, Status_From); + raise Copy_Error; + end if; + + -- Allocate the buffer on the heap + + Buffer := new Buf; + + loop + R := Read (From, Buffer (1)'Address, Buf_Size); + + -- For VMS, the buffer may not be full. So, we need to try again + -- until there is nothing to read. + + exit when R = 0; + + W := Write (To, Buffer (1)'Address, R); + + if W < R then + + -- Problem writing data, could be a disk full. Close files + -- without worrying about status, since we are raising a + -- Copy_Error exception in any case. + + Close (From, Status_From); + Close (To, Status_To); + + Free (Buffer); + + raise Copy_Error; + end if; + end loop; + + Close (From, Status_From); + Close (To, Status_To); + + Free (Buffer); + + if not (Status_From and Status_To) then + raise Copy_Error; + end if; + end Copy; + + ------------- + -- Copy_To -- + ------------- + + procedure Copy_To (To_Name : String) is + + function Copy_Attributes + (From, To : System.Address; + Mode : Integer) return Integer; + pragma Import (C, Copy_Attributes, "__gnat_copy_attribs"); + -- Mode = 0 - copy only time stamps. + -- Mode = 1 - copy time stamps and read/write/execute attributes + + C_From : String (1 .. Name'Length + 1); + C_To : String (1 .. To_Name'Length + 1); + + begin + From := Open_Read (Name, Binary); + + -- Do not clobber destination file if source file could not be opened + + if From /= Invalid_FD then + To := Create_File (To_Name, Binary); + end if; + + Copy (From, To); + + -- Copy attributes + + C_From (1 .. Name'Length) := Name; + C_From (C_From'Last) := ASCII.NUL; + + C_To (1 .. To_Name'Length) := To_Name; + C_To (C_To'Last) := ASCII.NUL; + + case Preserve is + + when Time_Stamps => + if Copy_Attributes (C_From'Address, C_To'Address, 0) = -1 then + raise Copy_Error; + end if; + + when Full => + if Copy_Attributes (C_From'Address, C_To'Address, 1) = -1 then + raise Copy_Error; + end if; + + when None => + null; + end case; + + end Copy_To; + + -- Start of processing for Copy_File + + begin + Success := True; + + -- The source file must exist + + if not Is_Regular_File (Name) then + raise Copy_Error; + end if; + + -- The source file exists + + case Mode is + + -- Copy case, target file must not exist + + when Copy => + + -- If the target file exists, we have an error + + if Is_Regular_File (Pathname) then + raise Copy_Error; + + -- Case of target is a directory + + elsif Is_Directory (Pathname) then + declare + Dest : constant String := Build_Path (Pathname, Name); + + begin + -- If target file exists, we have an error, else do copy + + if Is_Regular_File (Dest) then + raise Copy_Error; + else + Copy_To (Dest); + end if; + end; + + -- Case of normal copy to file (destination does not exist) + + else + Copy_To (Pathname); + end if; + + -- Overwrite case (destination file may or may not exist) + + when Overwrite => + if Is_Directory (Pathname) then + Copy_To (Build_Path (Pathname, Name)); + else + Copy_To (Pathname); + end if; + + -- Append case (destination file may or may not exist) + + when Append => + + -- Appending to existing file + + if Is_Regular_File (Pathname) then + + -- Append mode and destination file exists, append data at the + -- end of Pathname. But if we fail to open source file, do not + -- touch destination file at all. + + From := Open_Read (Name, Binary); + if From /= Invalid_FD then + To := Open_Read_Write (Pathname, Binary); + end if; + + Lseek (To, 0, Seek_End); + + Copy (From, To); + + -- Appending to directory, not allowed + + elsif Is_Directory (Pathname) then + raise Copy_Error; + + -- Appending when target file does not exist + + else + Copy_To (Pathname); + end if; + end case; + + -- All error cases are caught here + + exception + when Copy_Error => + Success := False; + end Copy_File; + + procedure Copy_File + (Name : C_File_Name; + Pathname : C_File_Name; + Success : out Boolean; + Mode : Copy_Mode := Copy; + Preserve : Attribute := Time_Stamps) + is + Ada_Name : String_Access := + To_Path_String_Access + (Name, C_String_Length (Name)); + Ada_Pathname : String_Access := + To_Path_String_Access + (Pathname, C_String_Length (Pathname)); + begin + Copy_File (Ada_Name.all, Ada_Pathname.all, Success, Mode, Preserve); + Free (Ada_Name); + Free (Ada_Pathname); + end Copy_File; + + ---------------------- + -- Copy_Time_Stamps -- + ---------------------- + + procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean) is + + function Copy_Attributes + (From, To : System.Address; + Mode : Integer) return Integer; + pragma Import (C, Copy_Attributes, "__gnat_copy_attribs"); + -- Mode = 0 - copy only time stamps. + -- Mode = 1 - copy time stamps and read/write/execute attributes + + begin + if Is_Regular_File (Source) and then Is_Writable_File (Dest) then + declare + C_Source : String (1 .. Source'Length + 1); + C_Dest : String (1 .. Dest'Length + 1); + + begin + C_Source (1 .. Source'Length) := Source; + C_Source (C_Source'Last) := ASCII.NUL; + + C_Dest (1 .. Dest'Length) := Dest; + C_Dest (C_Dest'Last) := ASCII.NUL; + + if Copy_Attributes (C_Source'Address, C_Dest'Address, 0) = -1 then + Success := False; + else + Success := True; + end if; + end; + + else + Success := False; + end if; + end Copy_Time_Stamps; + + procedure Copy_Time_Stamps + (Source, Dest : C_File_Name; + Success : out Boolean) + is + Ada_Source : String_Access := + To_Path_String_Access + (Source, C_String_Length (Source)); + Ada_Dest : String_Access := + To_Path_String_Access + (Dest, C_String_Length (Dest)); + begin + Copy_Time_Stamps (Ada_Source.all, Ada_Dest.all, Success); + Free (Ada_Source); + Free (Ada_Dest); + end Copy_Time_Stamps; + + ----------------- + -- Create_File -- + ----------------- + + function Create_File + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor + is + function C_Create_File + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + pragma Import (C, C_Create_File, "__gnat_open_create"); + + begin + return C_Create_File (Name, Fmode); + end Create_File; + + function Create_File + (Name : String; + Fmode : Mode) return File_Descriptor + is + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return Create_File (C_Name (C_Name'First)'Address, Fmode); + end Create_File; + + --------------------- + -- Create_New_File -- + --------------------- + + function Create_New_File + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor + is + function C_Create_New_File + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + pragma Import (C, C_Create_New_File, "__gnat_open_new"); + + begin + return C_Create_New_File (Name, Fmode); + end Create_New_File; + + function Create_New_File + (Name : String; + Fmode : Mode) return File_Descriptor + is + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return Create_New_File (C_Name (C_Name'First)'Address, Fmode); + end Create_New_File; + + ----------------------------- + -- Create_Output_Text_File -- + ----------------------------- + + function Create_Output_Text_File (Name : String) return File_Descriptor is + function C_Create_File + (Name : C_File_Name) return File_Descriptor; + pragma Import (C, C_Create_File, "__gnat_create_output_file"); + + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return C_Create_File (C_Name (C_Name'First)'Address); + end Create_Output_Text_File; + + ---------------------- + -- Create_Temp_File -- + ---------------------- + + procedure Create_Temp_File + (FD : out File_Descriptor; + Name : out Temp_File_Name) + is + function Open_New_Temp + (Name : System.Address; + Fmode : Mode) return File_Descriptor; + pragma Import (C, Open_New_Temp, "__gnat_open_new_temp"); + + begin + FD := Open_New_Temp (Name'Address, Binary); + end Create_Temp_File; + + procedure Create_Temp_File + (FD : out File_Descriptor; + Name : out String_Access) + is + Pos : Positive; + Attempts : Natural := 0; + Current : String (Current_Temp_File_Name'Range); + + begin + -- Loop until a new temp file can be created + + File_Loop : loop + Locked : begin + -- We need to protect global variable Current_Temp_File_Name + -- against concurrent access by different tasks. + + SSL.Lock_Task.all; + + -- Start at the last digit + + Pos := Temp_File_Name_Last_Digit; + + Digit_Loop : + loop + -- Increment the digit by one + + case Current_Temp_File_Name (Pos) is + when '0' .. '8' => + Current_Temp_File_Name (Pos) := + Character'Succ (Current_Temp_File_Name (Pos)); + exit Digit_Loop; + + when '9' => + + -- For 9, set the digit to 0 and go to the previous digit + + Current_Temp_File_Name (Pos) := '0'; + Pos := Pos - 1; + + when others => + + -- If it is not a digit, then there are no available + -- temp file names. Return Invalid_FD. There is almost + -- no chance that this code will be ever be executed, + -- since it would mean that there are one million temp + -- files in the same directory! + + SSL.Unlock_Task.all; + FD := Invalid_FD; + Name := null; + exit File_Loop; + end case; + end loop Digit_Loop; + + Current := Current_Temp_File_Name; + + -- We can now release the lock, because we are no longer + -- accessing Current_Temp_File_Name. + + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Locked; + + -- Attempt to create the file + + FD := Create_New_File (Current, Binary); + + if FD /= Invalid_FD then + Name := new String'(Current); + exit File_Loop; + end if; + + if not Is_Regular_File (Current) then + + -- If the file does not already exist and we are unable to create + -- it, we give up after Max_Attempts. Otherwise, we try again with + -- the next available file name. + + Attempts := Attempts + 1; + + if Attempts >= Max_Attempts then + FD := Invalid_FD; + Name := null; + exit File_Loop; + end if; + end if; + end loop File_Loop; + end Create_Temp_File; + + ----------------- + -- Delete_File -- + ----------------- + + procedure Delete_File (Name : Address; Success : out Boolean) is + R : Integer; + + function unlink (A : Address) return Integer; + pragma Import (C, unlink, "unlink"); + + begin + R := unlink (Name); + Success := (R = 0); + end Delete_File; + + procedure Delete_File (Name : String; Success : out Boolean) is + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + + Delete_File (C_Name'Address, Success); + end Delete_File; + + --------------------- + -- File_Time_Stamp -- + --------------------- + + function File_Time_Stamp (FD : File_Descriptor) return OS_Time is + function File_Time (FD : File_Descriptor) return OS_Time; + pragma Import (C, File_Time, "__gnat_file_time_fd"); + begin + return File_Time (FD); + end File_Time_Stamp; + + function File_Time_Stamp (Name : C_File_Name) return OS_Time is + function File_Time (Name : Address) return OS_Time; + pragma Import (C, File_Time, "__gnat_file_time_name"); + begin + return File_Time (Name); + end File_Time_Stamp; + + function File_Time_Stamp (Name : String) return OS_Time is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return File_Time_Stamp (F_Name'Address); + end File_Time_Stamp; + + --------------------------- + -- Get_Debuggable_Suffix -- + --------------------------- + + function Get_Debuggable_Suffix return String_Access is + procedure Get_Suffix_Ptr (Length, Ptr : Address); + pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + Suffix_Ptr : Address; + Suffix_Length : Integer; + Result : String_Access; + + begin + Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); + + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length); + end if; + + return Result; + end Get_Debuggable_Suffix; + + --------------------------- + -- Get_Executable_Suffix -- + --------------------------- + + function Get_Executable_Suffix return String_Access is + procedure Get_Suffix_Ptr (Length, Ptr : Address); + pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + Suffix_Ptr : Address; + Suffix_Length : Integer; + Result : String_Access; + + begin + Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); + + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length); + end if; + + return Result; + end Get_Executable_Suffix; + + ----------------------- + -- Get_Object_Suffix -- + ----------------------- + + function Get_Object_Suffix return String_Access is + procedure Get_Suffix_Ptr (Length, Ptr : Address); + pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + Suffix_Ptr : Address; + Suffix_Length : Integer; + Result : String_Access; + + begin + Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); + + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length); + end if; + + return Result; + end Get_Object_Suffix; + + ---------------------------------- + -- Get_Target_Debuggable_Suffix -- + ---------------------------------- + + function Get_Target_Debuggable_Suffix return String_Access is + Target_Exec_Ext_Ptr : Address; + pragma Import + (C, Target_Exec_Ext_Ptr, "__gnat_target_debuggable_extension"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + function Strlen (Cstring : Address) return Integer; + pragma Import (C, Strlen, "strlen"); + + Suffix_Length : Integer; + Result : String_Access; + + begin + Suffix_Length := Strlen (Target_Exec_Ext_Ptr); + + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length); + end if; + + return Result; + end Get_Target_Debuggable_Suffix; + + ---------------------------------- + -- Get_Target_Executable_Suffix -- + ---------------------------------- + + function Get_Target_Executable_Suffix return String_Access is + Target_Exec_Ext_Ptr : Address; + pragma Import + (C, Target_Exec_Ext_Ptr, "__gnat_target_executable_extension"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + function Strlen (Cstring : Address) return Integer; + pragma Import (C, Strlen, "strlen"); + + Suffix_Length : Integer; + Result : String_Access; + + begin + Suffix_Length := Strlen (Target_Exec_Ext_Ptr); + + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length); + end if; + + return Result; + end Get_Target_Executable_Suffix; + + ------------------------------ + -- Get_Target_Object_Suffix -- + ------------------------------ + + function Get_Target_Object_Suffix return String_Access is + Target_Object_Ext_Ptr : Address; + pragma Import + (C, Target_Object_Ext_Ptr, "__gnat_target_object_extension"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + function Strlen (Cstring : Address) return Integer; + pragma Import (C, Strlen, "strlen"); + + Suffix_Length : Integer; + Result : String_Access; + + begin + Suffix_Length := Strlen (Target_Object_Ext_Ptr); + + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy (Result.all'Address, Target_Object_Ext_Ptr, Suffix_Length); + end if; + + return Result; + end Get_Target_Object_Suffix; + + ------------ + -- Getenv -- + ------------ + + function Getenv (Name : String) return String_Access is + procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); + pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); + + procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); + pragma Import (C, Strncpy, "strncpy"); + + Env_Value_Ptr : aliased Address; + Env_Value_Length : aliased Integer; + F_Name : aliased String (1 .. Name'Length + 1); + Result : String_Access; + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + + Get_Env_Value_Ptr + (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); + + Result := new String (1 .. Env_Value_Length); + + if Env_Value_Length > 0 then + Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length); + end if; + + return Result; + end Getenv; + + ------------ + -- GM_Day -- + ------------ + + function GM_Day (Date : OS_Time) return Day_Type is + D : Day_Type; + + pragma Warnings (Off); + Y : Year_Type; + Mo : Month_Type; + H : Hour_Type; + Mn : Minute_Type; + S : Second_Type; + pragma Warnings (On); + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return D; + end GM_Day; + + ------------- + -- GM_Hour -- + ------------- + + function GM_Hour (Date : OS_Time) return Hour_Type is + H : Hour_Type; + + pragma Warnings (Off); + Y : Year_Type; + Mo : Month_Type; + D : Day_Type; + Mn : Minute_Type; + S : Second_Type; + pragma Warnings (On); + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return H; + end GM_Hour; + + --------------- + -- GM_Minute -- + --------------- + + function GM_Minute (Date : OS_Time) return Minute_Type is + Mn : Minute_Type; + + pragma Warnings (Off); + Y : Year_Type; + Mo : Month_Type; + D : Day_Type; + H : Hour_Type; + S : Second_Type; + pragma Warnings (On); + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return Mn; + end GM_Minute; + + -------------- + -- GM_Month -- + -------------- + + function GM_Month (Date : OS_Time) return Month_Type is + Mo : Month_Type; + + pragma Warnings (Off); + Y : Year_Type; + D : Day_Type; + H : Hour_Type; + Mn : Minute_Type; + S : Second_Type; + pragma Warnings (On); + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return Mo; + end GM_Month; + + --------------- + -- GM_Second -- + --------------- + + function GM_Second (Date : OS_Time) return Second_Type is + S : Second_Type; + + pragma Warnings (Off); + Y : Year_Type; + Mo : Month_Type; + D : Day_Type; + H : Hour_Type; + Mn : Minute_Type; + pragma Warnings (On); + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return S; + end GM_Second; + + -------------- + -- GM_Split -- + -------------- + + procedure GM_Split + (Date : OS_Time; + Year : out Year_Type; + Month : out Month_Type; + Day : out Day_Type; + Hour : out Hour_Type; + Minute : out Minute_Type; + Second : out Second_Type) + is + procedure To_GM_Time + (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address); + pragma Import (C, To_GM_Time, "__gnat_to_gm_time"); + + T : OS_Time := Date; + Y : Integer; + Mo : Integer; + D : Integer; + H : Integer; + Mn : Integer; + S : Integer; + + begin + -- Use the global lock because To_GM_Time is not thread safe + + Locked_Processing : begin + SSL.Lock_Task.all; + To_GM_Time + (T'Address, Y'Address, Mo'Address, D'Address, + H'Address, Mn'Address, S'Address); + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Locked_Processing; + + Year := Y + 1900; + Month := Mo + 1; + Day := D; + Hour := H; + Minute := Mn; + Second := S; + end GM_Split; + + ------------- + -- GM_Year -- + ------------- + + function GM_Year (Date : OS_Time) return Year_Type is + Y : Year_Type; + + pragma Warnings (Off); + Mo : Month_Type; + D : Day_Type; + H : Hour_Type; + Mn : Minute_Type; + S : Second_Type; + pragma Warnings (On); + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return Y; + end GM_Year; + + ---------------------- + -- Is_Absolute_Path -- + ---------------------- + + function Is_Absolute_Path (Name : String) return Boolean is + function Is_Absolute_Path + (Name : Address; + Length : Integer) return Integer; + pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path"); + begin + return Is_Absolute_Path (Name'Address, Name'Length) /= 0; + end Is_Absolute_Path; + + ------------------ + -- Is_Directory -- + ------------------ + + function Is_Directory (Name : C_File_Name) return Boolean is + function Is_Directory (Name : Address) return Integer; + pragma Import (C, Is_Directory, "__gnat_is_directory"); + begin + return Is_Directory (Name) /= 0; + end Is_Directory; + + function Is_Directory (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Directory (F_Name'Address); + end Is_Directory; + + ---------------------- + -- Is_Readable_File -- + ---------------------- + + function Is_Readable_File (Name : C_File_Name) return Boolean is + function Is_Readable_File (Name : Address) return Integer; + pragma Import (C, Is_Readable_File, "__gnat_is_readable_file"); + begin + return Is_Readable_File (Name) /= 0; + end Is_Readable_File; + + function Is_Readable_File (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Readable_File (F_Name'Address); + end Is_Readable_File; + + ------------------------ + -- Is_Executable_File -- + ------------------------ + + function Is_Executable_File (Name : C_File_Name) return Boolean is + function Is_Executable_File (Name : Address) return Integer; + pragma Import (C, Is_Executable_File, "__gnat_is_executable_file"); + begin + return Is_Executable_File (Name) /= 0; + end Is_Executable_File; + + function Is_Executable_File (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Executable_File (F_Name'Address); + end Is_Executable_File; + + --------------------- + -- Is_Regular_File -- + --------------------- + + function Is_Regular_File (Name : C_File_Name) return Boolean is + function Is_Regular_File (Name : Address) return Integer; + pragma Import (C, Is_Regular_File, "__gnat_is_regular_file"); + begin + return Is_Regular_File (Name) /= 0; + end Is_Regular_File; + + function Is_Regular_File (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Regular_File (F_Name'Address); + end Is_Regular_File; + + ---------------------- + -- Is_Symbolic_Link -- + ---------------------- + + function Is_Symbolic_Link (Name : C_File_Name) return Boolean is + function Is_Symbolic_Link (Name : Address) return Integer; + pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link"); + begin + return Is_Symbolic_Link (Name) /= 0; + end Is_Symbolic_Link; + + function Is_Symbolic_Link (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Symbolic_Link (F_Name'Address); + end Is_Symbolic_Link; + + ---------------------- + -- Is_Writable_File -- + ---------------------- + + function Is_Writable_File (Name : C_File_Name) return Boolean is + function Is_Writable_File (Name : Address) return Integer; + pragma Import (C, Is_Writable_File, "__gnat_is_writable_file"); + begin + return Is_Writable_File (Name) /= 0; + end Is_Writable_File; + + function Is_Writable_File (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Writable_File (F_Name'Address); + end Is_Writable_File; + + ------------------------- + -- Locate_Exec_On_Path -- + ------------------------- + + function Locate_Exec_On_Path + (Exec_Name : String) return String_Access + is + function Locate_Exec_On_Path (C_Exec_Name : Address) return Address; + pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path"); + + procedure Free (Ptr : System.Address); + pragma Import (C, Free, "free"); + + C_Exec_Name : String (1 .. Exec_Name'Length + 1); + Path_Addr : Address; + Path_Len : Integer; + Result : String_Access; + + begin + C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name; + C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL; + + Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address); + Path_Len := C_String_Length (Path_Addr); + + if Path_Len = 0 then + return null; + + else + Result := To_Path_String_Access (Path_Addr, Path_Len); + Free (Path_Addr); + + -- Always return an absolute path name + + if 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 if; + end Locate_Exec_On_Path; + + ------------------------- + -- Locate_Regular_File -- + ------------------------- + + function Locate_Regular_File + (File_Name : C_File_Name; + Path : C_File_Name) return String_Access + is + function Locate_Regular_File + (C_File_Name, Path_Val : Address) return Address; + pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file"); + + procedure Free (Ptr : System.Address); + pragma Import (C, Free, "free"); + + Path_Addr : Address; + Path_Len : Integer; + Result : String_Access; + + begin + Path_Addr := Locate_Regular_File (File_Name, Path); + Path_Len := C_String_Length (Path_Addr); + + if Path_Len = 0 then + return null; + + else + Result := To_Path_String_Access (Path_Addr, Path_Len); + Free (Path_Addr); + return Result; + end if; + end Locate_Regular_File; + + function Locate_Regular_File + (File_Name : String; + Path : String) return String_Access + is + C_File_Name : String (1 .. File_Name'Length + 1); + C_Path : String (1 .. Path'Length + 1); + Result : String_Access; + + begin + C_File_Name (1 .. File_Name'Length) := File_Name; + C_File_Name (C_File_Name'Last) := ASCII.NUL; + + C_Path (1 .. Path'Length) := Path; + C_Path (C_Path'Last) := ASCII.NUL; + + Result := Locate_Regular_File (C_File_Name'Address, C_Path'Address); + + -- Always return an absolute path name + + 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_Regular_File; + + ------------------------ + -- Non_Blocking_Spawn -- + ------------------------ + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List) return Process_Id + is + Pid : Process_Id; + Junk : Integer; + pragma Warnings (Off, Junk); + begin + Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False); + return Pid; + end Non_Blocking_Spawn; + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Output_File_Descriptor : File_Descriptor; + Err_To_Out : Boolean := True) return Process_Id + is + Saved_Output : File_Descriptor; + Saved_Error : File_Descriptor := Invalid_FD; -- prevent warning + Pid : Process_Id; + + begin + if Output_File_Descriptor = Invalid_FD then + return Invalid_Pid; + end if; + + -- Set standard output and, if specified, error to the temporary file + + Saved_Output := Dup (Standout); + Dup2 (Output_File_Descriptor, Standout); + + if Err_To_Out then + Saved_Error := Dup (Standerr); + Dup2 (Output_File_Descriptor, Standerr); + end if; + + -- Spawn the program + + Pid := Non_Blocking_Spawn (Program_Name, Args); + + -- Restore the standard output and error + + Dup2 (Saved_Output, Standout); + + if Err_To_Out then + Dup2 (Saved_Error, Standerr); + end if; + + -- And close the saved standard output and error file descriptors + + Close (Saved_Output); + + if Err_To_Out then + Close (Saved_Error); + end if; + + return Pid; + end Non_Blocking_Spawn; + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Output_File : String; + Err_To_Out : Boolean := True) return Process_Id + is + Output_File_Descriptor : constant File_Descriptor := + Create_Output_Text_File (Output_File); + Result : Process_Id; + + begin + -- Do not attempt to spawn if the output file could not be created + + if Output_File_Descriptor = Invalid_FD then + return Invalid_Pid; + + else + Result := Non_Blocking_Spawn + (Program_Name, Args, Output_File_Descriptor, Err_To_Out); + + -- Close the file just created for the output, as the file descriptor + -- cannot be used anywhere, being a local value. It is safe to do + -- that, as the file descriptor has been duplicated to form + -- standard output and error of the spawned process. + + Close (Output_File_Descriptor); + + return Result; + end if; + end Non_Blocking_Spawn; + + ------------------------- + -- Normalize_Arguments -- + ------------------------- + + procedure Normalize_Arguments (Args : in out Argument_List) is + + procedure Quote_Argument (Arg : in out String_Access); + -- Add quote around argument if it contains spaces + + C_Argument_Needs_Quote : Integer; + pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote"); + Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0; + + -------------------- + -- Quote_Argument -- + -------------------- + + procedure Quote_Argument (Arg : in out String_Access) is + Res : String (1 .. Arg'Length * 2); + J : Positive := 1; + Quote_Needed : Boolean := False; + + begin + if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then + + -- Starting quote + + Res (J) := '"'; + + for K in Arg'Range loop + + J := J + 1; + + if Arg (K) = '"' then + Res (J) := '\'; + J := J + 1; + Res (J) := '"'; + Quote_Needed := True; + + elsif Arg (K) = ' ' then + Res (J) := Arg (K); + Quote_Needed := True; + + else + Res (J) := Arg (K); + end if; + + end loop; + + if Quote_Needed then + + -- If null terminated string, put the quote before + + if Res (J) = ASCII.NUL then + Res (J) := '"'; + J := J + 1; + Res (J) := ASCII.NUL; + + -- If argument is terminated by '\', then double it. Otherwise + -- the ending quote will be taken as-is. This is quite strange + -- spawn behavior from Windows, but this is what we see! + + else + if Res (J) = '\' then + J := J + 1; + Res (J) := '\'; + end if; + + -- Ending quote + + J := J + 1; + Res (J) := '"'; + end if; + + declare + Old : String_Access := Arg; + + begin + Arg := new String'(Res (1 .. J)); + Free (Old); + end; + end if; + + end if; + end Quote_Argument; + + -- Start of processing for Normalize_Arguments + + begin + if Argument_Needs_Quote then + for K in Args'Range loop + if Args (K) /= null and then Args (K)'Length /= 0 then + Quote_Argument (Args (K)); + end if; + end loop; + end if; + end Normalize_Arguments; + + ------------------------ + -- Normalize_Pathname -- + ------------------------ + + function Normalize_Pathname + (Name : String; + Directory : String := ""; + Resolve_Links : Boolean := True; + Case_Sensitive : Boolean := True) return String + is + Max_Path : Integer; + pragma Import (C, Max_Path, "__gnat_max_path_len"); + -- Maximum length of a path name + + procedure Get_Current_Dir + (Dir : System.Address; + Length : System.Address); + pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir"); + + Path_Buffer : String (1 .. Max_Path + Max_Path + 2); + End_Path : Natural := 0; + Link_Buffer : String (1 .. Max_Path + 2); + Status : Integer; + Last : Positive; + Start : Natural; + Finish : Positive; + + Max_Iterations : constant := 500; + + function Get_File_Names_Case_Sensitive return Integer; + pragma Import + (C, Get_File_Names_Case_Sensitive, + "__gnat_get_file_names_case_sensitive"); + + Fold_To_Lower_Case : constant Boolean := + not Case_Sensitive + and then Get_File_Names_Case_Sensitive = 0; + + function Readlink + (Path : System.Address; + Buf : System.Address; + Bufsiz : Integer) return Integer; + pragma Import (C, Readlink, "__gnat_readlink"); + + function To_Canonical_File_Spec + (Host_File : System.Address) return System.Address; + pragma Import + (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec"); + + The_Name : String (1 .. Name'Length + 1); + Canonical_File_Addr : System.Address; + Canonical_File_Len : Integer; + + function Strlen (S : System.Address) return Integer; + pragma Import (C, Strlen, "strlen"); + + function Final_Value (S : String) return String; + -- Make final adjustment to the returned string. This function strips + -- trailing directory separators, and folds returned string to lower + -- case if required. + + function Get_Directory (Dir : String) return String; + -- If Dir is not empty, return it, adding a directory separator + -- if not already present, otherwise return current working directory + -- with terminating directory separator. + + ----------------- + -- Final_Value -- + ----------------- + + function Final_Value (S : String) return String is + S1 : String := S; + -- We may need to fold S to lower case, so we need a variable + + Last : Natural; + + begin + if Fold_To_Lower_Case then + System.Case_Util.To_Lower (S1); + end if; + + -- Remove trailing directory separator, if any + + Last := S1'Last; + + if Last > 1 + and then (S1 (Last) = '/' + or else + S1 (Last) = Directory_Separator) + then + -- Special case for Windows: C:\ + + if Last = 3 + and then S1 (1) /= Directory_Separator + and then S1 (2) = ':' + then + null; + + else + Last := Last - 1; + end if; + end if; + + return S1 (1 .. Last); + end Final_Value; + + ------------------- + -- Get_Directory -- + ------------------- + + function Get_Directory (Dir : String) return String is + begin + -- Directory given, add directory separator if needed + + if Dir'Length > 0 then + if Dir (Dir'Last) = Directory_Separator then + return Dir; + else + declare + Result : String (1 .. Dir'Length + 1); + begin + Result (1 .. Dir'Length) := Dir; + Result (Result'Length) := Directory_Separator; + return Result; + end; + end if; + + -- Directory name not given, get current directory + + 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; + + -- By default, the drive letter on Windows is in upper case + + if On_Windows and then Path_Len >= 2 and then + Buffer (2) = ':' + then + System.Case_Util.To_Upper (Buffer (1 .. 1)); + end if; + + return Buffer (1 .. Path_Len); + end; + end if; + end Get_Directory; + + -- Start of processing for Normalize_Pathname + + begin + -- Special case, if name is null, then return null + + if Name'Length = 0 then + return ""; + end if; + + -- First, convert VMS file spec to Unix file spec. + -- If Name is not in VMS syntax, then this is equivalent + -- to put Name at the beginning of Path_Buffer. + + VMS_Conversion : begin + The_Name (1 .. Name'Length) := Name; + The_Name (The_Name'Last) := ASCII.NUL; + + Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address); + Canonical_File_Len := Strlen (Canonical_File_Addr); + + -- If VMS syntax conversion has failed, return an empty string + -- to indicate the failure. + + if Canonical_File_Len = 0 then + return ""; + end if; + + declare + subtype Path_String is String (1 .. Canonical_File_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 (Canonical_File_Addr); + + begin + Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all; + End_Path := Canonical_File_Len; + Last := 1; + end; + end VMS_Conversion; + + -- Replace all '/' by Directory Separators (this is for Windows) + + if Directory_Separator /= '/' then + for Index in 1 .. End_Path loop + if Path_Buffer (Index) = '/' then + Path_Buffer (Index) := Directory_Separator; + end if; + end loop; + end if; + + -- Resolve directory names for Windows (formerly also VMS) + + -- On VMS, if we have a Unix path such as /temp/..., and TEMP is a + -- logical name, we must not try to resolve this logical name, because + -- it may have multiple equivalences and if resolved we will only + -- get the first one. + + -- On Windows, if we have an absolute path starting with a directory + -- separator, we need to have the drive letter appended in front. + + -- On Windows, Get_Current_Dir will return a suitable directory + -- name (path starting with a drive letter on Windows). So we take this + -- drive letter and prepend it to the current path. + + if On_Windows + and then Path_Buffer (1) = Directory_Separator + and then Path_Buffer (2) /= Directory_Separator + then + declare + Cur_Dir : constant String := Get_Directory (""); + -- Get the current directory to get the drive letter + + begin + if Cur_Dir'Length > 2 + and then Cur_Dir (Cur_Dir'First + 1) = ':' + then + Path_Buffer (3 .. End_Path + 2) := Path_Buffer (1 .. End_Path); + Path_Buffer (1 .. 2) := + Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1); + End_Path := End_Path + 2; + end if; + end; + end if; + + -- On Windows, remove all double-quotes that are possibly part of the + -- path but can cause problems with other methods. + + if On_Windows then + declare + Index : Natural; + + begin + Index := Path_Buffer'First; + for Current in Path_Buffer'First .. End_Path loop + if Path_Buffer (Current) /= '"' then + Path_Buffer (Index) := Path_Buffer (Current); + Index := Index + 1; + end if; + end loop; + + End_Path := Index - 1; + end; + end if; + + -- Start the conversions + + -- If this is not finished after Max_Iterations, give up and return an + -- empty string. + + for J in 1 .. Max_Iterations loop + + -- If we don't have an absolute pathname, prepend the directory + -- Reference_Dir. + + if Last = 1 + and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path)) + then + declare + Reference_Dir : constant String := Get_Directory (Directory); + Ref_Dir_Len : constant Natural := Reference_Dir'Length; + -- Current directory name specified and its length + + begin + Path_Buffer (Ref_Dir_Len + 1 .. Ref_Dir_Len + End_Path) := + Path_Buffer (1 .. End_Path); + End_Path := Ref_Dir_Len + End_Path; + Path_Buffer (1 .. Ref_Dir_Len) := Reference_Dir; + Last := Ref_Dir_Len; + end; + end if; + + Start := Last + 1; + Finish := Last; + + -- Ensure that Windows network drives are kept, e.g: \\server\drive-c + + if Start = 2 + and then Directory_Separator = '\' + and then Path_Buffer (1 .. 2) = "\\" + then + Start := 3; + end if; + + -- If we have traversed the full pathname, return it + + if Start > End_Path then + return Final_Value (Path_Buffer (1 .. End_Path)); + end if; + + -- Remove duplicate directory separators + + while Path_Buffer (Start) = Directory_Separator loop + if Start = End_Path then + return Final_Value (Path_Buffer (1 .. End_Path - 1)); + + else + Path_Buffer (Start .. End_Path - 1) := + Path_Buffer (Start + 1 .. End_Path); + End_Path := End_Path - 1; + end if; + end loop; + + -- Find the end of the current field: last character or the one + -- preceding the next directory separator. + + while Finish < End_Path + and then Path_Buffer (Finish + 1) /= Directory_Separator + loop + Finish := Finish + 1; + end loop; + + -- Remove "." field + + if Start = Finish and then Path_Buffer (Start) = '.' then + if Start = End_Path then + if Last = 1 then + return (1 => Directory_Separator); + else + + if Fold_To_Lower_Case then + System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1)); + end if; + + return Path_Buffer (1 .. Last - 1); + + end if; + + else + Path_Buffer (Last + 1 .. End_Path - 2) := + Path_Buffer (Last + 3 .. End_Path); + End_Path := End_Path - 2; + end if; + + -- Remove ".." fields + + elsif Finish = Start + 1 + and then Path_Buffer (Start .. Finish) = ".." + then + Start := Last; + loop + Start := Start - 1; + exit when Start < 1 or else + Path_Buffer (Start) = Directory_Separator; + end loop; + + if Start <= 1 then + if Finish = End_Path then + return (1 => Directory_Separator); + + else + Path_Buffer (1 .. End_Path - Finish) := + Path_Buffer (Finish + 1 .. End_Path); + End_Path := End_Path - Finish; + Last := 1; + end if; + + else + if Finish = End_Path then + return Final_Value (Path_Buffer (1 .. Start - 1)); + + else + Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) := + Path_Buffer (Finish + 2 .. End_Path); + End_Path := Start + End_Path - Finish - 1; + Last := Start; + end if; + end if; + + -- Check if current field is a symbolic link + + elsif Resolve_Links then + declare + Saved : constant Character := Path_Buffer (Finish + 1); + + begin + Path_Buffer (Finish + 1) := ASCII.NUL; + Status := Readlink (Path_Buffer'Address, + Link_Buffer'Address, + Link_Buffer'Length); + Path_Buffer (Finish + 1) := Saved; + end; + + -- Not a symbolic link, move to the next field, if any + + if Status <= 0 then + Last := Finish + 1; + + -- Replace symbolic link with its value + + else + if Is_Absolute_Path (Link_Buffer (1 .. Status)) then + Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) := + Path_Buffer (Finish + 1 .. End_Path); + End_Path := End_Path - (Finish - Status); + Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status); + Last := 1; + + else + Path_Buffer + (Last + Status + 1 .. End_Path - Finish + Last + Status) := + Path_Buffer (Finish + 1 .. End_Path); + End_Path := End_Path - Finish + Last + Status; + Path_Buffer (Last + 1 .. Last + Status) := + Link_Buffer (1 .. Status); + end if; + end if; + + else + Last := Finish + 1; + end if; + end loop; + + -- Too many iterations: give up + + -- This can happen when there is a circularity in the symbolic links: A + -- is a symbolic link for B, which itself is a symbolic link, and the + -- target of B or of another symbolic link target of B is A. In this + -- case, we return an empty string to indicate failure to resolve. + + return ""; + end Normalize_Pathname; + + --------------- + -- Open_Read -- + --------------- + + function Open_Read + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor + is + function C_Open_Read + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + pragma Import (C, C_Open_Read, "__gnat_open_read"); + begin + return C_Open_Read (Name, Fmode); + end Open_Read; + + function Open_Read + (Name : String; + Fmode : Mode) return File_Descriptor + is + C_Name : String (1 .. Name'Length + 1); + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return Open_Read (C_Name (C_Name'First)'Address, Fmode); + end Open_Read; + + --------------------- + -- Open_Read_Write -- + --------------------- + + function Open_Read_Write + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor + is + function C_Open_Read_Write + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + pragma Import (C, C_Open_Read_Write, "__gnat_open_rw"); + begin + return C_Open_Read_Write (Name, Fmode); + end Open_Read_Write; + + function Open_Read_Write + (Name : String; + Fmode : Mode) return File_Descriptor + is + C_Name : String (1 .. Name'Length + 1); + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode); + end Open_Read_Write; + + ------------- + -- OS_Exit -- + ------------- + + procedure OS_Exit (Status : Integer) is + begin + OS_Exit_Ptr (Status); + raise Program_Error; + end OS_Exit; + + --------------------- + -- OS_Exit_Default -- + --------------------- + + procedure OS_Exit_Default (Status : Integer) is + procedure GNAT_OS_Exit (Status : Integer); + pragma Import (C, GNAT_OS_Exit, "__gnat_os_exit"); + pragma No_Return (GNAT_OS_Exit); + begin + GNAT_OS_Exit (Status); + end OS_Exit_Default; + + -------------------- + -- Pid_To_Integer -- + -------------------- + + function Pid_To_Integer (Pid : Process_Id) return Integer is + begin + return Integer (Pid); + end Pid_To_Integer; + + ---------- + -- Read -- + ---------- + + function Read + (FD : File_Descriptor; + A : System.Address; + N : Integer) return Integer + is + begin + return Integer (System.CRTL.read + (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N))); + end Read; + + ----------------- + -- Rename_File -- + ----------------- + + procedure Rename_File + (Old_Name : C_File_Name; + New_Name : C_File_Name; + Success : out Boolean) + is + function rename (From, To : Address) return Integer; + pragma Import (C, rename, "rename"); + R : Integer; + begin + R := rename (Old_Name, New_Name); + Success := (R = 0); + end Rename_File; + + procedure Rename_File + (Old_Name : String; + New_Name : String; + Success : out Boolean) + is + C_Old_Name : String (1 .. Old_Name'Length + 1); + C_New_Name : String (1 .. New_Name'Length + 1); + begin + C_Old_Name (1 .. Old_Name'Length) := Old_Name; + C_Old_Name (C_Old_Name'Last) := ASCII.NUL; + C_New_Name (1 .. New_Name'Length) := New_Name; + C_New_Name (C_New_Name'Last) := ASCII.NUL; + Rename_File (C_Old_Name'Address, C_New_Name'Address, Success); + end Rename_File; + + ----------------------- + -- Set_Close_On_Exec -- + ----------------------- + + procedure Set_Close_On_Exec + (FD : File_Descriptor; + Close_On_Exec : Boolean; + Status : out Boolean) + is + function C_Set_Close_On_Exec + (FD : File_Descriptor; Close_On_Exec : System.CRTL.int) + return System.CRTL.int; + pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec"); + begin + Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0; + end Set_Close_On_Exec; + + -------------------- + -- Set_Executable -- + -------------------- + + procedure Set_Executable (Name : String) is + procedure C_Set_Executable (Name : C_File_Name); + pragma Import (C, C_Set_Executable, "__gnat_set_executable"); + C_Name : aliased String (Name'First .. Name'Last + 1); + begin + C_Name (Name'Range) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + C_Set_Executable (C_Name (C_Name'First)'Address); + end Set_Executable; + + ---------------------- + -- Set_Non_Readable -- + ---------------------- + + procedure Set_Non_Readable (Name : String) is + procedure C_Set_Non_Readable (Name : C_File_Name); + pragma Import (C, C_Set_Non_Readable, "__gnat_set_non_readable"); + C_Name : aliased String (Name'First .. Name'Last + 1); + begin + C_Name (Name'Range) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + C_Set_Non_Readable (C_Name (C_Name'First)'Address); + end Set_Non_Readable; + + ---------------------- + -- Set_Non_Writable -- + ---------------------- + + procedure Set_Non_Writable (Name : String) is + procedure C_Set_Non_Writable (Name : C_File_Name); + pragma Import (C, C_Set_Non_Writable, "__gnat_set_non_writable"); + C_Name : aliased String (Name'First .. Name'Last + 1); + begin + C_Name (Name'Range) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + C_Set_Non_Writable (C_Name (C_Name'First)'Address); + end Set_Non_Writable; + + ------------------ + -- Set_Readable -- + ------------------ + + procedure Set_Readable (Name : String) is + procedure C_Set_Readable (Name : C_File_Name); + pragma Import (C, C_Set_Readable, "__gnat_set_readable"); + C_Name : aliased String (Name'First .. Name'Last + 1); + begin + C_Name (Name'Range) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + C_Set_Readable (C_Name (C_Name'First)'Address); + end Set_Readable; + + -------------------- + -- Set_Writable -- + -------------------- + + procedure Set_Writable (Name : String) is + procedure C_Set_Writable (Name : C_File_Name); + pragma Import (C, C_Set_Writable, "__gnat_set_writable"); + C_Name : aliased String (Name'First .. Name'Last + 1); + begin + C_Name (Name'Range) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + C_Set_Writable (C_Name (C_Name'First)'Address); + end Set_Writable; + + ------------ + -- Setenv -- + ------------ + + procedure Setenv (Name : String; Value : String) is + F_Name : String (1 .. Name'Length + 1); + F_Value : String (1 .. Value'Length + 1); + + procedure Set_Env_Value (Name, Value : System.Address); + pragma Import (C, Set_Env_Value, "__gnat_setenv"); + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + + F_Value (1 .. Value'Length) := Value; + F_Value (F_Value'Last) := ASCII.NUL; + + Set_Env_Value (F_Name'Address, F_Value'Address); + end Setenv; + + ----------- + -- Spawn -- + ----------- + + function Spawn + (Program_Name : String; + Args : Argument_List) return Integer + is + Result : Integer; + Junk : Process_Id; + pragma Warnings (Off, Junk); + begin + Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True); + return Result; + end Spawn; + + procedure Spawn + (Program_Name : String; + Args : Argument_List; + Success : out Boolean) + is + begin + Success := (Spawn (Program_Name, Args) = 0); + end Spawn; + + procedure Spawn + (Program_Name : String; + Args : Argument_List; + Output_File_Descriptor : File_Descriptor; + Return_Code : out Integer; + Err_To_Out : Boolean := True) + is + Saved_Output : File_Descriptor; + Saved_Error : File_Descriptor := Invalid_FD; -- prevent compiler warning + + begin + -- Set standard output and error to the temporary file + + Saved_Output := Dup (Standout); + Dup2 (Output_File_Descriptor, Standout); + + if Err_To_Out then + Saved_Error := Dup (Standerr); + Dup2 (Output_File_Descriptor, Standerr); + end if; + + -- Spawn the program + + Return_Code := Spawn (Program_Name, Args); + + -- Restore the standard output and error + + Dup2 (Saved_Output, Standout); + + if Err_To_Out then + Dup2 (Saved_Error, Standerr); + end if; + + -- And close the saved standard output and error file descriptors + + Close (Saved_Output); + + if Err_To_Out then + Close (Saved_Error); + end if; + end Spawn; + + procedure Spawn + (Program_Name : String; + Args : Argument_List; + Output_File : String; + Success : out Boolean; + Return_Code : out Integer; + Err_To_Out : Boolean := True) + is + FD : File_Descriptor; + + begin + Success := True; + Return_Code := 0; + + FD := Create_Output_Text_File (Output_File); + + if FD = Invalid_FD then + Success := False; + return; + end if; + + Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out); + + Close (FD, Success); + end Spawn; + + -------------------- + -- Spawn_Internal -- + -------------------- + + procedure Spawn_Internal + (Program_Name : String; + Args : Argument_List; + Result : out Integer; + Pid : out Process_Id; + Blocking : Boolean) + is + + procedure Spawn (Args : Argument_List); + -- Call Spawn with given argument list + + N_Args : Argument_List (Args'Range); + -- Normalized arguments + + ----------- + -- Spawn -- + ----------- + + procedure Spawn (Args : Argument_List) is + type Chars is array (Positive range <>) of aliased Character; + type Char_Ptr is access constant Character; + + Command_Len : constant Positive := Program_Name'Length + 1 + + Args_Length (Args); + Command_Last : Natural := 0; + Command : aliased Chars (1 .. Command_Len); + -- Command contains all characters of the Program_Name and Args, all + -- terminated by ASCII.NUL characters. + + Arg_List_Len : constant Positive := Args'Length + 2; + Arg_List_Last : Natural := 0; + Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr; + -- List with pointers to NUL-terminated strings of the Program_Name + -- and the Args and terminated with a null pointer. We rely on the + -- default initialization for the last null pointer. + + procedure Add_To_Command (S : String); + -- Add S and a NUL character to Command, updating Last + + function Portable_Spawn (Args : Address) return Integer; + pragma Import (C, Portable_Spawn, "__gnat_portable_spawn"); + + function Portable_No_Block_Spawn (Args : Address) return Process_Id; + pragma Import + (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn"); + + -------------------- + -- Add_To_Command -- + -------------------- + + procedure Add_To_Command (S : String) is + First : constant Natural := Command_Last + 1; + + begin + Command_Last := Command_Last + S'Length; + + -- Move characters one at a time, because Command has aliased + -- components. + + -- But not volatile, so why is this necessary ??? + + for J in S'Range loop + Command (First + J - S'First) := S (J); + end loop; + + Command_Last := Command_Last + 1; + Command (Command_Last) := ASCII.NUL; + + Arg_List_Last := Arg_List_Last + 1; + Arg_List (Arg_List_Last) := Command (First)'Access; + end Add_To_Command; + + -- Start of processing for Spawn + + begin + Add_To_Command (Program_Name); + + for J in Args'Range loop + Add_To_Command (Args (J).all); + end loop; + + if Blocking then + Pid := Invalid_Pid; + Result := Portable_Spawn (Arg_List'Address); + else + Pid := Portable_No_Block_Spawn (Arg_List'Address); + Result := Boolean'Pos (Pid /= Invalid_Pid); + end if; + end Spawn; + + -- Start of processing for Spawn_Internal + + begin + -- Copy arguments into a local structure + + for K in N_Args'Range loop + N_Args (K) := new String'(Args (K).all); + end loop; + + -- Normalize those arguments + + Normalize_Arguments (N_Args); + + -- Call spawn using the normalized arguments + + Spawn (N_Args); + + -- Free arguments list + + for K in N_Args'Range loop + Free (N_Args (K)); + end loop; + end Spawn_Internal; + + --------------------------- + -- 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; + + ------------------ + -- Wait_Process -- + ------------------ + + procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is + Status : Integer; + + function Portable_Wait (S : Address) return Process_Id; + pragma Import (C, Portable_Wait, "__gnat_portable_wait"); + + begin + Pid := Portable_Wait (Status'Address); + Success := (Status = 0); + end Wait_Process; + + ----------- + -- Write -- + ----------- + + function Write + (FD : File_Descriptor; + A : System.Address; + N : Integer) return Integer + is + begin + return Integer (System.CRTL.write + (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N))); + end Write; + +end System.OS_Lib; |