path: root/gcc/ada/g-os_lib.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                          G N A T . O S _ L I B                           --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--           Copyright (C) 1995-2002 Ada Core Technologies, Inc.            --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- 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,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
--                                                                          --
------------------------------------------------------------------------------

with System.Soft_Links;
with Unchecked_Conversion;
with System; use System;

package body GNAT.OS_Lib is

   package SSL renames System.Soft_Links;

   -----------------------
   -- 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
   --  that 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

   -----------------
   -- 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 : Integer := Arg_String'Length;
      New_Argv : Argument_List (1 .. Max_Args);
      New_Argc : Natural := 0;
      Idx      : Integer;

   begin
      Idx := Arg_String'First;

      loop
         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;

         exit when Idx > Arg_String'Last;
      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;

   -----------------
   -- 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_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;

   -----------------
   -- 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;

   ----------
   -- Free --
   ----------

   procedure Free (Arg : in out String_List_Access) is
      X : String_Access;

      procedure Free_Array is new Unchecked_Deallocation
        (Object => String_List, Name => String_List_Access);

   begin
      for J in Arg'Range loop
         X := Arg (J);
         Free (X);
      end loop;

      Free_Array (Arg);
   end Free;

   ---------------------------
   -- 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;

   ------------
   -- 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_get_env_value_ptr");

      procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
      pragma Import (C, Strncpy, "strncpy");

      Env_Value_Ptr    : Address;
      Env_Value_Length : Integer;
      F_Name           : 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
      Y  : Year_Type;
      Mo : Month_Type;
      D  : Day_Type;
      H  : Hour_Type;
      Mn : Minute_Type;
      S  : Second_Type;

   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
      Y  : Year_Type;
      Mo : Month_Type;
      D  : Day_Type;
      H  : Hour_Type;
      Mn : Minute_Type;
      S  : Second_Type;

   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
      Y  : Year_Type;
      Mo : Month_Type;
      D  : Day_Type;
      H  : Hour_Type;
      Mn : Minute_Type;
      S  : Second_Type;

   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
      Y  : Year_Type;
      Mo : Month_Type;
      D  : Day_Type;
      H  : Hour_Type;
      Mn : Minute_Type;
      S  : Second_Type;

   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
      Y  : Year_Type;
      Mo : Month_Type;
      D  : Day_Type;
      H  : Hour_Type;
      Mn : Minute_Type;
      S  : Second_Type;

   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;
      Mo : Month_Type;
      D  : Day_Type;
      H  : Hour_Type;
      Mn : Minute_Type;
      S  : Second_Type;

   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) return Integer;
      pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");

      F_Name : String (1 .. Name'Length + 1);

   begin
      F_Name (1 .. Name'Length) := Name;
      F_Name (F_Name'Last)      := ASCII.NUL;

      return Is_Absolute_Path (F_Name'Address) /= 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_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_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);
         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);

   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;

      return Locate_Regular_File (C_File_Name'Address, C_Path'Address);
   end Locate_Regular_File;

   ------------------------
   -- Non_Blocking_Spawn --
   ------------------------

   function Non_Blocking_Spawn
     (Program_Name : String;
      Args         : Argument_List)
      return         Process_Id
   is
      Junk : Integer;
      Pid  : Process_Id;

   begin
      Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
      return Pid;
   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.

      Argument_Needs_Quote : Boolean;
      pragma Import (C, Argument_Needs_Quote, "__gnat_argument_needs_quote");

      --------------------
      -- 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) := '"';

               elsif Arg (K) = ' ' then
                  Res (J) := Arg (K);
                  Quote_Needed := True;

               else
                  Res (J) := Arg (K);
               end if;

            end loop;

            if Quote_Needed then

               --  Ending quote

               J := J + 1;
               Res (J) := '"';

               declare
                  Old : String_Access := Arg;

               begin
                  Arg := new String'(Res (1 .. J));
                  Free (Old);
               end;
            end if;

         end if;
      end Quote_Argument;

   begin
      if Argument_Needs_Quote then
         for K in Args'Range loop
            if Args (K) /= null then
               Quote_Argument (Args (K));
            end if;
         end loop;
      end if;
   end Normalize_Arguments;

   ------------------------
   -- Normalize_Pathname --
   ------------------------

   function Normalize_Pathname
     (Name      : String;
      Directory : String := "")
      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 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;

      Need_To_Check_Drive_Letter : Boolean := False;
      --  Set to true if Name is an absolute path that starts with "//"

      function Strlen (S : System.Address) return Integer;
      pragma Import (C, Strlen, "strlen");

      function Get_Directory return String;
      --  If Directory is not empty, return it, adding a directory separator
      --  if not already present, otherwise return current working directory
      --  with terminating directory separator.

      function Final_Value (S : String) return String;
      --  Make final adjustment to the returned string.
      --  To compensate for non standard path name in Interix,
      --  if S is "/x" or starts with "/x", where x is a capital
      --  letter 'A' to 'Z', add an additional '/' at the beginning
      --  so that the returned value starts with "//x".

      -------------------
      -- Get_Directory --
      -------------------

      function Get_Directory return String is
      begin
         --  Directory given, add directory separator if needed

         if Directory'Length > 0 then
            if Directory (Directory'Length) = Directory_Separator then
               return Directory;
            else
               declare
                  Result : String (1 .. Directory'Length + 1);

               begin
                  Result (1 .. Directory'Length) := Directory;
                  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;

               return Buffer (1 .. Path_Len);
            end;
         end if;
      end Get_Directory;

      Reference_Dir : constant String := Get_Directory;
      --  Current directory name specified

      -----------------
      -- Final_Value --
      -----------------

      function Final_Value (S : String) return String is
      begin
         --  Interix has the non standard notion of disk drive
         --  indicated by two '/' followed by a capital letter
         --  'A' .. 'Z'. One of the two '/' may have been removed
         --  by Normalize_Pathname. It has to be added again.
         --  For other OSes, this should not make no difference.

         if Need_To_Check_Drive_Letter
           and then S'Length >= 2
           and then S (S'First) = '/'
           and then S (S'First + 1) in 'A' .. 'Z'
           and then (S'Length = 2 or else S (S'First + 2) = '/')
         then
            declare
               Result : String (1 .. S'Length + 1);

            begin
               Result (1) := '/';
               Result (2 .. Result'Last) := S;
               return Result;
            end;

         else
            return S;
         end if;

      end Final_Value;

   --  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 begining 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
               Unchecked_Conversion (Source => Address,
                                     Target => Path_String_Access);

            Path_Access : 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;

      --  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
            Path_Buffer
              (Reference_Dir'Last + 1 .. Reference_Dir'Length + End_Path) :=
                 Path_Buffer (1 .. End_Path);
            End_Path := Reference_Dir'Length + End_Path;
            Path_Buffer (1 .. Reference_Dir'Length) := Reference_Dir;
            Last := Reference_Dir'Length;
         end if;

         --  If name starts with "//", we may have a drive letter on Interix

         if Last = 1 and then End_Path >= 3 then
            Need_To_Check_Drive_Letter := (Path_Buffer (1 .. 2)) = "//";
         end if;

         Start  := Last + 1;
         Finish := Last;

         --  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
                  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

         else
            declare
               Saved : 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;
         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;

   -----------------
   -- 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;

   ------------
   -- 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_set_env_value");

   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
      Junk   : Process_Id;
      Result : Integer;

   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;

   --------------------
   -- 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.

      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.

            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
        Unchecked_Conversion (Source => Address,
                              Target => Path_String_Access);

      Path_Access : 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;

end GNAT.OS_Lib;