PR fortran/46625

[official-gcc.git] / gcc / ada / osint.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                                O S I N T                                 --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  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 COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Alloc;
with Debug;
with Fmap;     use Fmap;
with Gnatvsn;  use Gnatvsn;
with Hostparm;
with Opt;      use Opt;
with Output;   use Output;
with Sdefault; use Sdefault;
with Table;
with Targparm; use Targparm;

with Unchecked_Conversion;

pragma Warnings (Off);
--  This package is used also by gnatcoll
with System.Case_Util; use System.Case_Util;
pragma Warnings (On);

with GNAT.HTable;

package body Osint is

   Running_Program : Program_Type := Unspecified;
   --  comment required here ???

   Program_Set : Boolean := False;
   --  comment required here ???

   Std_Prefix : String_Ptr;
   --  Standard prefix, computed dynamically the first time Relocate_Path
   --  is called, and cached for subsequent calls.

   Empty  : aliased String := "";
   No_Dir : constant String_Ptr := Empty'Access;
   --  Used in Locate_File as a fake directory when Name is already an
   --  absolute path.

   -------------------------------------
   -- Use of Name_Find and Name_Enter --
   -------------------------------------

   --  This package creates a number of source, ALI and object file names
   --  that are used to locate the actual file and for the purpose of message
   --  construction. These names need not be accessible by Name_Find, and can
   --  be therefore created by using routine Name_Enter. The files in question
   --  are file names with a prefix directory (i.e., the files not in the
   --  current directory). File names without a prefix directory are entered
   --  with Name_Find because special values might be attached to the various
   --  Info fields of the corresponding name table entry.

   -----------------------
   -- Local Subprograms --
   -----------------------

   function Append_Suffix_To_File_Name
     (Name   : File_Name_Type;
      Suffix : String) return File_Name_Type;
   --  Appends Suffix to Name and returns the new name

   function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type;
   --  Convert OS format time to GNAT format time stamp. If T is Invalid_Time,
   --  then returns Empty_Time_Stamp.

   function Executable_Prefix return String_Ptr;
   --  Returns the name of the root directory where the executable is stored.
   --  The executable must be located in a directory called "bin", or under
   --  root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if
   --  executable is stored in directory "/foo/bar/bin", this routine returns
   --  "/foo/bar/". Return "" if location is not recognized as described above.

   function Update_Path (Path : String_Ptr) return String_Ptr;
   --  Update the specified path to replace the prefix with the location where
   --  GNAT is installed. See the file prefix.c in GCC for details.

   procedure Locate_File
     (N     : File_Name_Type;
      T     : File_Type;
      Dir   : Natural;
      Name  : String;
      Found : out File_Name_Type;
      Attr  : access File_Attributes);
   --  See if the file N whose name is Name exists in directory Dir. Dir is an
   --  index into the Lib_Search_Directories table if T = Library. Otherwise
   --  if T = Source, Dir is an index into the Src_Search_Directories table.
   --  Returns the File_Name_Type of the full file name if file found, or
   --  No_File if not found.
   --
   --  On exit, Found is set to the file that was found, and Attr to a cache of
   --  its attributes (at least those that have been computed so far). Reusing
   --  the cache will save some system calls.
   --
   --  Attr is always reset in this call to Unknown_Attributes, even in case of
   --  failure

   procedure Find_File
     (N     : File_Name_Type;
      T     : File_Type;
      Found : out File_Name_Type;
      Attr  : access File_Attributes);
   --  A version of Find_File that also returns a cache of the file attributes
   --  for later reuse

   procedure Smart_Find_File
     (N     : File_Name_Type;
      T     : File_Type;
      Found : out File_Name_Type;
      Attr  : out File_Attributes);
   --  A version of Smart_Find_File that also returns a cache of the file
   --  attributes for later reuse

   function C_String_Length (S : Address) return Integer;
   --  Returns length of a C string (zero for a null address)

   function To_Path_String_Access
     (Path_Addr : Address;
      Path_Len  : Integer) return String_Access;
   --  Converts a C String to an Ada String. Are we doing this to avoid withing
   --  Interfaces.C.Strings ???
   --  Caller must free result.

   function Include_Dir_Default_Prefix return String_Access;
   --  Same as exported version, except returns a String_Access

   ------------------------------
   -- Other Local Declarations --
   ------------------------------

   EOL : constant Character := ASCII.LF;
   --  End of line character

   Number_File_Names : Int := 0;
   --  Number of file names found on command line and placed in File_Names

   Look_In_Primary_Directory_For_Current_Main : Boolean := False;
   --  When this variable is True, Find_File only looks in Primary_Directory
   --  for the Current_Main file. This variable is always set to True for the
   --  compiler. It is also True for gnatmake, when the source name given on
   --  the command line has directory information.

   Current_Full_Source_Name  : File_Name_Type  := No_File;
   Current_Full_Source_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
   Current_Full_Lib_Name     : File_Name_Type  := No_File;
   Current_Full_Lib_Stamp    : Time_Stamp_Type := Empty_Time_Stamp;
   Current_Full_Obj_Name     : File_Name_Type  := No_File;
   Current_Full_Obj_Stamp    : Time_Stamp_Type := Empty_Time_Stamp;
   --  Respectively full name (with directory info) and time stamp of the
   --  latest source, library and object files opened by Read_Source_File and
   --  Read_Library_Info.

   package File_Name_Chars is new Table.Table (
     Table_Component_Type => Character,
     Table_Index_Type     => Int,
     Table_Low_Bound      => 1,
     Table_Initial        => Alloc.File_Name_Chars_Initial,
     Table_Increment      => Alloc.File_Name_Chars_Increment,
     Table_Name           => "File_Name_Chars");
   --  Table to store text to be printed by Dump_Source_File_Names

   The_Include_Dir_Default_Prefix : String_Access := null;
   --  Value returned by Include_Dir_Default_Prefix. We don't initialize it
   --  here, because that causes an elaboration cycle with Sdefault; we
   --  initialize it lazily instead.

   ------------------
   -- Search Paths --
   ------------------

   Primary_Directory : constant := 0;
   --  This is index in the tables created below for the first directory to
   --  search in for source or library information files. This is the directory
   --  containing the latest main input file (a source file for the compiler or
   --  a library file for the binder).

   package Src_Search_Directories is new Table.Table (
     Table_Component_Type => String_Ptr,
     Table_Index_Type     => Integer,
     Table_Low_Bound      => Primary_Directory,
     Table_Initial        => 10,
     Table_Increment      => 100,
     Table_Name           => "Osint.Src_Search_Directories");
   --  Table of names of directories in which to search for source (Compiler)
   --  files. This table is filled in the order in which the directories are
   --  to be searched, and then used in that order.

   package Lib_Search_Directories is new Table.Table (
     Table_Component_Type => String_Ptr,
     Table_Index_Type     => Integer,
     Table_Low_Bound      => Primary_Directory,
     Table_Initial        => 10,
     Table_Increment      => 100,
     Table_Name           => "Osint.Lib_Search_Directories");
   --  Table of names of directories in which to search for library (Binder)
   --  files. This table is filled in the order in which the directories are
   --  to be searched and then used in that order. The reason for having two
   --  distinct tables is that we need them both in gnatmake.

   ---------------------
   -- File Hash Table --
   ---------------------

   --  The file hash table is provided to free the programmer from any
   --  efficiency concern when retrieving full file names or time stamps of
   --  source files. If the programmer calls Source_File_Data (Cache => True)
   --  he is guaranteed that the price to retrieve the full name (i.e. with
   --  directory info) or time stamp of the file will be payed only once, the
   --  first time the full name is actually searched (or the first time the
   --  time stamp is actually retrieved). This is achieved by employing a hash
   --  table that stores as a key the File_Name_Type of the file and associates
   --  to that File_Name_Type the full file name and time stamp of the file.

   File_Cache_Enabled : Boolean := False;
   --  Set to true if you want the enable the file data caching mechanism

   type File_Hash_Num is range 0 .. 1020;

   function File_Hash (F : File_Name_Type) return File_Hash_Num;
   --  Compute hash index for use by Simple_HTable

   type File_Info_Cache is record
      File : File_Name_Type;
      Attr : aliased File_Attributes;
   end record;

   No_File_Info_Cache : constant File_Info_Cache :=
                          (No_File, Unknown_Attributes);

   package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable (
     Header_Num => File_Hash_Num,
     Element    => File_Info_Cache,
     No_Element => No_File_Info_Cache,
     Key        => File_Name_Type,
     Hash       => File_Hash,
     Equal      => "=");

   function Smart_Find_File
     (N : File_Name_Type;
      T : File_Type) return File_Name_Type;
   --  Exactly like Find_File except that if File_Cache_Enabled is True this
   --  routine looks first in the hash table to see if the full name of the
   --  file is already available.

   function Smart_File_Stamp
     (N : File_Name_Type;
      T : File_Type) return Time_Stamp_Type;
   --  Takes the same parameter as the routine above (N is a file name without
   --  any prefix directory information) and behaves like File_Stamp except
   --  that if File_Cache_Enabled is True this routine looks first in the hash
   --  table to see if the file stamp of the file is already available.

   -----------------------------
   -- Add_Default_Search_Dirs --
   -----------------------------

   procedure Add_Default_Search_Dirs is
      Search_Dir     : String_Access;
      Search_Path    : String_Access;
      Path_File_Name : String_Access;

      procedure Add_Search_Dir
        (Search_Dir            : String;
         Additional_Source_Dir : Boolean);
      procedure Add_Search_Dir
        (Search_Dir            : String_Access;
         Additional_Source_Dir : Boolean);
      --  Add a source search dir or a library search dir, depending on the
      --  value of Additional_Source_Dir.

      procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean);
      --  Open a path file and read the directory to search, one per line

      function Get_Libraries_From_Registry return String_Ptr;
      --  On Windows systems, get the list of installed standard libraries
      --  from the registry key:
      --
      --  HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
      --                             GNAT\Standard Libraries
      --  Return an empty string on other systems.
      --
      --  Note that this is an undocumented legacy feature, and that it
      --  works only when using the default runtime library (i.e. no --RTS=
      --  command line switch).

      --------------------
      -- Add_Search_Dir --
      --------------------

      procedure Add_Search_Dir
        (Search_Dir            : String;
         Additional_Source_Dir : Boolean)
      is
      begin
         if Additional_Source_Dir then
            Add_Src_Search_Dir (Search_Dir);
         else
            Add_Lib_Search_Dir (Search_Dir);
         end if;
      end Add_Search_Dir;

      procedure Add_Search_Dir
        (Search_Dir            : String_Access;
         Additional_Source_Dir : Boolean)
      is
      begin
         if Additional_Source_Dir then
            Add_Src_Search_Dir (Search_Dir.all);
         else
            Add_Lib_Search_Dir (Search_Dir.all);
         end if;
      end Add_Search_Dir;

      ------------------------
      -- Get_Dirs_From_File --
      ------------------------

      procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean) is
         File_FD    : File_Descriptor;
         Buffer     : constant String := Path_File_Name.all & ASCII.NUL;
         Len        : Natural;
         Actual_Len : Natural;
         S          : String_Access;
         Curr       : Natural;
         First      : Natural;
         Ch         : Character;

         Status : Boolean;
         pragma Warnings (Off, Status);
         --  For the call to Close where status is ignored

      begin
         File_FD := Open_Read (Buffer'Address, Binary);

         --  If we cannot open the file, we ignore it, we don't fail

         if File_FD = Invalid_FD then
            return;
         end if;

         Len := Integer (File_Length (File_FD));

         S := new String (1 .. Len);

         --  Read the file. Note that the loop is not necessary since the
         --  whole file is read at once except on VMS.

         Curr := 1;
         Actual_Len := Len;
         while Curr <= Len and then Actual_Len /= 0 loop
            Actual_Len := Read (File_FD, S (Curr)'Address, Len);
            Curr := Curr + Actual_Len;
         end loop;

         --  We are done with the file, so we close it (ignore any error on
         --  the close, since we have successfully read the file).

         Close (File_FD, Status);

         --  Now, we read line by line

         First := 1;
         Curr := 0;
         while Curr < Len loop
            Ch := S (Curr + 1);

            if Ch = ASCII.CR or else Ch = ASCII.LF
              or else Ch = ASCII.FF or else Ch = ASCII.VT
            then
               if First <= Curr then
                  Add_Search_Dir (S (First .. Curr), Additional_Source_Dir);
               end if;

               First := Curr + 2;
            end if;

            Curr := Curr + 1;
         end loop;

         --  Last line is a special case, if the file does not end with
         --  an end of line mark.

         if First <= S'Last then
            Add_Search_Dir (S (First .. S'Last), Additional_Source_Dir);
         end if;
      end Get_Dirs_From_File;

      ---------------------------------
      -- Get_Libraries_From_Registry --
      ---------------------------------

      function Get_Libraries_From_Registry return String_Ptr is
         function C_Get_Libraries_From_Registry return Address;
         pragma Import (C, C_Get_Libraries_From_Registry,
                        "__gnat_get_libraries_from_registry");

         function Strlen (Str : Address) return Integer;
         pragma Import (C, Strlen, "strlen");

         procedure Strncpy (X : Address; Y : Address; Length : Integer);
         pragma Import (C, Strncpy, "strncpy");

         procedure C_Free (Str : Address);
         pragma Import (C, C_Free, "free");

         Result_Ptr    : Address;
         Result_Length : Integer;
         Out_String    : String_Ptr;

      begin
         Result_Ptr := C_Get_Libraries_From_Registry;
         Result_Length := Strlen (Result_Ptr);

         Out_String := new String (1 .. Result_Length);
         Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);

         C_Free (Result_Ptr);

         return Out_String;
      end Get_Libraries_From_Registry;

   --  Start of processing for Add_Default_Search_Dirs

   begin
      --  After the locations specified on the command line, the next places
      --  to look for files are the directories specified by the appropriate
      --  environment variable. Get this value, extract the directory names
      --  and store in the tables.

      --  Check for eventual project path file env vars

      Path_File_Name := Getenv (Project_Include_Path_File);

      if Path_File_Name'Length > 0 then
         Get_Dirs_From_File (Additional_Source_Dir => True);
      end if;

      Path_File_Name := Getenv (Project_Objects_Path_File);

      if Path_File_Name'Length > 0 then
         Get_Dirs_From_File (Additional_Source_Dir => False);
      end if;

      --  On VMS, don't expand the logical name (e.g. environment variable),
      --  just put it into Unix (e.g. canonical) format. System services
      --  will handle the expansion as part of the file processing.

      for Additional_Source_Dir in False .. True loop
         if Additional_Source_Dir then
            Search_Path := Getenv (Ada_Include_Path);

            if Search_Path'Length > 0 then
               if Hostparm.OpenVMS then
                  Search_Path := To_Canonical_Path_Spec ("ADA_INCLUDE_PATH:");
               else
                  Search_Path := To_Canonical_Path_Spec (Search_Path.all);
               end if;
            end if;

         else
            Search_Path := Getenv (Ada_Objects_Path);

            if Search_Path'Length > 0 then
               if Hostparm.OpenVMS then
                  Search_Path := To_Canonical_Path_Spec ("ADA_OBJECTS_PATH:");
               else
                  Search_Path := To_Canonical_Path_Spec (Search_Path.all);
               end if;
            end if;
         end if;

         Get_Next_Dir_In_Path_Init (Search_Path);
         loop
            Search_Dir := Get_Next_Dir_In_Path (Search_Path);
            exit when Search_Dir = null;
            Add_Search_Dir (Search_Dir, Additional_Source_Dir);
         end loop;
      end loop;

      --  For the compiler, if --RTS= was specified, add the runtime
      --  directories.

      if RTS_Src_Path_Name /= null
        and then RTS_Lib_Path_Name /= null
      then
         Add_Search_Dirs (RTS_Src_Path_Name, Include);
         Add_Search_Dirs (RTS_Lib_Path_Name, Objects);

      else
         if not Opt.No_Stdinc then

            --  For WIN32 systems, look for any system libraries defined in
            --  the registry. These are added to both source and object
            --  directories.

            Search_Path := String_Access (Get_Libraries_From_Registry);

            Get_Next_Dir_In_Path_Init (Search_Path);
            loop
               Search_Dir := Get_Next_Dir_In_Path (Search_Path);
               exit when Search_Dir = null;
               Add_Search_Dir (Search_Dir, False);
               Add_Search_Dir (Search_Dir, True);
            end loop;

            --  The last place to look are the defaults

            Search_Path :=
              Read_Default_Search_Dirs
                (String_Access (Update_Path (Search_Dir_Prefix)),
                 Include_Search_File,
                 String_Access (Update_Path (Include_Dir_Default_Name)));

            Get_Next_Dir_In_Path_Init (Search_Path);
            loop
               Search_Dir := Get_Next_Dir_In_Path (Search_Path);
               exit when Search_Dir = null;
               Add_Search_Dir (Search_Dir, True);
            end loop;
         end if;

         --  Even when -nostdlib is used, we still want to have visibility on
         --  the run-time object directory, as it is used by gnatbind to find
         --  the run-time ALI files in "real" ZFP set up.

         if not Opt.RTS_Switch then
            Search_Path :=
              Read_Default_Search_Dirs
                (String_Access (Update_Path (Search_Dir_Prefix)),
                 Objects_Search_File,
                 String_Access (Update_Path (Object_Dir_Default_Name)));

            Get_Next_Dir_In_Path_Init (Search_Path);
            loop
               Search_Dir := Get_Next_Dir_In_Path (Search_Path);
               exit when Search_Dir = null;
               Add_Search_Dir (Search_Dir, False);
            end loop;
         end if;
      end if;
   end Add_Default_Search_Dirs;

   --------------
   -- Add_File --
   --------------

   procedure Add_File (File_Name : String; Index : Int := No_Index) is
   begin
      Number_File_Names := Number_File_Names + 1;

      --  As Add_File may be called for mains specified inside a project file,
      --  File_Names may be too short and needs to be extended.

      if Number_File_Names > File_Names'Last then
         File_Names := new File_Name_Array'(File_Names.all & File_Names.all);
         File_Indexes :=
           new File_Index_Array'(File_Indexes.all & File_Indexes.all);
      end if;

      File_Names   (Number_File_Names) := new String'(File_Name);
      File_Indexes (Number_File_Names) := Index;
   end Add_File;

   ------------------------
   -- Add_Lib_Search_Dir --
   ------------------------

   procedure Add_Lib_Search_Dir (Dir : String) is
   begin
      if Dir'Length = 0 then
         Fail ("missing library directory name");
      end if;

      declare
         Norm : String_Ptr := Normalize_Directory_Name (Dir);

      begin
         --  Do nothing if the directory is already in the list. This saves
         --  system calls and avoid unneeded work

         for D in Lib_Search_Directories.First ..
                  Lib_Search_Directories.Last
         loop
            if Lib_Search_Directories.Table (D).all = Norm.all then
               Free (Norm);
               return;
            end if;
         end loop;

         Lib_Search_Directories.Increment_Last;
         Lib_Search_Directories.Table (Lib_Search_Directories.Last) := Norm;
      end;
   end Add_Lib_Search_Dir;

   ---------------------
   -- Add_Search_Dirs --
   ---------------------

   procedure Add_Search_Dirs
     (Search_Path : String_Ptr;
      Path_Type   : Search_File_Type)
   is
      Current_Search_Path : String_Access;

   begin
      Get_Next_Dir_In_Path_Init (String_Access (Search_Path));
      loop
         Current_Search_Path :=
           Get_Next_Dir_In_Path (String_Access (Search_Path));
         exit when Current_Search_Path = null;

         if Path_Type = Include then
            Add_Src_Search_Dir (Current_Search_Path.all);
         else
            Add_Lib_Search_Dir (Current_Search_Path.all);
         end if;
      end loop;
   end Add_Search_Dirs;

   ------------------------
   -- Add_Src_Search_Dir --
   ------------------------

   procedure Add_Src_Search_Dir (Dir : String) is
   begin
      if Dir'Length = 0 then
         Fail ("missing source directory name");
      end if;

      Src_Search_Directories.Increment_Last;
      Src_Search_Directories.Table (Src_Search_Directories.Last) :=
        Normalize_Directory_Name (Dir);
   end Add_Src_Search_Dir;

   --------------------------------
   -- Append_Suffix_To_File_Name --
   --------------------------------

   function Append_Suffix_To_File_Name
     (Name   : File_Name_Type;
      Suffix : String) return File_Name_Type
   is
   begin
      Get_Name_String (Name);
      Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
      Name_Len := Name_Len + Suffix'Length;
      return Name_Find;
   end Append_Suffix_To_File_Name;

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

   ------------------------------
   -- Canonical_Case_File_Name --
   ------------------------------

   procedure Canonical_Case_File_Name (S : in out String) is
   begin
      if not File_Names_Case_Sensitive then
         To_Lower (S);
      end if;
   end Canonical_Case_File_Name;

   ---------------------------------
   -- Canonical_Case_Env_Var_Name --
   ---------------------------------

   procedure Canonical_Case_Env_Var_Name (S : in out String) is
   begin
      if not Env_Vars_Case_Sensitive then
         To_Lower (S);
      end if;
   end Canonical_Case_Env_Var_Name;

   ---------------------------
   -- Create_File_And_Check --
   ---------------------------

   procedure Create_File_And_Check
     (Fdesc : out File_Descriptor;
      Fmode : Mode)
   is
   begin
      Output_File_Name := Name_Enter;
      Fdesc := Create_File (Name_Buffer'Address, Fmode);

      if Fdesc = Invalid_FD then
         Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
      end if;
   end Create_File_And_Check;

   ------------------------
   -- Current_File_Index --
   ------------------------

   function Current_File_Index return Int is
   begin
      return File_Indexes (Current_File_Name_Index);
   end Current_File_Index;

   --------------------------------
   -- Current_Library_File_Stamp --
   --------------------------------

   function Current_Library_File_Stamp return Time_Stamp_Type is
   begin
      return Current_Full_Lib_Stamp;
   end Current_Library_File_Stamp;

   -------------------------------
   -- Current_Object_File_Stamp --
   -------------------------------

   function Current_Object_File_Stamp return Time_Stamp_Type is
   begin
      return Current_Full_Obj_Stamp;
   end Current_Object_File_Stamp;

   -------------------------------
   -- Current_Source_File_Stamp --
   -------------------------------

   function Current_Source_File_Stamp return Time_Stamp_Type is
   begin
      return Current_Full_Source_Stamp;
   end Current_Source_File_Stamp;

   ----------------------------
   -- Dir_In_Obj_Search_Path --
   ----------------------------

   function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is
   begin
      if Opt.Look_In_Primary_Dir then
         return
           Lib_Search_Directories.Table (Primary_Directory + Position - 1);
      else
         return Lib_Search_Directories.Table (Primary_Directory + Position);
      end if;
   end Dir_In_Obj_Search_Path;

   ----------------------------
   -- Dir_In_Src_Search_Path --
   ----------------------------

   function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is
   begin
      if Opt.Look_In_Primary_Dir then
         return
           Src_Search_Directories.Table (Primary_Directory + Position - 1);
      else
         return Src_Search_Directories.Table (Primary_Directory + Position);
      end if;
   end Dir_In_Src_Search_Path;

   ----------------------------
   -- Dump_Source_File_Names --
   ----------------------------

   procedure Dump_Source_File_Names is
      subtype Rng is Int range File_Name_Chars.First .. File_Name_Chars.Last;
   begin
      Write_Str (String (File_Name_Chars.Table (Rng)));
   end Dump_Source_File_Names;

   ---------------------
   -- Executable_Name --
   ---------------------

   function Executable_Name
     (Name              : File_Name_Type;
      Only_If_No_Suffix : Boolean := False) return File_Name_Type
   is
      Exec_Suffix : String_Access;
      Add_Suffix  : Boolean;

   begin
      if Name = No_File then
         return No_File;
      end if;

      if Executable_Extension_On_Target = No_Name then
         Exec_Suffix := Get_Target_Executable_Suffix;
      else
         Get_Name_String (Executable_Extension_On_Target);
         Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
      end if;

      if Exec_Suffix'Length /= 0 then
         Get_Name_String (Name);

         Add_Suffix := True;
         if Only_If_No_Suffix then
            for J in reverse 1 .. Name_Len loop
               if Name_Buffer (J) = '.' then
                  Add_Suffix := False;
                  exit;

               elsif Name_Buffer (J) = '/' or else
                     Name_Buffer (J) = Directory_Separator
               then
                  exit;
               end if;
            end loop;
         end if;

         if Add_Suffix then
            declare
               Buffer : String := Name_Buffer (1 .. Name_Len);

            begin
               --  Get the file name in canonical case to accept as is names
               --  ending with ".EXE" on VMS and Windows.

               Canonical_Case_File_Name (Buffer);

               --  If Executable does not end with the executable suffix, add
               --  it.

               if Buffer'Length <= Exec_Suffix'Length
                 or else
                   Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last)
                     /= Exec_Suffix.all
               then
                  Name_Buffer
                    (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
                      Exec_Suffix.all;
                  Name_Len := Name_Len + Exec_Suffix'Length;
                  Free (Exec_Suffix);
                  return Name_Find;
               end if;
            end;
         end if;
      end if;

      Free (Exec_Suffix);
      return Name;
   end Executable_Name;

   function Executable_Name
     (Name              : String;
      Only_If_No_Suffix : Boolean := False) return String
   is
      Exec_Suffix    : String_Access;
      Add_Suffix     : Boolean;
      Canonical_Name : String := Name;

   begin
      if Executable_Extension_On_Target = No_Name then
         Exec_Suffix := Get_Target_Executable_Suffix;
      else
         Get_Name_String (Executable_Extension_On_Target);
         Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
      end if;

      if Exec_Suffix'Length = 0 then
         Free (Exec_Suffix);
         return Name;

      else
         declare
            Suffix : constant String := Exec_Suffix.all;

         begin
            Free (Exec_Suffix);
            Canonical_Case_File_Name (Canonical_Name);

            Add_Suffix := True;
            if Only_If_No_Suffix then
               for J in reverse Canonical_Name'Range loop
                  if Canonical_Name (J) = '.' then
                     Add_Suffix := False;
                     exit;

                  elsif Canonical_Name (J) = '/' or else
                        Canonical_Name (J) = Directory_Separator
                  then
                     exit;
                  end if;
               end loop;
            end if;

            if Add_Suffix and then
              (Canonical_Name'Length <= Suffix'Length
               or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
                                       .. Canonical_Name'Last) /= Suffix)
            then
               declare
                  Result : String (1 .. Name'Length + Suffix'Length);
               begin
                  Result (1 .. Name'Length) := Name;
                  Result (Name'Length + 1 .. Result'Last) := Suffix;
                  return Result;
               end;
            else
               return Name;
            end if;
         end;
      end if;
   end Executable_Name;

   -----------------------
   -- Executable_Prefix --
   -----------------------

   function Executable_Prefix return String_Ptr is

      function Get_Install_Dir (Exec : String) return String_Ptr;
      --  S is the executable name preceded by the absolute or relative
      --  path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".

      ---------------------
      -- Get_Install_Dir --
      ---------------------

      function Get_Install_Dir (Exec : String) return String_Ptr is
         Full_Path : constant String := Normalize_Pathname (Exec);
         --  Use the full path, so that we find "lib" or "bin", even when
         --  the tool has been invoked with a relative path, as in
         --  "./gnatls -v" invoked in the GNAT bin directory.

      begin
         for J in reverse Full_Path'Range loop
            if Is_Directory_Separator (Full_Path (J)) then
               if J < Full_Path'Last - 5 then
                  if (To_Lower (Full_Path (J + 1)) = 'l'
                      and then To_Lower (Full_Path (J + 2)) = 'i'
                      and then To_Lower (Full_Path (J + 3)) = 'b')
                    or else
                      (To_Lower (Full_Path (J + 1)) = 'b'
                       and then To_Lower (Full_Path (J + 2)) = 'i'
                       and then To_Lower (Full_Path (J + 3)) = 'n')
                  then
                     return new String'(Full_Path (Full_Path'First .. J));
                  end if;
               end if;
            end if;
         end loop;

         return new String'("");
      end Get_Install_Dir;

   --  Start of processing for Executable_Prefix

   begin
      if Exec_Name = null then
         Exec_Name := new String (1 .. Len_Arg (0));
         Osint.Fill_Arg (Exec_Name (1)'Address, 0);
      end if;

      --  First determine if a path prefix was placed in front of the
      --  executable name.

      for J in reverse Exec_Name'Range loop
         if Is_Directory_Separator (Exec_Name (J)) then
            return Get_Install_Dir (Exec_Name.all);
         end if;
      end loop;

      --  If we come here, the user has typed the executable name with no
      --  directory prefix.

      return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all);
   end Executable_Prefix;

   ------------------
   -- Exit_Program --
   ------------------

   procedure Exit_Program (Exit_Code : Exit_Code_Type) is
   begin
      --  The program will exit with the following status:

      --    0 if the object file has been generated (with or without warnings)
      --    1 if recompilation was not needed (smart recompilation)
      --    2 if gnat1 has been killed by a signal (detected by GCC)
      --    4 for a fatal error
      --    5 if there were errors
      --    6 if no code has been generated (spec)

      --  Note that exit code 3 is not used and must not be used as this is
      --  the code returned by a program aborted via C abort() routine on
      --  Windows. GCC checks for that case and thinks that the child process
      --  has been aborted. This code (exit code 3) used to be the code used
      --  for E_No_Code, but E_No_Code was changed to 6 for this reason.

      case Exit_Code is
         when E_Success    => OS_Exit (0);
         when E_Warnings   => OS_Exit (0);
         when E_No_Compile => OS_Exit (1);
         when E_Fatal      => OS_Exit (4);
         when E_Errors     => OS_Exit (5);
         when E_No_Code    => OS_Exit (6);
         when E_Abort      => OS_Abort;
      end case;
   end Exit_Program;

   ----------
   -- Fail --
   ----------

   procedure Fail (S : String) is
   begin
      --  We use Output in case there is a special output set up.
      --  In this case Set_Standard_Error will have no immediate effect.

      Set_Standard_Error;
      Osint.Write_Program_Name;
      Write_Str (": ");
      Write_Str (S);
      Write_Eol;

      Exit_Program (E_Fatal);
   end Fail;

   ---------------
   -- File_Hash --
   ---------------

   function File_Hash (F : File_Name_Type) return File_Hash_Num is
   begin
      return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
   end File_Hash;

   -----------------
   -- File_Length --
   -----------------

   function File_Length
     (Name : C_File_Name;
      Attr : access File_Attributes) return Long_Integer
   is
      function Internal
        (F : Integer;
         N : C_File_Name;
         A : System.Address) return Long_Integer;
      pragma Import (C, Internal, "__gnat_file_length_attr");
   begin
      return Internal (-1, Name, Attr.all'Address);
   end File_Length;

   ---------------------
   -- File_Time_Stamp --
   ---------------------

   function File_Time_Stamp
     (Name : C_File_Name;
      Attr : access File_Attributes) return OS_Time
   is
      function Internal (N : C_File_Name; A : System.Address) return OS_Time;
      pragma Import (C, Internal, "__gnat_file_time_name_attr");
   begin
      return Internal (Name, Attr.all'Address);
   end File_Time_Stamp;

   function File_Time_Stamp
     (Name : Path_Name_Type;
      Attr : access File_Attributes) return Time_Stamp_Type
   is
   begin
      if Name = No_Path then
         return Empty_Time_Stamp;
      end if;

      Get_Name_String (Name);
      Name_Buffer (Name_Len + 1) := ASCII.NUL;
      return OS_Time_To_GNAT_Time
               (File_Time_Stamp (Name_Buffer'Address, Attr));
   end File_Time_Stamp;

   ----------------
   -- File_Stamp --
   ----------------

   function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
   begin
      if Name = No_File then
         return Empty_Time_Stamp;
      end if;

      Get_Name_String (Name);

      --  File_Time_Stamp will always return Invalid_Time if the file does
      --  not exist, and OS_Time_To_GNAT_Time will convert this value to
      --  Empty_Time_Stamp. Therefore we do not need to first test whether
      --  the file actually exists, which saves a system call.

      return OS_Time_To_GNAT_Time
               (File_Time_Stamp (Name_Buffer (1 .. Name_Len)));
   end File_Stamp;

   function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is
   begin
      return File_Stamp (File_Name_Type (Name));
   end File_Stamp;

   ---------------
   -- Find_File --
   ---------------

   function Find_File
     (N : File_Name_Type;
      T : File_Type) return File_Name_Type
   is
      Attr  : aliased File_Attributes;
      Found : File_Name_Type;
   begin
      Find_File (N, T, Found, Attr'Access);
      return Found;
   end Find_File;

   ---------------
   -- Find_File --
   ---------------

   procedure Find_File
     (N     : File_Name_Type;
      T     : File_Type;
      Found : out File_Name_Type;
      Attr  : access File_Attributes) is
   begin
      Get_Name_String (N);

      declare
         File_Name : String renames Name_Buffer (1 .. Name_Len);
         File      : File_Name_Type := No_File;
         Last_Dir  : Natural;

      begin
         --  If we are looking for a config file, look only in the current
         --  directory, i.e. return input argument unchanged. Also look only in
         --  the current directory if we are looking for a .dg file (happens in
         --  -gnatD mode).

         if T = Config
           or else (Debug_Generated_Code
                      and then Name_Len > 3
                      and then
                      (Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg"
                       or else
                       (Hostparm.OpenVMS and then
                        Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg")))
         then
            Found := N;
            Attr.all  := Unknown_Attributes;
            return;

         --  If we are trying to find the current main file just look in the
         --  directory where the user said it was.

         elsif Look_In_Primary_Directory_For_Current_Main
           and then Current_Main = N
         then
            Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
            return;

         --  Otherwise do standard search for source file

         else
            --  Check the mapping of this file name

            File := Mapped_Path_Name (N);

            --  If the file name is mapped to a path name, return the
            --  corresponding path name

            if File /= No_File then

               --  For locally removed file, Error_Name is returned; then
               --  return No_File, indicating the file is not a source.

               if File = Error_File_Name then
                  Found := No_File;
               else
                  Found := File;
               end if;

               Attr.all := Unknown_Attributes;
               return;
            end if;

            --  First place to look is in the primary directory (i.e. the same
            --  directory as the source) unless this has been disabled with -I-

            if Opt.Look_In_Primary_Dir then
               Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);

               if Found /= No_File then
                  return;
               end if;
            end if;

            --  Finally look in directories specified with switches -I/-aI/-aO

            if T = Library then
               Last_Dir := Lib_Search_Directories.Last;
            else
               Last_Dir := Src_Search_Directories.Last;
            end if;

            for D in Primary_Directory + 1 .. Last_Dir loop
               Locate_File (N, T, D, File_Name, Found, Attr);

               if Found /= No_File then
                  return;
               end if;
            end loop;

            Attr.all := Unknown_Attributes;
            Found := No_File;
         end if;
      end;
   end Find_File;

   -----------------------
   -- Find_Program_Name --
   -----------------------

   procedure Find_Program_Name is
      Command_Name : String (1 .. Len_Arg (0));
      Cindex1      : Integer := Command_Name'First;
      Cindex2      : Integer := Command_Name'Last;

   begin
      Fill_Arg (Command_Name'Address, 0);

      if Command_Name = "" then
         Name_Len := 0;
         return;
      end if;

      --  The program name might be specified by a full path name. However,
      --  we don't want to print that all out in an error message, so the
      --  path might need to be stripped away.

      for J in reverse Cindex1 .. Cindex2 loop
         if Is_Directory_Separator (Command_Name (J)) then
            Cindex1 := J + 1;
            exit;
         end if;
      end loop;

      --  Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
      --  POSIX command "basename argv[0]"

      --  Strip off any versioning information such as found on VMS.
      --  This would take the form of TOOL.exe followed by a ";" or "."
      --  and a sequence of one or more numbers.

      if Command_Name (Cindex2) in '0' .. '9' then
         for J in reverse Cindex1 .. Cindex2 loop
            if Command_Name (J) = '.' or else Command_Name (J) = ';' then
               Cindex2 := J - 1;
               exit;
            end if;

            exit when Command_Name (J) not in '0' .. '9';
         end loop;
      end if;

      --  Strip off any executable extension (usually nothing or .exe)
      --  but formally reported by autoconf in the variable EXEEXT

      if Cindex2 - Cindex1 >= 4 then
         if To_Lower (Command_Name (Cindex2 - 3)) = '.'
            and then To_Lower (Command_Name (Cindex2 - 2)) = 'e'
            and then To_Lower (Command_Name (Cindex2 - 1)) = 'x'
            and then To_Lower (Command_Name (Cindex2)) = 'e'
         then
            Cindex2 := Cindex2 - 4;
         end if;
      end if;

      Name_Len := Cindex2 - Cindex1 + 1;
      Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
   end Find_Program_Name;

   ------------------------
   -- Full_Lib_File_Name --
   ------------------------

   procedure Full_Lib_File_Name
     (N        : File_Name_Type;
      Lib_File : out File_Name_Type;
      Attr     : out File_Attributes)
   is
      A : aliased File_Attributes;
   begin
      --  ??? seems we could use Smart_Find_File here
      Find_File (N, Library, Lib_File, A'Access);
      Attr := A;
   end Full_Lib_File_Name;

   ------------------------
   -- Full_Lib_File_Name --
   ------------------------

   function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
      Attr : File_Attributes;
      File : File_Name_Type;
   begin
      Full_Lib_File_Name (N, File, Attr);
      return File;
   end Full_Lib_File_Name;

   ----------------------------
   -- Full_Library_Info_Name --
   ----------------------------

   function Full_Library_Info_Name return File_Name_Type is
   begin
      return Current_Full_Lib_Name;
   end Full_Library_Info_Name;

   ---------------------------
   -- Full_Object_File_Name --
   ---------------------------

   function Full_Object_File_Name return File_Name_Type is
   begin
      return Current_Full_Obj_Name;
   end Full_Object_File_Name;

   ----------------------
   -- Full_Source_Name --
   ----------------------

   function Full_Source_Name return File_Name_Type is
   begin
      return Current_Full_Source_Name;
   end Full_Source_Name;

   ----------------------
   -- Full_Source_Name --
   ----------------------

   function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
   begin
      return Smart_Find_File (N, Source);
   end Full_Source_Name;

   ----------------------
   -- Full_Source_Name --
   ----------------------

   procedure Full_Source_Name
     (N         : File_Name_Type;
      Full_File : out File_Name_Type;
      Attr      : access File_Attributes) is
   begin
      Smart_Find_File (N, Source, Full_File, Attr.all);
   end Full_Source_Name;

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

   function Get_Directory (Name : File_Name_Type) return File_Name_Type is
   begin
      Get_Name_String (Name);

      for J in reverse 1 .. Name_Len loop
         if Is_Directory_Separator (Name_Buffer (J)) then
            Name_Len := J;
            return Name_Find;
         end if;
      end loop;

      Name_Len := Hostparm.Normalized_CWD'Length;
      Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
      return Name_Find;
   end Get_Directory;

   --------------------------
   -- Get_Next_Dir_In_Path --
   --------------------------

   Search_Path_Pos : Integer;
   --  Keeps track of current position in search path. Initialized by the
   --  call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.

   function Get_Next_Dir_In_Path
     (Search_Path : String_Access) return String_Access
   is
      Lower_Bound : Positive := Search_Path_Pos;
      Upper_Bound : Positive;

   begin
      loop
         while Lower_Bound <= Search_Path'Last
           and then Search_Path.all (Lower_Bound) = Path_Separator
         loop
            Lower_Bound := Lower_Bound + 1;
         end loop;

         exit when Lower_Bound > Search_Path'Last;

         Upper_Bound := Lower_Bound;
         while Upper_Bound <= Search_Path'Last
           and then Search_Path.all (Upper_Bound) /= Path_Separator
         loop
            Upper_Bound := Upper_Bound + 1;
         end loop;

         Search_Path_Pos := Upper_Bound;
         return new String'(Search_Path.all (Lower_Bound .. Upper_Bound - 1));
      end loop;

      return null;
   end Get_Next_Dir_In_Path;

   -------------------------------
   -- Get_Next_Dir_In_Path_Init --
   -------------------------------

   procedure Get_Next_Dir_In_Path_Init (Search_Path : String_Access) is
   begin
      Search_Path_Pos := Search_Path'First;
   end Get_Next_Dir_In_Path_Init;

   --------------------------------------
   -- Get_Primary_Src_Search_Directory --
   --------------------------------------

   function Get_Primary_Src_Search_Directory return String_Ptr is
   begin
      return Src_Search_Directories.Table (Primary_Directory);
   end Get_Primary_Src_Search_Directory;

   ------------------------
   -- Get_RTS_Search_Dir --
   ------------------------

   function Get_RTS_Search_Dir
     (Search_Dir : String;
      File_Type  : Search_File_Type) return String_Ptr
   is
      procedure Get_Current_Dir
        (Dir    : System.Address;
         Length : System.Address);
      pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");

      Max_Path : Integer;
      pragma Import (C, Max_Path, "__gnat_max_path_len");
      --  Maximum length of a path name

      Current_Dir        : String_Ptr;
      Default_Search_Dir : String_Access;
      Default_Suffix_Dir : String_Access;
      Local_Search_Dir   : String_Access;
      Norm_Search_Dir    : String_Access;
      Result_Search_Dir  : String_Access;
      Search_File        : String_Access;
      Temp_String        : String_Ptr;

   begin
      --  Add a directory separator at the end of the directory if necessary
      --  so that we can directly append a file to the directory

      if Search_Dir (Search_Dir'Last) /= Directory_Separator then
         Local_Search_Dir :=
           new String'(Search_Dir & String'(1 => Directory_Separator));
      else
         Local_Search_Dir := new String'(Search_Dir);
      end if;

      if File_Type = Include then
         Search_File := Include_Search_File;
         Default_Suffix_Dir := new String'("adainclude");
      else
         Search_File := Objects_Search_File;
         Default_Suffix_Dir := new String'("adalib");
      end if;

      Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all);

      if Is_Absolute_Path (Norm_Search_Dir.all) then

         --  We first verify if there is a directory Include_Search_Dir
         --  containing default search directories

         Result_Search_Dir :=
           Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
         Default_Search_Dir :=
           new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
         Free (Norm_Search_Dir);

         if Result_Search_Dir /= null then
            return String_Ptr (Result_Search_Dir);
         elsif Is_Directory (Default_Search_Dir.all) then
            return String_Ptr (Default_Search_Dir);
         else
            return null;
         end if;

      --  Search in the current directory

      else
         --  Get the current directory

         declare
            Buffer   : String (1 .. Max_Path + 2);
            Path_Len : Natural := Max_Path;

         begin
            Get_Current_Dir (Buffer'Address, Path_Len'Address);

            if Buffer (Path_Len) /= Directory_Separator then
               Path_Len := Path_Len + 1;
               Buffer (Path_Len) := Directory_Separator;
            end if;

            Current_Dir := new String'(Buffer (1 .. Path_Len));
         end;

         Norm_Search_Dir :=
           new String'(Current_Dir.all & Local_Search_Dir.all);

         Result_Search_Dir :=
           Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);

         Default_Search_Dir :=
           new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);

         Free (Norm_Search_Dir);

         if Result_Search_Dir /= null then
            return String_Ptr (Result_Search_Dir);

         elsif Is_Directory (Default_Search_Dir.all) then
            return String_Ptr (Default_Search_Dir);

         else
            --  Search in Search_Dir_Prefix/Search_Dir

            Norm_Search_Dir :=
              new String'
               (Update_Path (Search_Dir_Prefix).all & Local_Search_Dir.all);

            Result_Search_Dir :=
              Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);

            Default_Search_Dir :=
              new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);

            Free (Norm_Search_Dir);

            if Result_Search_Dir /= null then
               return String_Ptr (Result_Search_Dir);

            elsif Is_Directory (Default_Search_Dir.all) then
               return String_Ptr (Default_Search_Dir);

            else
               --  We finally search in Search_Dir_Prefix/rts-Search_Dir

               Temp_String :=
                 new String'(Update_Path (Search_Dir_Prefix).all & "rts-");

               Norm_Search_Dir :=
                 new String'(Temp_String.all & Local_Search_Dir.all);

               Result_Search_Dir :=
                 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);

               Default_Search_Dir :=
                 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
               Free (Norm_Search_Dir);

               if Result_Search_Dir /= null then
                  return String_Ptr (Result_Search_Dir);

               elsif Is_Directory (Default_Search_Dir.all) then
                  return String_Ptr (Default_Search_Dir);

               else
                  return null;
               end if;
            end if;
         end if;
      end if;
   end Get_RTS_Search_Dir;

   --------------------------------
   -- Include_Dir_Default_Prefix --
   --------------------------------

   function Include_Dir_Default_Prefix return String_Access is
   begin
      if The_Include_Dir_Default_Prefix = null then
         The_Include_Dir_Default_Prefix :=
           String_Access (Update_Path (Include_Dir_Default_Name));
      end if;

      return The_Include_Dir_Default_Prefix;
   end Include_Dir_Default_Prefix;

   function Include_Dir_Default_Prefix return String is
   begin
      return Include_Dir_Default_Prefix.all;
   end Include_Dir_Default_Prefix;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
   begin
      Number_File_Names       := 0;
      Current_File_Name_Index := 0;

      Src_Search_Directories.Init;
      Lib_Search_Directories.Init;

      --  Start off by setting all suppress options to False, these will
      --  be reset later (turning some on if -gnato is not specified, and
      --  turning all of them on if -gnatp is specified).

      Suppress_Options := (others => False);

      --  Reserve the first slot in the search paths table. This is the
      --  directory of the main source file or main library file and is filled
      --  in by each call to Next_Main_Source/Next_Main_Lib_File with the
      --  directory specified for this main source or library file. This is the
      --  directory which is searched first by default. This default search is
      --  inhibited by the option -I- for both source and library files.

      Src_Search_Directories.Set_Last (Primary_Directory);
      Src_Search_Directories.Table (Primary_Directory) := new String'("");

      Lib_Search_Directories.Set_Last (Primary_Directory);
      Lib_Search_Directories.Table (Primary_Directory) := new String'("");
   end Initialize;

   ------------------
   -- Is_Directory --
   ------------------

   function Is_Directory
     (Name : C_File_Name; Attr : access File_Attributes) return Boolean
   is
      function Internal (N : C_File_Name; A : System.Address) return Integer;
      pragma Import (C, Internal, "__gnat_is_directory_attr");
   begin
      return Internal (Name, Attr.all'Address) /= 0;
   end Is_Directory;

   ----------------------------
   -- Is_Directory_Separator --
   ----------------------------

   function Is_Directory_Separator (C : Character) return Boolean is
   begin
      --  In addition to the default directory_separator allow the '/' to
      --  act as separator since this is allowed in MS-DOS, Windows 95/NT,
      --  and OS2 ports. On VMS, the situation is more complicated because
      --  there are two characters to check for.

      return
        C = Directory_Separator
          or else C = '/'
          or else (Hostparm.OpenVMS
                    and then (C = ']' or else C = ':'));
   end Is_Directory_Separator;

   -------------------------
   -- Is_Readonly_Library --
   -------------------------

   function Is_Readonly_Library (File : File_Name_Type) return Boolean is
   begin
      Get_Name_String (File);

      pragma Assert (Name_Buffer (Name_Len - 3 .. Name_Len) = ".ali");

      return not Is_Writable_File (Name_Buffer (1 .. Name_Len));
   end Is_Readonly_Library;

   ------------------------
   -- Is_Executable_File --
   ------------------------

   function Is_Executable_File
     (Name : C_File_Name; Attr : access File_Attributes) return Boolean
   is
      function Internal (N : C_File_Name; A : System.Address) return Integer;
      pragma Import (C, Internal, "__gnat_is_executable_file_attr");
   begin
      return Internal (Name, Attr.all'Address) /= 0;
   end Is_Executable_File;

   ----------------------
   -- Is_Readable_File --
   ----------------------

   function Is_Readable_File
     (Name : C_File_Name; Attr : access File_Attributes) return Boolean
   is
      function Internal (N : C_File_Name; A : System.Address) return Integer;
      pragma Import (C, Internal, "__gnat_is_readable_file_attr");
   begin
      return Internal (Name, Attr.all'Address) /= 0;
   end Is_Readable_File;

   ---------------------
   -- Is_Regular_File --
   ---------------------

   function Is_Regular_File
     (Name : C_File_Name; Attr : access File_Attributes) return Boolean
   is
      function Internal (N : C_File_Name; A : System.Address) return Integer;
      pragma Import (C, Internal, "__gnat_is_regular_file_attr");
   begin
      return Internal (Name, Attr.all'Address) /= 0;
   end Is_Regular_File;

   ----------------------
   -- Is_Symbolic_Link --
   ----------------------

   function Is_Symbolic_Link
     (Name : C_File_Name; Attr : access File_Attributes) return Boolean
   is
      function Internal (N : C_File_Name; A : System.Address) return Integer;
      pragma Import (C, Internal, "__gnat_is_symbolic_link_attr");
   begin
      return Internal (Name, Attr.all'Address) /= 0;
   end Is_Symbolic_Link;

   ----------------------
   -- Is_Writable_File --
   ----------------------

   function Is_Writable_File
     (Name : C_File_Name; Attr : access File_Attributes) return Boolean
   is
      function Internal (N : C_File_Name; A : System.Address) return Integer;
      pragma Import (C, Internal, "__gnat_is_writable_file_attr");
   begin
      return Internal (Name, Attr.all'Address) /= 0;
   end Is_Writable_File;

   -------------------
   -- Lib_File_Name --
   -------------------

   function Lib_File_Name
     (Source_File : File_Name_Type;
      Munit_Index : Nat := 0) return File_Name_Type
   is
   begin
      Get_Name_String (Source_File);

      for J in reverse 2 .. Name_Len loop
         if Name_Buffer (J) = '.' then
            Name_Len := J - 1;
            exit;
         end if;
      end loop;

      if Munit_Index /= 0 then
         Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
         Add_Nat_To_Name_Buffer (Munit_Index);
      end if;

      Add_Char_To_Name_Buffer ('.');
      Add_Str_To_Name_Buffer (ALI_Suffix.all);
      return Name_Find;
   end Lib_File_Name;

   -----------------
   -- Locate_File --
   -----------------

   procedure Locate_File
     (N     : File_Name_Type;
      T     : File_Type;
      Dir   : Natural;
      Name  : String;
      Found : out File_Name_Type;
      Attr  : access File_Attributes)
   is
      Dir_Name : String_Ptr;

   begin
      --  If Name is already an absolute path, do not look for a directory

      if Is_Absolute_Path (Name) then
         Dir_Name := No_Dir;

      elsif T = Library then
         Dir_Name := Lib_Search_Directories.Table (Dir);

      else
         pragma Assert (T /= Config);
         Dir_Name := Src_Search_Directories.Table (Dir);
      end if;

      declare
         Full_Name : String (1 .. Dir_Name'Length + Name'Length + 1);

      begin
         Full_Name (1 .. Dir_Name'Length) := Dir_Name.all;
         Full_Name (Dir_Name'Length + 1 .. Full_Name'Last - 1) := Name;
         Full_Name (Full_Name'Last) := ASCII.NUL;

         Attr.all := Unknown_Attributes;

         if not Is_Regular_File (Full_Name'Address, Attr) then
            Found := No_File;

         else
            --  If the file is in the current directory then return N itself

            if Dir_Name'Length = 0 then
               Found := N;
            else
               Name_Len := Full_Name'Length - 1;
               Name_Buffer (1 .. Name_Len) :=
                 Full_Name (1 .. Full_Name'Last - 1);
               Found := Name_Find;  --  ??? Was Name_Enter, no obvious reason
            end if;
         end if;
      end;
   end Locate_File;

   -------------------------------
   -- Matching_Full_Source_Name --
   -------------------------------

   function Matching_Full_Source_Name
     (N : File_Name_Type;
      T : Time_Stamp_Type) return File_Name_Type
   is
   begin
      Get_Name_String (N);

      declare
         File_Name : constant String := Name_Buffer (1 .. Name_Len);
         File      : File_Name_Type := No_File;
         Attr      : aliased File_Attributes;
         Last_Dir  : Natural;

      begin
         if Opt.Look_In_Primary_Dir then
            Locate_File
              (N, Source, Primary_Directory, File_Name, File, Attr'Access);

            if File /= No_File and then T = File_Stamp (N) then
               return File;
            end if;
         end if;

         Last_Dir := Src_Search_Directories.Last;

         for D in Primary_Directory + 1 .. Last_Dir loop
            Locate_File (N, Source, D, File_Name, File, Attr'Access);

            if File /= No_File and then T = File_Stamp (File) then
               return File;
            end if;
         end loop;

         return No_File;
      end;
   end Matching_Full_Source_Name;

   ----------------
   -- More_Files --
   ----------------

   function More_Files return Boolean is
   begin
      return (Current_File_Name_Index < Number_File_Names);
   end More_Files;

   -------------------------------
   -- Nb_Dir_In_Obj_Search_Path --
   -------------------------------

   function Nb_Dir_In_Obj_Search_Path return Natural is
   begin
      if Opt.Look_In_Primary_Dir then
         return Lib_Search_Directories.Last -  Primary_Directory + 1;
      else
         return Lib_Search_Directories.Last -  Primary_Directory;
      end if;
   end Nb_Dir_In_Obj_Search_Path;

   -------------------------------
   -- Nb_Dir_In_Src_Search_Path --
   -------------------------------

   function Nb_Dir_In_Src_Search_Path return Natural is
   begin
      if Opt.Look_In_Primary_Dir then
         return Src_Search_Directories.Last -  Primary_Directory + 1;
      else
         return Src_Search_Directories.Last -  Primary_Directory;
      end if;
   end Nb_Dir_In_Src_Search_Path;

   --------------------
   -- Next_Main_File --
   --------------------

   function Next_Main_File return File_Name_Type is
      File_Name : String_Ptr;
      Dir_Name  : String_Ptr;
      Fptr      : Natural;

   begin
      pragma Assert (More_Files);

      Current_File_Name_Index := Current_File_Name_Index + 1;

      --  Get the file and directory name

      File_Name := File_Names (Current_File_Name_Index);
      Fptr := File_Name'First;

      for J in reverse File_Name'Range loop
         if File_Name (J) = Directory_Separator
           or else File_Name (J) = '/'
         then
            if J = File_Name'Last then
               Fail ("File name missing");
            end if;

            Fptr := J + 1;
            exit;
         end if;
      end loop;

      --  Save name of directory in which main unit resides for use in
      --  locating other units

      Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1));

      case Running_Program is

         when Compiler =>
            Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
            Look_In_Primary_Directory_For_Current_Main := True;

         when Make =>
            Src_Search_Directories.Table (Primary_Directory) := Dir_Name;

            if Fptr > File_Name'First then
               Look_In_Primary_Directory_For_Current_Main := True;
            end if;

         when Binder | Gnatls =>
            Dir_Name := Normalize_Directory_Name (Dir_Name.all);
            Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;

         when Unspecified =>
            null;
      end case;

      Name_Len := File_Name'Last - Fptr + 1;
      Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
      Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
      Current_Main := Name_Find;

      --  In the gnatmake case, the main file may have not have the
      --  extension. Try ".adb" first then ".ads"

      if Running_Program = Make then
         declare
            Orig_Main : constant File_Name_Type := Current_Main;

         begin
            if Strip_Suffix (Orig_Main) = Orig_Main then
               Current_Main :=
                 Append_Suffix_To_File_Name (Orig_Main, ".adb");

               if Full_Source_Name (Current_Main) = No_File then
                  Current_Main :=
                    Append_Suffix_To_File_Name (Orig_Main, ".ads");

                  if Full_Source_Name (Current_Main) = No_File then
                     Current_Main := Orig_Main;
                  end if;
               end if;
            end if;
         end;
      end if;

      return Current_Main;
   end Next_Main_File;

   ------------------------------
   -- Normalize_Directory_Name --
   ------------------------------

   function Normalize_Directory_Name (Directory : String) return String_Ptr is

      function Is_Quoted (Path : String) return Boolean;
      pragma Inline (Is_Quoted);
      --  Returns true if Path is quoted (either double or single quotes)

      ---------------
      -- Is_Quoted --
      ---------------

      function Is_Quoted (Path : String) return Boolean is
         First : constant Character := Path (Path'First);
         Last  : constant Character := Path (Path'Last);

      begin
         if (First = ''' and then Last = ''')
               or else
            (First = '"' and then Last = '"')
         then
            return True;
         else
            return False;
         end if;
      end Is_Quoted;

      Result : String_Ptr;

   --  Start of processing for Normalize_Directory_Name

   begin
      if Directory'Length = 0 then
         Result := new String'(Hostparm.Normalized_CWD);

      elsif Is_Directory_Separator (Directory (Directory'Last)) then
         Result := new String'(Directory);

      elsif Is_Quoted (Directory) then

         --  This is a quoted string, it certainly means that the directory
         --  contains some spaces for example. We can safely remove the quotes
         --  here as the OS_Lib.Normalize_Arguments will be called before any
         --  spawn routines. This ensure that quotes will be added when needed.

         Result := new String (1 .. Directory'Length - 1);
         Result (1 .. Directory'Length - 2) :=
           Directory (Directory'First + 1 .. Directory'Last - 1);
         Result (Result'Last) := Directory_Separator;

      else
         Result := new String (1 .. Directory'Length + 1);
         Result (1 .. Directory'Length) := Directory;
         Result (Directory'Length + 1) := Directory_Separator;
      end if;

      return Result;
   end Normalize_Directory_Name;

   ---------------------
   -- Number_Of_Files --
   ---------------------

   function Number_Of_Files return Int is
   begin
      return Number_File_Names;
   end Number_Of_Files;

   -------------------------------
   -- Object_Dir_Default_Prefix --
   -------------------------------

   function Object_Dir_Default_Prefix return String is
      Object_Dir : String_Access :=
                     String_Access (Update_Path (Object_Dir_Default_Name));

   begin
      if Object_Dir = null then
         return "";

      else
         declare
            Result : constant String := Object_Dir.all;
         begin
            Free (Object_Dir);
            return Result;
         end;
      end if;
   end Object_Dir_Default_Prefix;

   ----------------------
   -- Object_File_Name --
   ----------------------

   function Object_File_Name (N : File_Name_Type) return File_Name_Type is
   begin
      if N = No_File then
         return No_File;
      end if;

      Get_Name_String (N);
      Name_Len := Name_Len - ALI_Suffix'Length - 1;

      for J in Target_Object_Suffix'Range loop
         Name_Len := Name_Len + 1;
         Name_Buffer (Name_Len) := Target_Object_Suffix (J);
      end loop;

      return Name_Enter;
   end Object_File_Name;

   -------------------------------
   -- OS_Exit_Through_Exception --
   -------------------------------

   procedure OS_Exit_Through_Exception (Status : Integer) is
   begin
      Current_Exit_Status := Status;
      raise Types.Terminate_Program;
   end OS_Exit_Through_Exception;

   --------------------------
   -- OS_Time_To_GNAT_Time --
   --------------------------

   function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
      GNAT_Time : Time_Stamp_Type;

      Y  : Year_Type;
      Mo : Month_Type;
      D  : Day_Type;
      H  : Hour_Type;
      Mn : Minute_Type;
      S  : Second_Type;

   begin
      if T = Invalid_Time then
         return Empty_Time_Stamp;
      end if;

      GM_Split (T, Y, Mo, D, H, Mn, S);
      Make_Time_Stamp
        (Year    => Nat (Y),
         Month   => Nat (Mo),
         Day     => Nat (D),
         Hour    => Nat (H),
         Minutes => Nat (Mn),
         Seconds => Nat (S),
         TS      => GNAT_Time);

      return GNAT_Time;
   end OS_Time_To_GNAT_Time;

   ------------------
   -- Program_Name --
   ------------------

   function Program_Name (Nam : String; Prog : String) return String_Access is
      End_Of_Prefix   : Natural := 0;
      Start_Of_Prefix : Positive := 1;
      Start_Of_Suffix : Positive;

   begin
      --  GNAAMP tool names require special treatment

      if AAMP_On_Target then

         --  The name "gcc" is mapped to "gnaamp" (the compiler driver)

         if Nam = "gcc" then
            return new String'("gnaamp");

         --  Tool names starting with "gnat" are mapped by substituting the
         --  string "gnaamp" for "gnat" (for example, "gnatpp" => "gnaamppp").

         elsif Nam'Length >= 4
           and then Nam (Nam'First .. Nam'First + 3) = "gnat"
         then
            return new String'("gnaamp" & Nam (Nam'First + 4 .. Nam'Last));

         --  No other mapping rules, so we continue and handle any other forms
         --  of tool names the same as on other targets.

         else
            null;
         end if;
      end if;

      --  Get the name of the current program being executed

      Find_Program_Name;

      Start_Of_Suffix := Name_Len + 1;

      --  Find the target prefix if any, for the cross compilation case.
      --  For instance in "powerpc-elf-gcc" the target prefix is
      --  "powerpc-elf-"
      --  Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1"

      for J in reverse 1 .. Name_Len loop
         if Name_Buffer (J) = '/'
           or else Name_Buffer (J) = Directory_Separator
           or else Name_Buffer (J) = ':'
         then
            Start_Of_Prefix := J + 1;
            exit;
         end if;
      end loop;

      --  Find End_Of_Prefix

      for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop
         if Name_Buffer (J .. J + Prog'Length - 1) = Prog then
            End_Of_Prefix := J - 1;
            exit;
         end if;
      end loop;

      if End_Of_Prefix > 1 then
         Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1;
      end if;

      --  Create the new program name

      return new String'
        (Name_Buffer (Start_Of_Prefix .. End_Of_Prefix)
         & Nam
         & Name_Buffer (Start_Of_Suffix .. Name_Len));
   end Program_Name;

   ------------------------------
   -- Read_Default_Search_Dirs --
   ------------------------------

   function Read_Default_Search_Dirs
     (Search_Dir_Prefix       : String_Access;
      Search_File             : String_Access;
      Search_Dir_Default_Name : String_Access) return String_Access
   is
      Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
      Buffer     : String (1 .. Prefix_Len + Search_File.all'Length + 1);
      File_FD    : File_Descriptor;
      S, S1      : String_Access;
      Len        : Integer;
      Curr       : Integer;
      Actual_Len : Integer;
      J1         : Integer;

      Prev_Was_Separator : Boolean;
      Nb_Relative_Dir    : Integer;

      function Is_Relative (S : String; K : Positive) return Boolean;
      pragma Inline (Is_Relative);
      --  Returns True if a relative directory specification is found
      --  in S at position K, False otherwise.

      -----------------
      -- Is_Relative --
      -----------------

      function Is_Relative (S : String; K : Positive) return Boolean is
      begin
         return not Is_Absolute_Path (S (K .. S'Last));
      end Is_Relative;

   --  Start of processing for Read_Default_Search_Dirs

   begin
      --  Construct a C compatible character string buffer

      Buffer (1 .. Search_Dir_Prefix.all'Length)
        := Search_Dir_Prefix.all;
      Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1)
        := Search_File.all;
      Buffer (Buffer'Last) := ASCII.NUL;

      File_FD := Open_Read (Buffer'Address, Binary);
      if File_FD = Invalid_FD then
         return Search_Dir_Default_Name;
      end if;

      Len := Integer (File_Length (File_FD));

      --  An extra character for a trailing Path_Separator is allocated

      S := new String (1 .. Len + 1);
      S (Len + 1) := Path_Separator;

      --  Read the file. Note that the loop is not necessary since the
      --  whole file is read at once except on VMS.

      Curr := 1;
      Actual_Len := Len;
      while Actual_Len /= 0 loop
         Actual_Len := Read (File_FD, S (Curr)'Address, Len);
         Curr := Curr + Actual_Len;
      end loop;

      --  Process the file, dealing with path separators

      Prev_Was_Separator := True;
      Nb_Relative_Dir := 0;
      for J in 1 .. Len loop

         --  Treat any control character as a path separator. Note that we do
         --  not treat space as a path separator (we used to treat space as a
         --  path separator in an earlier version). That way space can appear
         --  as a legitimate character in a path name.

         --  Why do we treat all control characters as path separators???

         if S (J) in ASCII.NUL .. ASCII.US then
            S (J) := Path_Separator;
         end if;

         --  Test for explicit path separator (or control char as above)

         if S (J) = Path_Separator then
            Prev_Was_Separator := True;

         --  If not path separator, register use of relative directory

         else
            if Prev_Was_Separator and then Is_Relative (S.all, J) then
               Nb_Relative_Dir := Nb_Relative_Dir + 1;
            end if;

            Prev_Was_Separator := False;
         end if;
      end loop;

      if Nb_Relative_Dir = 0 then
         return S;
      end if;

      --  Add the Search_Dir_Prefix to all relative paths

      S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len);
      J1 := 1;
      Prev_Was_Separator := True;
      for J in 1 .. Len + 1 loop
         if S (J) = Path_Separator then
            Prev_Was_Separator := True;

         else
            if Prev_Was_Separator and then Is_Relative (S.all, J) then
               S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all;
               J1 := J1 + Prefix_Len;
            end if;

            Prev_Was_Separator := False;
         end if;
         S1 (J1) := S (J);
         J1 := J1 + 1;
      end loop;

      Free (S);
      return S1;
   end Read_Default_Search_Dirs;

   -----------------------
   -- Read_Library_Info --
   -----------------------

   function Read_Library_Info
     (Lib_File  : File_Name_Type;
      Fatal_Err : Boolean := False) return Text_Buffer_Ptr
   is
      File : File_Name_Type;
      Attr : aliased File_Attributes;
   begin
      Find_File (Lib_File, Library, File, Attr'Access);
      return Read_Library_Info_From_Full
        (Full_Lib_File => File,
         Lib_File_Attr => Attr'Access,
         Fatal_Err     => Fatal_Err);
   end Read_Library_Info;

   ---------------------------------
   -- Read_Library_Info_From_Full --
   ---------------------------------

   function Read_Library_Info_From_Full
     (Full_Lib_File : File_Name_Type;
      Lib_File_Attr : access File_Attributes;
      Fatal_Err     : Boolean := False) return Text_Buffer_Ptr
   is
      Lib_FD : File_Descriptor;
      --  The file descriptor for the current library file. A negative value
      --  indicates failure to open the specified source file.

      Len : Integer;
      --  Length of source file text (ALI). If it doesn't fit in an integer
      --  we're probably stuck anyway (>2 gigs of source seems a lot!)

      Text : Text_Buffer_Ptr;
      --  Allocated text buffer

      Status : Boolean;
      pragma Warnings (Off, Status);
      --  For the calls to Close

   begin
      Current_Full_Lib_Name := Full_Lib_File;
      Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name);

      if Current_Full_Lib_Name = No_File then
         if Fatal_Err then
            Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
         else
            Current_Full_Obj_Stamp := Empty_Time_Stamp;
            return null;
         end if;
      end if;

      Get_Name_String (Current_Full_Lib_Name);
      Name_Buffer (Name_Len + 1) := ASCII.NUL;

      --  Open the library FD, note that we open in binary mode, because as
      --  documented in the spec, the caller is expected to handle either
      --  DOS or Unix mode files, and there is no point in wasting time on
      --  text translation when it is not required.

      Lib_FD := Open_Read (Name_Buffer'Address, Binary);

      if Lib_FD = Invalid_FD then
         if Fatal_Err then
            Fail ("Cannot open: " & Name_Buffer (1 .. Name_Len));
         else
            Current_Full_Obj_Stamp := Empty_Time_Stamp;
            return null;
         end if;
      end if;

      --  Compute the length of the file (potentially also preparing other data
      --  like the timestamp and whether the file is read-only, for future use)

      Len := Integer (File_Length (Name_Buffer'Address, Lib_File_Attr));

      --  Check for object file consistency if requested

      if Opt.Check_Object_Consistency then
         --  On most systems, this does not result in an extra system call

         Current_Full_Lib_Stamp :=
           OS_Time_To_GNAT_Time
             (File_Time_Stamp (Name_Buffer'Address, Lib_File_Attr));

         --  ??? One system call here

         Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name);

         if Current_Full_Obj_Stamp (1) = ' ' then

            --  When the library is readonly always assume object is consistent
            --  The call to Is_Writable_File only results in a system call on
            --  some systems, but in most cases it has already been computed as
            --  part of the call to File_Length above.

            Get_Name_String (Current_Full_Lib_Name);
            Name_Buffer (Name_Len + 1) := ASCII.NUL;

            if not Is_Writable_File (Name_Buffer'Address, Lib_File_Attr) then
               Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;

            elsif Fatal_Err then
               Get_Name_String (Current_Full_Obj_Name);
               Close (Lib_FD, Status);

               --  No need to check the status, we fail anyway

               Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));

            else
               Current_Full_Obj_Stamp := Empty_Time_Stamp;
               Close (Lib_FD, Status);

               --  No need to check the status, we return null anyway

               return null;
            end if;

         elsif Current_Full_Obj_Stamp < Current_Full_Lib_Stamp then
            Close (Lib_FD, Status);

            --  No need to check the status, we return null anyway

            return null;
         end if;
      end if;

      --  Read data from the file

      declare
         Actual_Len : Integer := 0;

         Lo : constant Text_Ptr := 0;
         --  Low bound for allocated text buffer

         Hi : Text_Ptr := Text_Ptr (Len);
         --  High bound for allocated text buffer. Note length is Len + 1
         --  which allows for extra EOF character at the end of the buffer.

      begin
         --  Allocate text buffer. Note extra character at end for EOF

         Text := new Text_Buffer (Lo .. Hi);

         --  Some systems (e.g. VMS) have file types that require one
         --  read per line, so read until we get the Len bytes or until
         --  there are no more characters.

         Hi := Lo;
         loop
            Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len);
            Hi := Hi + Text_Ptr (Actual_Len);
            exit when Actual_Len = Len or else Actual_Len <= 0;
         end loop;

         Text (Hi) := EOF;
      end;

      --  Read is complete, close file and we are done

      Close (Lib_FD, Status);
      --  The status should never be False. But, if it is, what can we do?
      --  So, we don't test it.

      return Text;

   end Read_Library_Info_From_Full;

   ----------------------
   -- Read_Source_File --
   ----------------------

   procedure Read_Source_File
     (N   : File_Name_Type;
      Lo  : Source_Ptr;
      Hi  : out Source_Ptr;
      Src : out Source_Buffer_Ptr;
      T   : File_Type := Source)
   is
      Source_File_FD : File_Descriptor;
      --  The file descriptor for the current source file. A negative value
      --  indicates failure to open the specified source file.

      Len : Integer;
      --  Length of file. Assume no more than 2 gigabytes of source!

      Actual_Len : Integer;

      Status : Boolean;
      pragma Warnings (Off, Status);
      --  For the call to Close

   begin
      Current_Full_Source_Name  := Find_File (N, T);
      Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);

      if Current_Full_Source_Name = No_File then

         --  If we were trying to access the main file and we could not find
         --  it, we have an error.

         if N = Current_Main then
            Get_Name_String (N);
            Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
         end if;

         Src := null;
         Hi  := No_Location;
         return;
      end if;

      Get_Name_String (Current_Full_Source_Name);
      Name_Buffer (Name_Len + 1) := ASCII.NUL;

      --  Open the source FD, note that we open in binary mode, because as
      --  documented in the spec, the caller is expected to handle either
      --  DOS or Unix mode files, and there is no point in wasting time on
      --  text translation when it is not required.

      Source_File_FD := Open_Read (Name_Buffer'Address, Binary);

      if Source_File_FD = Invalid_FD then
         Src := null;
         Hi  := No_Location;
         return;
      end if;

      --  Print out the file name, if requested, and if it's not part of the
      --  runtimes, store it in File_Name_Chars.

      declare
         Name : String renames Name_Buffer (1 .. Name_Len);
         Inc  : String renames Include_Dir_Default_Prefix.all;

      begin
         if Debug.Debug_Flag_Dot_N then
            Write_Line (Name);
         end if;

         if Inc /= ""
           and then Inc'Length < Name_Len
           and then Name_Buffer (1 .. Inc'Length) = Inc
         then
            --  Part of runtimes, so ignore it

            null;

         else
            File_Name_Chars.Append_All (File_Name_Chars.Table_Type (Name));
            File_Name_Chars.Append (ASCII.LF);
         end if;
      end;

      --  Prepare to read data from the file

      Len := Integer (File_Length (Source_File_FD));

      --  Set Hi so that length is one more than the physical length,
      --  allowing for the extra EOF character at the end of the buffer

      Hi := Lo + Source_Ptr (Len);

      --  Do the actual read operation

      declare
         subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
         --  Physical buffer allocated

         type Actual_Source_Ptr is access Actual_Source_Buffer;
         --  This is the pointer type for the physical buffer allocated

         Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
         --  And this is the actual physical buffer

      begin
         --  Allocate source buffer, allowing extra character at end for EOF

         --  Some systems (e.g. VMS) have file types that require one read per
         --  line, so read until we get the Len bytes or until there are no
         --  more characters.

         Hi := Lo;
         loop
            Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
            Hi := Hi + Source_Ptr (Actual_Len);
            exit when Actual_Len = Len or else Actual_Len <= 0;
         end loop;

         Actual_Ptr (Hi) := EOF;

         --  Now we need to work out the proper virtual origin pointer to
         --  return. This is exactly Actual_Ptr (0)'Address, but we have to
         --  be careful to suppress checks to compute this address.

         declare
            pragma Suppress (All_Checks);

            pragma Warnings (Off);
            --  This use of unchecked conversion is aliasing safe

            function To_Source_Buffer_Ptr is new
              Unchecked_Conversion (Address, Source_Buffer_Ptr);

            pragma Warnings (On);

         begin
            Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
         end;
      end;

      --  Read is complete, get time stamp and close file and we are done

      Close (Source_File_FD, Status);

      --  The status should never be False. But, if it is, what can we do?
      --  So, we don't test it.

   end Read_Source_File;

   -------------------
   -- Relocate_Path --
   -------------------

   function Relocate_Path
     (Prefix : String;
      Path   : String) return String_Ptr
   is
      S : String_Ptr;

      procedure set_std_prefix (S : String; Len : Integer);
      pragma Import (C, set_std_prefix);

   begin
      if Std_Prefix = null then
         Std_Prefix := Executable_Prefix;

         if Std_Prefix.all /= "" then

            --  Remove trailing directory separator when calling set_std_prefix

            set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1);
         end if;
      end if;

      if Path (Prefix'Range) = Prefix then
         if Std_Prefix.all /= "" then
            S := new String
              (1 .. Std_Prefix'Length + Path'Last - Prefix'Last);
            S (1 .. Std_Prefix'Length) := Std_Prefix.all;
            S (Std_Prefix'Length + 1 .. S'Last) :=
              Path (Prefix'Last + 1 .. Path'Last);
            return S;
         end if;
      end if;

      return new String'(Path);
   end Relocate_Path;

   -----------------
   -- Set_Program --
   -----------------

   procedure Set_Program (P : Program_Type) is
   begin
      if Program_Set then
         Fail ("Set_Program called twice");
      end if;

      Program_Set := True;
      Running_Program := P;
   end Set_Program;

   ----------------
   -- Shared_Lib --
   ----------------

   function Shared_Lib (Name : String) return String is
      Library : String (1 .. Name'Length + Library_Version'Length + 3);
      --  3 = 2 for "-l" + 1 for "-" before lib version

   begin
      Library (1 .. 2)                          := "-l";
      Library (3 .. 2 + Name'Length)            := Name;
      Library (3 + Name'Length)                 := '-';
      Library (4 + Name'Length .. Library'Last) := Library_Version;

      if OpenVMS_On_Target then
         for K in Library'First + 2 .. Library'Last loop
            if Library (K) = '.' or else Library (K) = '-' then
               Library (K) := '_';
            end if;
         end loop;
      end if;

      return Library;
   end Shared_Lib;

   ----------------------
   -- Smart_File_Stamp --
   ----------------------

   function Smart_File_Stamp
     (N : File_Name_Type;
      T : File_Type) return Time_Stamp_Type
   is
      File : File_Name_Type;
      Attr : aliased File_Attributes;

   begin
      if not File_Cache_Enabled then
         Find_File (N, T, File, Attr'Access);
      else
         Smart_Find_File (N, T, File, Attr);
      end if;

      if File = No_File then
         return Empty_Time_Stamp;
      else
         Get_Name_String (File);
         Name_Buffer (Name_Len + 1) := ASCII.NUL;
         return
           OS_Time_To_GNAT_Time
             (File_Time_Stamp (Name_Buffer'Address, Attr'Access));
      end if;
   end Smart_File_Stamp;

   ---------------------
   -- Smart_Find_File --
   ---------------------

   function Smart_Find_File
     (N : File_Name_Type;
      T : File_Type) return File_Name_Type
   is
      File : File_Name_Type;
      Attr : File_Attributes;
   begin
      Smart_Find_File (N, T, File, Attr);
      return File;
   end Smart_Find_File;

   ---------------------
   -- Smart_Find_File --
   ---------------------

   procedure Smart_Find_File
     (N     : File_Name_Type;
      T     : File_Type;
      Found : out File_Name_Type;
      Attr  : out File_Attributes)
   is
      Info : File_Info_Cache;

   begin
      if not File_Cache_Enabled then
         Find_File (N, T, Info.File, Info.Attr'Access);

      else
         Info := File_Name_Hash_Table.Get (N);

         if Info.File = No_File then
            Find_File (N, T, Info.File, Info.Attr'Access);
            File_Name_Hash_Table.Set (N, Info);
         end if;
      end if;

      Found := Info.File;
      Attr  := Info.Attr;
   end Smart_Find_File;

   ----------------------
   -- Source_File_Data --
   ----------------------

   procedure Source_File_Data (Cache : Boolean) is
   begin
      File_Cache_Enabled := Cache;
   end Source_File_Data;

   -----------------------
   -- Source_File_Stamp --
   -----------------------

   function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
   begin
      return Smart_File_Stamp (N, Source);
   end Source_File_Stamp;

   ---------------------
   -- Strip_Directory --
   ---------------------

   function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
   begin
      Get_Name_String (Name);

      for J in reverse 1 .. Name_Len - 1 loop

         --  If we find the last directory separator

         if Is_Directory_Separator (Name_Buffer (J)) then

            --  Return part of Name that follows this last directory separator

            Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
            Name_Len := Name_Len - J;
            return Name_Find;
         end if;
      end loop;

      --  There were no directory separator, just return Name

      return Name;
   end Strip_Directory;

   ------------------
   -- Strip_Suffix --
   ------------------

   function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
   begin
      Get_Name_String (Name);

      for J in reverse 2 .. Name_Len loop

         --  If we found the last '.', return part of Name that precedes it

         if Name_Buffer (J) = '.' then
            Name_Len := J - 1;
            return Name_Enter;
         end if;
      end loop;

      return Name;
   end Strip_Suffix;

   ---------------------------
   -- To_Canonical_Dir_Spec --
   ---------------------------

   function To_Canonical_Dir_Spec
     (Host_Dir     : String;
      Prefix_Style : Boolean) return String_Access
   is
      function To_Canonical_Dir_Spec
        (Host_Dir    : Address;
         Prefix_Flag : Integer) return Address;
      pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");

      C_Host_Dir         : String (1 .. Host_Dir'Length + 1);
      Canonical_Dir_Addr : Address;
      Canonical_Dir_Len  : Integer;

   begin
      C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir;
      C_Host_Dir (C_Host_Dir'Last)      := ASCII.NUL;

      if Prefix_Style then
         Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1);
      else
         Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
      end if;

      Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);

      if Canonical_Dir_Len = 0 then
         return null;
      else
         return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len);
      end if;

   exception
      when others =>
         Fail ("erroneous directory spec: " & Host_Dir);
         return null;
   end To_Canonical_Dir_Spec;

   ---------------------------
   -- To_Canonical_File_List --
   ---------------------------

   function To_Canonical_File_List
     (Wildcard_Host_File : String;
      Only_Dirs          : Boolean) return String_Access_List_Access
   is
      function To_Canonical_File_List_Init
        (Host_File : Address;
         Only_Dirs : Integer) return Integer;
      pragma Import (C, To_Canonical_File_List_Init,
                     "__gnat_to_canonical_file_list_init");

      function To_Canonical_File_List_Next return Address;
      pragma Import (C, To_Canonical_File_List_Next,
                     "__gnat_to_canonical_file_list_next");

      procedure To_Canonical_File_List_Free;
      pragma Import (C, To_Canonical_File_List_Free,
                     "__gnat_to_canonical_file_list_free");

      Num_Files            : Integer;
      C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);

   begin
      C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
        Wildcard_Host_File;
      C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;

      --  Do the expansion and say how many there are

      Num_Files := To_Canonical_File_List_Init
         (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));

      declare
         Canonical_File_List : String_Access_List (1 .. Num_Files);
         Canonical_File_Addr : Address;
         Canonical_File_Len  : Integer;

      begin
         --  Retrieve the expanded directory names and build the list

         for J in 1 .. Num_Files loop
            Canonical_File_Addr := To_Canonical_File_List_Next;
            Canonical_File_Len  := C_String_Length (Canonical_File_Addr);
            Canonical_File_List (J) := To_Path_String_Access
                  (Canonical_File_Addr, Canonical_File_Len);
         end loop;

         --  Free up the storage

         To_Canonical_File_List_Free;

         return new String_Access_List'(Canonical_File_List);
      end;
   end To_Canonical_File_List;

   ----------------------------
   -- To_Canonical_File_Spec --
   ----------------------------

   function To_Canonical_File_Spec
     (Host_File : String) return String_Access
   is
      function To_Canonical_File_Spec (Host_File : Address) return Address;
      pragma Import
        (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");

      C_Host_File         : String (1 .. Host_File'Length + 1);
      Canonical_File_Addr : Address;
      Canonical_File_Len  : Integer;

   begin
      C_Host_File (1 .. Host_File'Length) := Host_File;
      C_Host_File (C_Host_File'Last)      := ASCII.NUL;

      Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address);
      Canonical_File_Len  := C_String_Length (Canonical_File_Addr);

      if Canonical_File_Len = 0 then
         return null;
      else
         return To_Path_String_Access
                  (Canonical_File_Addr, Canonical_File_Len);
      end if;

   exception
      when others =>
         Fail ("erroneous file spec: " & Host_File);
         return null;
   end To_Canonical_File_Spec;

   ----------------------------
   -- To_Canonical_Path_Spec --
   ----------------------------

   function To_Canonical_Path_Spec
     (Host_Path : String) return String_Access
   is
      function To_Canonical_Path_Spec (Host_Path : Address) return Address;
      pragma Import
        (C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec");

      C_Host_Path         : String (1 .. Host_Path'Length + 1);
      Canonical_Path_Addr : Address;
      Canonical_Path_Len  : Integer;

   begin
      C_Host_Path (1 .. Host_Path'Length) := Host_Path;
      C_Host_Path (C_Host_Path'Last)      := ASCII.NUL;

      Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address);
      Canonical_Path_Len  := C_String_Length (Canonical_Path_Addr);

      --  Return a null string (vice a null) for zero length paths, for
      --  compatibility with getenv().

      return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len);

   exception
      when others =>
         Fail ("erroneous path spec: " & Host_Path);
         return null;
   end To_Canonical_Path_Spec;

   ---------------------------
   -- To_Host_Dir_Spec --
   ---------------------------

   function To_Host_Dir_Spec
     (Canonical_Dir : String;
      Prefix_Style  : Boolean) return String_Access
   is
      function To_Host_Dir_Spec
        (Canonical_Dir : Address;
         Prefix_Flag   : Integer) return Address;
      pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");

      C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
      Host_Dir_Addr   : Address;
      Host_Dir_Len    : Integer;

   begin
      C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir;
      C_Canonical_Dir (C_Canonical_Dir'Last)      := ASCII.NUL;

      if Prefix_Style then
         Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1);
      else
         Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0);
      end if;
      Host_Dir_Len := C_String_Length (Host_Dir_Addr);

      if Host_Dir_Len = 0 then
         return null;
      else
         return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len);
      end if;
   end To_Host_Dir_Spec;

   ----------------------------
   -- To_Host_File_Spec --
   ----------------------------

   function To_Host_File_Spec
     (Canonical_File : String) return String_Access
   is
      function To_Host_File_Spec (Canonical_File : Address) return Address;
      pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");

      C_Canonical_File      : String (1 .. Canonical_File'Length + 1);
      Host_File_Addr : Address;
      Host_File_Len  : Integer;

   begin
      C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File;
      C_Canonical_File (C_Canonical_File'Last)      := ASCII.NUL;

      Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address);
      Host_File_Len  := C_String_Length (Host_File_Addr);

      if Host_File_Len = 0 then
         return null;
      else
         return To_Path_String_Access
                  (Host_File_Addr, Host_File_Len);
      end if;
   end To_Host_File_Spec;

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

   -----------------
   -- Update_Path --
   -----------------

   function Update_Path (Path : String_Ptr) return String_Ptr is

      function C_Update_Path (Path, Component : Address) return Address;
      pragma Import (C, C_Update_Path, "update_path");

      function Strlen (Str : Address) return Integer;
      pragma Import (C, Strlen, "strlen");

      procedure Strncpy (X : Address; Y : Address; Length : Integer);
      pragma Import (C, Strncpy, "strncpy");

      In_Length      : constant Integer := Path'Length;
      In_String      : String (1 .. In_Length + 1);
      Component_Name : aliased String := "GCC" & ASCII.NUL;
      Result_Ptr     : Address;
      Result_Length  : Integer;
      Out_String     : String_Ptr;

   begin
      In_String (1 .. In_Length) := Path.all;
      In_String (In_Length + 1) := ASCII.NUL;
      Result_Ptr := C_Update_Path (In_String'Address, Component_Name'Address);
      Result_Length := Strlen (Result_Ptr);

      Out_String := new String (1 .. Result_Length);
      Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
      return Out_String;
   end Update_Path;

   ----------------
   -- Write_Info --
   ----------------

   procedure Write_Info (Info : String) is
   begin
      Write_With_Check (Info'Address, Info'Length);
      Write_With_Check (EOL'Address, 1);
   end Write_Info;

   ------------------------
   -- Write_Program_Name --
   ------------------------

   procedure Write_Program_Name is
      Save_Buffer : constant String (1 .. Name_Len) :=
                      Name_Buffer (1 .. Name_Len);

   begin
      Find_Program_Name;

      --  Convert the name to lower case so error messages are the same on
      --  all systems.

      for J in 1 .. Name_Len loop
         if Name_Buffer (J) in 'A' .. 'Z' then
            Name_Buffer (J) :=
              Character'Val (Character'Pos (Name_Buffer (J)) + 32);
         end if;
      end loop;

      Write_Str (Name_Buffer (1 .. Name_Len));

      --  Restore Name_Buffer which was clobbered by the call to
      --  Find_Program_Name

      Name_Len := Save_Buffer'Last;
      Name_Buffer (1 .. Name_Len) := Save_Buffer;
   end Write_Program_Name;

   ----------------------
   -- Write_With_Check --
   ----------------------

   procedure Write_With_Check (A  : Address; N  : Integer) is
      Ignore : Boolean;
      pragma Warnings (Off, Ignore);

   begin
      if N = Write (Output_FD, A, N) then
         return;

      else
         Write_Str ("error: disk full writing ");
         Write_Name_Decoded (Output_File_Name);
         Write_Eol;
         Name_Len := Name_Len + 1;
         Name_Buffer (Name_Len) := ASCII.NUL;
         Delete_File (Name_Buffer'Address, Ignore);
         Exit_Program (E_Fatal);
      end if;
   end Write_With_Check;

----------------------------
-- Package Initialization --
----------------------------

   procedure Reset_File_Attributes (Attr : System.Address);
   pragma Import (C, Reset_File_Attributes, "__gnat_reset_attributes");

begin
   Initialization : declare

      function Get_Default_Identifier_Character_Set return Character;
      pragma Import (C, Get_Default_Identifier_Character_Set,
                       "__gnat_get_default_identifier_character_set");
      --  Function to determine the default identifier character set,
      --  which is system dependent. See Opt package spec for a list of
      --  the possible character codes and their interpretations.

      function Get_Maximum_File_Name_Length return Int;
      pragma Import (C, Get_Maximum_File_Name_Length,
                    "__gnat_get_maximum_file_name_length");
      --  Function to get maximum file name length for system

      Sizeof_File_Attributes : Integer;
      pragma Import (C, Sizeof_File_Attributes,
                     "__gnat_size_of_file_attributes");

   begin
      pragma Assert (Sizeof_File_Attributes <= File_Attributes_Size);

      Reset_File_Attributes (Unknown_Attributes'Address);

      Identifier_Character_Set := Get_Default_Identifier_Character_Set;
      Maximum_File_Name_Length := Get_Maximum_File_Name_Length;

      --  Following should be removed by having above function return
      --  Integer'Last as indication of no maximum instead of -1 ???

      if Maximum_File_Name_Length = -1 then
         Maximum_File_Name_Length := Int'Last;
      end if;

      Src_Search_Directories.Set_Last (Primary_Directory);
      Src_Search_Directories.Table (Primary_Directory) := new String'("");

      Lib_Search_Directories.Set_Last (Primary_Directory);
      Lib_Search_Directories.Table (Primary_Directory) := new String'("");

      Osint.Initialize;
   end Initialization;

end Osint;