File : osint.adb


   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                O S I N T                                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2016, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25 
  26 with Alloc;
  27 with Debug;
  28 with Fmap;     use Fmap;
  29 with Gnatvsn;  use Gnatvsn;
  30 with Hostparm;
  31 with Opt;      use Opt;
  32 with Output;   use Output;
  33 with Sdefault; use Sdefault;
  34 with Table;
  35 with Targparm; use Targparm;
  36 
  37 with Unchecked_Conversion;
  38 
  39 pragma Warnings (Off);
  40 --  This package is used also by gnatcoll
  41 with System.Case_Util; use System.Case_Util;
  42 with System.CRTL;
  43 pragma Warnings (On);
  44 
  45 with GNAT.HTable;
  46 
  47 package body Osint is
  48 
  49    use type CRTL.size_t;
  50 
  51    Running_Program : Program_Type := Unspecified;
  52    --  comment required here ???
  53 
  54    Program_Set : Boolean := False;
  55    --  comment required here ???
  56 
  57    Std_Prefix : String_Ptr;
  58    --  Standard prefix, computed dynamically the first time Relocate_Path
  59    --  is called, and cached for subsequent calls.
  60 
  61    Empty  : aliased String := "";
  62    No_Dir : constant String_Ptr := Empty'Access;
  63    --  Used in Locate_File as a fake directory when Name is already an
  64    --  absolute path.
  65 
  66    -------------------------------------
  67    -- Use of Name_Find and Name_Enter --
  68    -------------------------------------
  69 
  70    --  This package creates a number of source, ALI and object file names
  71    --  that are used to locate the actual file and for the purpose of message
  72    --  construction. These names need not be accessible by Name_Find, and can
  73    --  be therefore created by using routine Name_Enter. The files in question
  74    --  are file names with a prefix directory (i.e., the files not in the
  75    --  current directory). File names without a prefix directory are entered
  76    --  with Name_Find because special values might be attached to the various
  77    --  Info fields of the corresponding name table entry.
  78 
  79    -----------------------
  80    -- Local Subprograms --
  81    -----------------------
  82 
  83    function Append_Suffix_To_File_Name
  84      (Name   : File_Name_Type;
  85       Suffix : String) return File_Name_Type;
  86    --  Appends Suffix to Name and returns the new name
  87 
  88    function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type;
  89    --  Convert OS format time to GNAT format time stamp. If T is Invalid_Time,
  90    --  then returns Empty_Time_Stamp.
  91 
  92    function Executable_Prefix return String_Ptr;
  93    --  Returns the name of the root directory where the executable is stored.
  94    --  The executable must be located in a directory called "bin", or under
  95    --  root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if
  96    --  executable is stored in directory "/foo/bar/bin", this routine returns
  97    --  "/foo/bar/". Return "" if location is not recognized as described above.
  98 
  99    function Update_Path (Path : String_Ptr) return String_Ptr;
 100    --  Update the specified path to replace the prefix with the location where
 101    --  GNAT is installed. See the file prefix.c in GCC for details.
 102 
 103    procedure Locate_File
 104      (N     : File_Name_Type;
 105       T     : File_Type;
 106       Dir   : Natural;
 107       Name  : String;
 108       Found : out File_Name_Type;
 109       Attr  : access File_Attributes);
 110    --  See if the file N whose name is Name exists in directory Dir. Dir is an
 111    --  index into the Lib_Search_Directories table if T = Library. Otherwise
 112    --  if T = Source, Dir is an index into the Src_Search_Directories table.
 113    --  Returns the File_Name_Type of the full file name if file found, or
 114    --  No_File if not found.
 115    --
 116    --  On exit, Found is set to the file that was found, and Attr to a cache of
 117    --  its attributes (at least those that have been computed so far). Reusing
 118    --  the cache will save some system calls.
 119    --
 120    --  Attr is always reset in this call to Unknown_Attributes, even in case of
 121    --  failure
 122 
 123    procedure Find_File
 124      (N         : File_Name_Type;
 125       T         : File_Type;
 126       Found     : out File_Name_Type;
 127       Attr      : access File_Attributes;
 128       Full_Name : Boolean := False);
 129    --  A version of Find_File that also returns a cache of the file attributes
 130    --  for later reuse
 131 
 132    procedure Smart_Find_File
 133      (N     : File_Name_Type;
 134       T     : File_Type;
 135       Found : out File_Name_Type;
 136       Attr  : out File_Attributes);
 137    --  A version of Smart_Find_File that also returns a cache of the file
 138    --  attributes for later reuse
 139 
 140    function C_String_Length (S : Address) return CRTL.size_t;
 141    --  Returns length of a C string (zero for a null address)
 142 
 143    function To_Path_String_Access
 144      (Path_Addr : Address;
 145       Path_Len  : CRTL.size_t) return String_Access;
 146    --  Converts a C String to an Ada String. Are we doing this to avoid withing
 147    --  Interfaces.C.Strings ???
 148    --  Caller must free result.
 149 
 150    function Include_Dir_Default_Prefix return String_Access;
 151    --  Same as exported version, except returns a String_Access
 152 
 153    ------------------------------
 154    -- Other Local Declarations --
 155    ------------------------------
 156 
 157    EOL : constant Character := ASCII.LF;
 158    --  End of line character
 159 
 160    Number_File_Names : Nat := 0;
 161    --  Number of file names found on command line and placed in File_Names
 162 
 163    Look_In_Primary_Directory_For_Current_Main : Boolean := False;
 164    --  When this variable is True, Find_File only looks in Primary_Directory
 165    --  for the Current_Main file. This variable is always set to True for the
 166    --  compiler. It is also True for gnatmake, when the source name given on
 167    --  the command line has directory information.
 168 
 169    Current_Full_Source_Name  : File_Name_Type  := No_File;
 170    Current_Full_Source_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
 171    Current_Full_Lib_Name     : File_Name_Type  := No_File;
 172    Current_Full_Lib_Stamp    : Time_Stamp_Type := Empty_Time_Stamp;
 173    Current_Full_Obj_Name     : File_Name_Type  := No_File;
 174    Current_Full_Obj_Stamp    : Time_Stamp_Type := Empty_Time_Stamp;
 175    --  Respectively full name (with directory info) and time stamp of the
 176    --  latest source, library and object files opened by Read_Source_File and
 177    --  Read_Library_Info.
 178 
 179    package File_Name_Chars is new Table.Table (
 180      Table_Component_Type => Character,
 181      Table_Index_Type     => Int,
 182      Table_Low_Bound      => 1,
 183      Table_Initial        => Alloc.File_Name_Chars_Initial,
 184      Table_Increment      => Alloc.File_Name_Chars_Increment,
 185      Table_Name           => "File_Name_Chars");
 186    --  Table to store text to be printed by Dump_Source_File_Names
 187 
 188    The_Include_Dir_Default_Prefix : String_Access := null;
 189    --  Value returned by Include_Dir_Default_Prefix. We don't initialize it
 190    --  here, because that causes an elaboration cycle with Sdefault; we
 191    --  initialize it lazily instead.
 192 
 193    ------------------
 194    -- Search Paths --
 195    ------------------
 196 
 197    Primary_Directory : constant := 0;
 198    --  This is index in the tables created below for the first directory to
 199    --  search in for source or library information files. This is the directory
 200    --  containing the latest main input file (a source file for the compiler or
 201    --  a library file for the binder).
 202 
 203    package Src_Search_Directories is new Table.Table (
 204      Table_Component_Type => String_Ptr,
 205      Table_Index_Type     => Integer,
 206      Table_Low_Bound      => Primary_Directory,
 207      Table_Initial        => 10,
 208      Table_Increment      => 100,
 209      Table_Name           => "Osint.Src_Search_Directories");
 210    --  Table of names of directories in which to search for source (Compiler)
 211    --  files. This table is filled in the order in which the directories are
 212    --  to be searched, and then used in that order.
 213 
 214    package Lib_Search_Directories is new Table.Table (
 215      Table_Component_Type => String_Ptr,
 216      Table_Index_Type     => Integer,
 217      Table_Low_Bound      => Primary_Directory,
 218      Table_Initial        => 10,
 219      Table_Increment      => 100,
 220      Table_Name           => "Osint.Lib_Search_Directories");
 221    --  Table of names of directories in which to search for library (Binder)
 222    --  files. This table is filled in the order in which the directories are
 223    --  to be searched and then used in that order. The reason for having two
 224    --  distinct tables is that we need them both in gnatmake.
 225 
 226    ---------------------
 227    -- File Hash Table --
 228    ---------------------
 229 
 230    --  The file hash table is provided to free the programmer from any
 231    --  efficiency concern when retrieving full file names or time stamps of
 232    --  source files. If the programmer calls Source_File_Data (Cache => True)
 233    --  he is guaranteed that the price to retrieve the full name (i.e. with
 234    --  directory info) or time stamp of the file will be payed only once, the
 235    --  first time the full name is actually searched (or the first time the
 236    --  time stamp is actually retrieved). This is achieved by employing a hash
 237    --  table that stores as a key the File_Name_Type of the file and associates
 238    --  to that File_Name_Type the full file name and time stamp of the file.
 239 
 240    File_Cache_Enabled : Boolean := False;
 241    --  Set to true if you want the enable the file data caching mechanism
 242 
 243    type File_Hash_Num is range 0 .. 1020;
 244 
 245    function File_Hash (F : File_Name_Type) return File_Hash_Num;
 246    --  Compute hash index for use by Simple_HTable
 247 
 248    type File_Info_Cache is record
 249       File : File_Name_Type;
 250       Attr : aliased File_Attributes;
 251    end record;
 252 
 253    No_File_Info_Cache : constant File_Info_Cache :=
 254                           (No_File, Unknown_Attributes);
 255 
 256    package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable (
 257      Header_Num => File_Hash_Num,
 258      Element    => File_Info_Cache,
 259      No_Element => No_File_Info_Cache,
 260      Key        => File_Name_Type,
 261      Hash       => File_Hash,
 262      Equal      => "=");
 263 
 264    function Smart_Find_File
 265      (N : File_Name_Type;
 266       T : File_Type) return File_Name_Type;
 267    --  Exactly like Find_File except that if File_Cache_Enabled is True this
 268    --  routine looks first in the hash table to see if the full name of the
 269    --  file is already available.
 270 
 271    function Smart_File_Stamp
 272      (N : File_Name_Type;
 273       T : File_Type) return Time_Stamp_Type;
 274    --  Takes the same parameter as the routine above (N is a file name without
 275    --  any prefix directory information) and behaves like File_Stamp except
 276    --  that if File_Cache_Enabled is True this routine looks first in the hash
 277    --  table to see if the file stamp of the file is already available.
 278 
 279    -----------------------------
 280    -- Add_Default_Search_Dirs --
 281    -----------------------------
 282 
 283    procedure Add_Default_Search_Dirs is
 284       Search_Dir     : String_Access;
 285       Search_Path    : String_Access;
 286       Path_File_Name : String_Access;
 287 
 288       procedure Add_Search_Dir
 289         (Search_Dir            : String;
 290          Additional_Source_Dir : Boolean);
 291       procedure Add_Search_Dir
 292         (Search_Dir            : String_Access;
 293          Additional_Source_Dir : Boolean);
 294       --  Add a source search dir or a library search dir, depending on the
 295       --  value of Additional_Source_Dir.
 296 
 297       procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean);
 298       --  Open a path file and read the directory to search, one per line
 299 
 300       function Get_Libraries_From_Registry return String_Ptr;
 301       --  On Windows systems, get the list of installed standard libraries
 302       --  from the registry key:
 303       --
 304       --  HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
 305       --                             GNAT\Standard Libraries
 306       --  Return an empty string on other systems.
 307       --
 308       --  Note that this is an undocumented legacy feature, and that it
 309       --  works only when using the default runtime library (i.e. no --RTS=
 310       --  command line switch).
 311 
 312       --------------------
 313       -- Add_Search_Dir --
 314       --------------------
 315 
 316       procedure Add_Search_Dir
 317         (Search_Dir            : String;
 318          Additional_Source_Dir : Boolean)
 319       is
 320       begin
 321          if Additional_Source_Dir then
 322             Add_Src_Search_Dir (Search_Dir);
 323          else
 324             Add_Lib_Search_Dir (Search_Dir);
 325          end if;
 326       end Add_Search_Dir;
 327 
 328       procedure Add_Search_Dir
 329         (Search_Dir            : String_Access;
 330          Additional_Source_Dir : Boolean)
 331       is
 332       begin
 333          if Additional_Source_Dir then
 334             Add_Src_Search_Dir (Search_Dir.all);
 335          else
 336             Add_Lib_Search_Dir (Search_Dir.all);
 337          end if;
 338       end Add_Search_Dir;
 339 
 340       ------------------------
 341       -- Get_Dirs_From_File --
 342       ------------------------
 343 
 344       procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean) is
 345          File_FD    : File_Descriptor;
 346          Buffer     : constant String := Path_File_Name.all & ASCII.NUL;
 347          Len        : Natural;
 348          Actual_Len : Natural;
 349          S          : String_Access;
 350          Curr       : Natural;
 351          First      : Natural;
 352          Ch         : Character;
 353 
 354          Status : Boolean;
 355          pragma Warnings (Off, Status);
 356          --  For the call to Close where status is ignored
 357 
 358       begin
 359          File_FD := Open_Read (Buffer'Address, Binary);
 360 
 361          --  If we cannot open the file, we ignore it, we don't fail
 362 
 363          if File_FD = Invalid_FD then
 364             return;
 365          end if;
 366 
 367          Len := Integer (File_Length (File_FD));
 368 
 369          S := new String (1 .. Len);
 370 
 371          --  Read the file. Note that the loop is probably not necessary any
 372          --  more since the whole file is read in at once on all targets. But
 373          --  it is harmless and might be needed in future.
 374 
 375          Curr := 1;
 376          Actual_Len := Len;
 377          while Curr <= Len and then Actual_Len /= 0 loop
 378             Actual_Len := Read (File_FD, S (Curr)'Address, Len);
 379             Curr := Curr + Actual_Len;
 380          end loop;
 381 
 382          --  We are done with the file, so we close it (ignore any error on
 383          --  the close, since we have successfully read the file).
 384 
 385          Close (File_FD, Status);
 386 
 387          --  Now, we read line by line
 388 
 389          First := 1;
 390          Curr := 0;
 391          while Curr < Len loop
 392             Ch := S (Curr + 1);
 393 
 394             if Ch = ASCII.CR or else Ch = ASCII.LF
 395               or else Ch = ASCII.FF or else Ch = ASCII.VT
 396             then
 397                if First <= Curr then
 398                   Add_Search_Dir (S (First .. Curr), Additional_Source_Dir);
 399                end if;
 400 
 401                First := Curr + 2;
 402             end if;
 403 
 404             Curr := Curr + 1;
 405          end loop;
 406 
 407          --  Last line is a special case, if the file does not end with
 408          --  an end of line mark.
 409 
 410          if First <= S'Last then
 411             Add_Search_Dir (S (First .. S'Last), Additional_Source_Dir);
 412          end if;
 413       end Get_Dirs_From_File;
 414 
 415       ---------------------------------
 416       -- Get_Libraries_From_Registry --
 417       ---------------------------------
 418 
 419       function Get_Libraries_From_Registry return String_Ptr is
 420          function C_Get_Libraries_From_Registry return Address;
 421          pragma Import (C, C_Get_Libraries_From_Registry,
 422                         "__gnat_get_libraries_from_registry");
 423 
 424          Result_Ptr    : Address;
 425          Result_Length : CRTL.size_t;
 426          Out_String    : String_Ptr;
 427 
 428       begin
 429          Result_Ptr := C_Get_Libraries_From_Registry;
 430          Result_Length := CRTL.strlen (Result_Ptr);
 431 
 432          Out_String := new String (1 .. Integer (Result_Length));
 433          CRTL.strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
 434 
 435          CRTL.free (Result_Ptr);
 436 
 437          return Out_String;
 438       end Get_Libraries_From_Registry;
 439 
 440    --  Start of processing for Add_Default_Search_Dirs
 441 
 442    begin
 443       --  If there was a -gnateO switch, add all object directories from the
 444       --  file given in argument to the library search list.
 445 
 446       if Object_Path_File_Name /= null then
 447          Path_File_Name := String_Access (Object_Path_File_Name);
 448          pragma Assert (Path_File_Name'Length > 0);
 449          Get_Dirs_From_File (Additional_Source_Dir => False);
 450       end if;
 451 
 452       --  After the locations specified on the command line, the next places
 453       --  to look for files are the directories specified by the appropriate
 454       --  environment variable. Get this value, extract the directory names
 455       --  and store in the tables.
 456 
 457       --  Check for eventual project path file env vars
 458 
 459       Path_File_Name := Getenv (Project_Include_Path_File);
 460 
 461       if Path_File_Name'Length > 0 then
 462          Get_Dirs_From_File (Additional_Source_Dir => True);
 463       end if;
 464 
 465       Path_File_Name := Getenv (Project_Objects_Path_File);
 466 
 467       if Path_File_Name'Length > 0 then
 468          Get_Dirs_From_File (Additional_Source_Dir => False);
 469       end if;
 470 
 471       --  Put path name in canonical form
 472 
 473       for Additional_Source_Dir in False .. True loop
 474          if Additional_Source_Dir then
 475             Search_Path := Getenv (Ada_Include_Path);
 476 
 477             if Search_Path'Length > 0 then
 478                Search_Path := To_Canonical_Path_Spec (Search_Path.all);
 479             end if;
 480 
 481          else
 482             Search_Path := Getenv (Ada_Objects_Path);
 483 
 484             if Search_Path'Length > 0 then
 485                Search_Path := To_Canonical_Path_Spec (Search_Path.all);
 486             end if;
 487          end if;
 488 
 489          Get_Next_Dir_In_Path_Init (Search_Path);
 490          loop
 491             Search_Dir := Get_Next_Dir_In_Path (Search_Path);
 492             exit when Search_Dir = null;
 493             Add_Search_Dir (Search_Dir, Additional_Source_Dir);
 494          end loop;
 495       end loop;
 496 
 497       --  For the compiler, if --RTS= was specified, add the runtime
 498       --  directories.
 499 
 500       if RTS_Src_Path_Name /= null and then RTS_Lib_Path_Name /= null then
 501          Add_Search_Dirs (RTS_Src_Path_Name, Include);
 502          Add_Search_Dirs (RTS_Lib_Path_Name, Objects);
 503 
 504       else
 505          if not Opt.No_Stdinc then
 506 
 507             --  For WIN32 systems, look for any system libraries defined in
 508             --  the registry. These are added to both source and object
 509             --  directories.
 510 
 511             Search_Path := String_Access (Get_Libraries_From_Registry);
 512 
 513             Get_Next_Dir_In_Path_Init (Search_Path);
 514             loop
 515                Search_Dir := Get_Next_Dir_In_Path (Search_Path);
 516                exit when Search_Dir = null;
 517                Add_Search_Dir (Search_Dir, False);
 518                Add_Search_Dir (Search_Dir, True);
 519             end loop;
 520 
 521             --  The last place to look are the defaults
 522 
 523             Search_Path :=
 524               Read_Default_Search_Dirs
 525                 (String_Access (Update_Path (Search_Dir_Prefix)),
 526                  Include_Search_File,
 527                  String_Access (Update_Path (Include_Dir_Default_Name)));
 528 
 529             Get_Next_Dir_In_Path_Init (Search_Path);
 530             loop
 531                Search_Dir := Get_Next_Dir_In_Path (Search_Path);
 532                exit when Search_Dir = null;
 533                Add_Search_Dir (Search_Dir, True);
 534             end loop;
 535          end if;
 536 
 537          --  Even when -nostdlib is used, we still want to have visibility on
 538          --  the run-time object directory, as it is used by gnatbind to find
 539          --  the run-time ALI files in "real" ZFP set up.
 540 
 541          if not Opt.RTS_Switch then
 542             Search_Path :=
 543               Read_Default_Search_Dirs
 544                 (String_Access (Update_Path (Search_Dir_Prefix)),
 545                  Objects_Search_File,
 546                  String_Access (Update_Path (Object_Dir_Default_Name)));
 547 
 548             Get_Next_Dir_In_Path_Init (Search_Path);
 549             loop
 550                Search_Dir := Get_Next_Dir_In_Path (Search_Path);
 551                exit when Search_Dir = null;
 552                Add_Search_Dir (Search_Dir, False);
 553             end loop;
 554          end if;
 555       end if;
 556    end Add_Default_Search_Dirs;
 557 
 558    --------------
 559    -- Add_File --
 560    --------------
 561 
 562    procedure Add_File (File_Name : String; Index : Int := No_Index) is
 563    begin
 564       Number_File_Names := Number_File_Names + 1;
 565 
 566       --  As Add_File may be called for mains specified inside a project file,
 567       --  File_Names may be too short and needs to be extended.
 568 
 569       if Number_File_Names > File_Names'Last then
 570          File_Names := new File_Name_Array'(File_Names.all & File_Names.all);
 571          File_Indexes :=
 572            new File_Index_Array'(File_Indexes.all & File_Indexes.all);
 573       end if;
 574 
 575       File_Names   (Number_File_Names) := new String'(File_Name);
 576       File_Indexes (Number_File_Names) := Index;
 577    end Add_File;
 578 
 579    ------------------------
 580    -- Add_Lib_Search_Dir --
 581    ------------------------
 582 
 583    procedure Add_Lib_Search_Dir (Dir : String) is
 584    begin
 585       if Dir'Length = 0 then
 586          Fail ("missing library directory name");
 587       end if;
 588 
 589       declare
 590          Norm : String_Ptr := Normalize_Directory_Name (Dir);
 591 
 592       begin
 593          --  Do nothing if the directory is already in the list. This saves
 594          --  system calls and avoid unneeded work
 595 
 596          for D in Lib_Search_Directories.First ..
 597                   Lib_Search_Directories.Last
 598          loop
 599             if Lib_Search_Directories.Table (D).all = Norm.all then
 600                Free (Norm);
 601                return;
 602             end if;
 603          end loop;
 604 
 605          Lib_Search_Directories.Increment_Last;
 606          Lib_Search_Directories.Table (Lib_Search_Directories.Last) := Norm;
 607       end;
 608    end Add_Lib_Search_Dir;
 609 
 610    ---------------------
 611    -- Add_Search_Dirs --
 612    ---------------------
 613 
 614    procedure Add_Search_Dirs
 615      (Search_Path : String_Ptr;
 616       Path_Type   : Search_File_Type)
 617    is
 618       Current_Search_Path : String_Access;
 619 
 620    begin
 621       Get_Next_Dir_In_Path_Init (String_Access (Search_Path));
 622       loop
 623          Current_Search_Path :=
 624            Get_Next_Dir_In_Path (String_Access (Search_Path));
 625          exit when Current_Search_Path = null;
 626 
 627          if Path_Type = Include then
 628             Add_Src_Search_Dir (Current_Search_Path.all);
 629          else
 630             Add_Lib_Search_Dir (Current_Search_Path.all);
 631          end if;
 632       end loop;
 633    end Add_Search_Dirs;
 634 
 635    ------------------------
 636    -- Add_Src_Search_Dir --
 637    ------------------------
 638 
 639    procedure Add_Src_Search_Dir (Dir : String) is
 640    begin
 641       if Dir'Length = 0 then
 642          Fail ("missing source directory name");
 643       end if;
 644 
 645       Src_Search_Directories.Increment_Last;
 646       Src_Search_Directories.Table (Src_Search_Directories.Last) :=
 647         Normalize_Directory_Name (Dir);
 648    end Add_Src_Search_Dir;
 649 
 650    --------------------------------
 651    -- Append_Suffix_To_File_Name --
 652    --------------------------------
 653 
 654    function Append_Suffix_To_File_Name
 655      (Name   : File_Name_Type;
 656       Suffix : String) return File_Name_Type
 657    is
 658    begin
 659       Get_Name_String (Name);
 660       Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 661       Name_Len := Name_Len + Suffix'Length;
 662       return Name_Find;
 663    end Append_Suffix_To_File_Name;
 664 
 665    ---------------------
 666    -- C_String_Length --
 667    ---------------------
 668 
 669    function C_String_Length (S : Address) return CRTL.size_t is
 670    begin
 671       if S = Null_Address then
 672          return 0;
 673       else
 674          return CRTL.strlen (S);
 675       end if;
 676    end C_String_Length;
 677 
 678    ------------------------------
 679    -- Canonical_Case_File_Name --
 680    ------------------------------
 681 
 682    procedure Canonical_Case_File_Name (S : in out String) is
 683    begin
 684       if not File_Names_Case_Sensitive then
 685          To_Lower (S);
 686       end if;
 687    end Canonical_Case_File_Name;
 688 
 689    ---------------------------------
 690    -- Canonical_Case_Env_Var_Name --
 691    ---------------------------------
 692 
 693    procedure Canonical_Case_Env_Var_Name (S : in out String) is
 694    begin
 695       if not Env_Vars_Case_Sensitive then
 696          To_Lower (S);
 697       end if;
 698    end Canonical_Case_Env_Var_Name;
 699 
 700    ---------------------------
 701    -- Create_File_And_Check --
 702    ---------------------------
 703 
 704    procedure Create_File_And_Check
 705      (Fdesc : out File_Descriptor;
 706       Fmode : Mode)
 707    is
 708    begin
 709       Output_File_Name := Name_Enter;
 710       Fdesc := Create_File (Name_Buffer'Address, Fmode);
 711 
 712       if Fdesc = Invalid_FD then
 713          Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
 714       end if;
 715    end Create_File_And_Check;
 716 
 717    -----------------------------------
 718    -- Open_File_To_Append_And_Check --
 719    -----------------------------------
 720 
 721    procedure Open_File_To_Append_And_Check
 722      (Fdesc : out File_Descriptor;
 723       Fmode : Mode)
 724    is
 725    begin
 726       Output_File_Name := Name_Enter;
 727       Fdesc := Open_Append (Name_Buffer'Address, Fmode);
 728 
 729       if Fdesc = Invalid_FD then
 730          Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
 731       end if;
 732    end Open_File_To_Append_And_Check;
 733 
 734    ------------------------
 735    -- Current_File_Index --
 736    ------------------------
 737 
 738    function Current_File_Index return Int is
 739    begin
 740       return File_Indexes (Current_File_Name_Index);
 741    end Current_File_Index;
 742 
 743    --------------------------------
 744    -- Current_Library_File_Stamp --
 745    --------------------------------
 746 
 747    function Current_Library_File_Stamp return Time_Stamp_Type is
 748    begin
 749       return Current_Full_Lib_Stamp;
 750    end Current_Library_File_Stamp;
 751 
 752    -------------------------------
 753    -- Current_Object_File_Stamp --
 754    -------------------------------
 755 
 756    function Current_Object_File_Stamp return Time_Stamp_Type is
 757    begin
 758       return Current_Full_Obj_Stamp;
 759    end Current_Object_File_Stamp;
 760 
 761    -------------------------------
 762    -- Current_Source_File_Stamp --
 763    -------------------------------
 764 
 765    function Current_Source_File_Stamp return Time_Stamp_Type is
 766    begin
 767       return Current_Full_Source_Stamp;
 768    end Current_Source_File_Stamp;
 769 
 770    ----------------------------
 771    -- Dir_In_Obj_Search_Path --
 772    ----------------------------
 773 
 774    function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is
 775    begin
 776       if Opt.Look_In_Primary_Dir then
 777          return
 778            Lib_Search_Directories.Table (Primary_Directory + Position - 1);
 779       else
 780          return Lib_Search_Directories.Table (Primary_Directory + Position);
 781       end if;
 782    end Dir_In_Obj_Search_Path;
 783 
 784    ----------------------------
 785    -- Dir_In_Src_Search_Path --
 786    ----------------------------
 787 
 788    function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is
 789    begin
 790       if Opt.Look_In_Primary_Dir then
 791          return
 792            Src_Search_Directories.Table (Primary_Directory + Position - 1);
 793       else
 794          return Src_Search_Directories.Table (Primary_Directory + Position);
 795       end if;
 796    end Dir_In_Src_Search_Path;
 797 
 798    ----------------------------
 799    -- Dump_Source_File_Names --
 800    ----------------------------
 801 
 802    procedure Dump_Source_File_Names is
 803       subtype Rng is Int range File_Name_Chars.First .. File_Name_Chars.Last;
 804    begin
 805       Write_Str (String (File_Name_Chars.Table (Rng)));
 806    end Dump_Source_File_Names;
 807 
 808    ---------------------
 809    -- Executable_Name --
 810    ---------------------
 811 
 812    function Executable_Name
 813      (Name              : File_Name_Type;
 814       Only_If_No_Suffix : Boolean := False) return File_Name_Type
 815    is
 816       Exec_Suffix : String_Access;
 817       Add_Suffix  : Boolean;
 818 
 819    begin
 820       if Name = No_File then
 821          return No_File;
 822       end if;
 823 
 824       if Executable_Extension_On_Target = No_Name then
 825          Exec_Suffix := Get_Target_Executable_Suffix;
 826       else
 827          Get_Name_String (Executable_Extension_On_Target);
 828          Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
 829       end if;
 830 
 831       if Exec_Suffix'Length /= 0 then
 832          Get_Name_String (Name);
 833 
 834          Add_Suffix := True;
 835          if Only_If_No_Suffix then
 836             for J in reverse 1 .. Name_Len loop
 837                if Name_Buffer (J) = '.' then
 838                   Add_Suffix := False;
 839                   exit;
 840 
 841                elsif Name_Buffer (J) = '/' or else
 842                      Name_Buffer (J) = Directory_Separator
 843                then
 844                   exit;
 845                end if;
 846             end loop;
 847          end if;
 848 
 849          if Add_Suffix then
 850             declare
 851                Buffer : String := Name_Buffer (1 .. Name_Len);
 852 
 853             begin
 854                --  Get the file name in canonical case to accept as is. Names
 855                --  end with ".EXE" on Windows.
 856 
 857                Canonical_Case_File_Name (Buffer);
 858 
 859                --  If Executable doesn't end with the executable suffix, add it
 860 
 861                if Buffer'Length <= Exec_Suffix'Length
 862                  or else
 863                    Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last)
 864                      /= Exec_Suffix.all
 865                then
 866                   Name_Buffer
 867                     (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
 868                       Exec_Suffix.all;
 869                   Name_Len := Name_Len + Exec_Suffix'Length;
 870                   Free (Exec_Suffix);
 871                   return Name_Find;
 872                end if;
 873             end;
 874          end if;
 875       end if;
 876 
 877       Free (Exec_Suffix);
 878       return Name;
 879    end Executable_Name;
 880 
 881    function Executable_Name
 882      (Name              : String;
 883       Only_If_No_Suffix : Boolean := False) return String
 884    is
 885       Exec_Suffix    : String_Access;
 886       Add_Suffix     : Boolean;
 887       Canonical_Name : String := Name;
 888 
 889    begin
 890       if Executable_Extension_On_Target = No_Name then
 891          Exec_Suffix := Get_Target_Executable_Suffix;
 892       else
 893          Get_Name_String (Executable_Extension_On_Target);
 894          Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
 895       end if;
 896 
 897       if Exec_Suffix'Length = 0 then
 898          Free (Exec_Suffix);
 899          return Name;
 900 
 901       else
 902          declare
 903             Suffix : constant String := Exec_Suffix.all;
 904 
 905          begin
 906             Free (Exec_Suffix);
 907             Canonical_Case_File_Name (Canonical_Name);
 908 
 909             Add_Suffix := True;
 910             if Only_If_No_Suffix then
 911                for J in reverse Canonical_Name'Range loop
 912                   if Canonical_Name (J) = '.' then
 913                      Add_Suffix := False;
 914                      exit;
 915 
 916                   elsif Canonical_Name (J) = '/' or else
 917                         Canonical_Name (J) = Directory_Separator
 918                   then
 919                      exit;
 920                   end if;
 921                end loop;
 922             end if;
 923 
 924             if Add_Suffix and then
 925               (Canonical_Name'Length <= Suffix'Length
 926                or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
 927                                        .. Canonical_Name'Last) /= Suffix)
 928             then
 929                declare
 930                   Result : String (1 .. Name'Length + Suffix'Length);
 931                begin
 932                   Result (1 .. Name'Length) := Name;
 933                   Result (Name'Length + 1 .. Result'Last) := Suffix;
 934                   return Result;
 935                end;
 936             else
 937                return Name;
 938             end if;
 939          end;
 940       end if;
 941    end Executable_Name;
 942 
 943    -----------------------
 944    -- Executable_Prefix --
 945    -----------------------
 946 
 947    function Executable_Prefix return String_Ptr is
 948 
 949       function Get_Install_Dir (Exec : String) return String_Ptr;
 950       --  S is the executable name preceded by the absolute or relative
 951       --  path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
 952 
 953       ---------------------
 954       -- Get_Install_Dir --
 955       ---------------------
 956 
 957       function Get_Install_Dir (Exec : String) return String_Ptr is
 958          Full_Path : constant String := Normalize_Pathname (Exec);
 959          --  Use the full path, so that we find "lib" or "bin", even when
 960          --  the tool has been invoked with a relative path, as in
 961          --  "./gnatls -v" invoked in the GNAT bin directory.
 962 
 963       begin
 964          for J in reverse Full_Path'Range loop
 965             if Is_Directory_Separator (Full_Path (J)) then
 966                if J < Full_Path'Last - 5 then
 967                   if (To_Lower (Full_Path (J + 1)) = 'l'
 968                       and then To_Lower (Full_Path (J + 2)) = 'i'
 969                       and then To_Lower (Full_Path (J + 3)) = 'b')
 970                     or else
 971                       (To_Lower (Full_Path (J + 1)) = 'b'
 972                        and then To_Lower (Full_Path (J + 2)) = 'i'
 973                        and then To_Lower (Full_Path (J + 3)) = 'n')
 974                   then
 975                      return new String'(Full_Path (Full_Path'First .. J));
 976                   end if;
 977                end if;
 978             end if;
 979          end loop;
 980 
 981          return new String'("");
 982       end Get_Install_Dir;
 983 
 984    --  Start of processing for Executable_Prefix
 985 
 986    begin
 987       if Exec_Name = null then
 988          Exec_Name := new String (1 .. Len_Arg (0));
 989          Osint.Fill_Arg (Exec_Name (1)'Address, 0);
 990       end if;
 991 
 992       --  First determine if a path prefix was placed in front of the
 993       --  executable name.
 994 
 995       for J in reverse Exec_Name'Range loop
 996          if Is_Directory_Separator (Exec_Name (J)) then
 997             return Get_Install_Dir (Exec_Name.all);
 998          end if;
 999       end loop;
1000 
1001       --  If we come here, the user has typed the executable name with no
1002       --  directory prefix.
1003 
1004       return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all);
1005    end Executable_Prefix;
1006 
1007    ------------------
1008    -- Exit_Program --
1009    ------------------
1010 
1011    procedure Exit_Program (Exit_Code : Exit_Code_Type) is
1012    begin
1013       --  The program will exit with the following status:
1014 
1015       --    0 if the object file has been generated (with or without warnings)
1016       --    1 if recompilation was not needed (smart recompilation)
1017       --    2 if gnat1 has been killed by a signal (detected by GCC)
1018       --    4 for a fatal error
1019       --    5 if there were errors
1020       --    6 if no code has been generated (spec)
1021 
1022       --  Note that exit code 3 is not used and must not be used as this is
1023       --  the code returned by a program aborted via C abort() routine on
1024       --  Windows. GCC checks for that case and thinks that the child process
1025       --  has been aborted. This code (exit code 3) used to be the code used
1026       --  for E_No_Code, but E_No_Code was changed to 6 for this reason.
1027 
1028       case Exit_Code is
1029          when E_Success    => OS_Exit (0);
1030          when E_Warnings   => OS_Exit (0);
1031          when E_No_Compile => OS_Exit (1);
1032          when E_Fatal      => OS_Exit (4);
1033          when E_Errors     => OS_Exit (5);
1034          when E_No_Code    => OS_Exit (6);
1035          when E_Abort      => OS_Abort;
1036       end case;
1037    end Exit_Program;
1038 
1039    ----------
1040    -- Fail --
1041    ----------
1042 
1043    procedure Fail (S : String) is
1044    begin
1045       --  We use Output in case there is a special output set up. In this case
1046       --  Set_Standard_Error will have no immediate effect.
1047 
1048       Set_Standard_Error;
1049       Osint.Write_Program_Name;
1050       Write_Str (": ");
1051       Write_Str (S);
1052       Write_Eol;
1053 
1054       Exit_Program (E_Fatal);
1055    end Fail;
1056 
1057    ---------------
1058    -- File_Hash --
1059    ---------------
1060 
1061    function File_Hash (F : File_Name_Type) return File_Hash_Num is
1062    begin
1063       return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
1064    end File_Hash;
1065 
1066    -----------------
1067    -- File_Length --
1068    -----------------
1069 
1070    function File_Length
1071      (Name : C_File_Name;
1072       Attr : access File_Attributes) return Long_Integer
1073    is
1074       function Internal
1075         (F : Integer;
1076          N : C_File_Name;
1077          A : System.Address) return CRTL.int64;
1078       pragma Import (C, Internal, "__gnat_file_length_attr");
1079 
1080    begin
1081       --  The conversion from int64 to Long_Integer is ok here as this
1082       --  routine is only to be used by the compiler and we do not expect
1083       --  a unit to be larger than a 32bit integer.
1084 
1085       return Long_Integer (Internal (-1, Name, Attr.all'Address));
1086    end File_Length;
1087 
1088    ---------------------
1089    -- File_Time_Stamp --
1090    ---------------------
1091 
1092    function File_Time_Stamp
1093      (Name : C_File_Name;
1094       Attr : access File_Attributes) return OS_Time
1095    is
1096       function Internal (N : C_File_Name; A : System.Address) return OS_Time;
1097       pragma Import (C, Internal, "__gnat_file_time_name_attr");
1098    begin
1099       return Internal (Name, Attr.all'Address);
1100    end File_Time_Stamp;
1101 
1102    function File_Time_Stamp
1103      (Name : Path_Name_Type;
1104       Attr : access File_Attributes) return Time_Stamp_Type
1105    is
1106    begin
1107       if Name = No_Path then
1108          return Empty_Time_Stamp;
1109       end if;
1110 
1111       Get_Name_String (Name);
1112       Name_Buffer (Name_Len + 1) := ASCII.NUL;
1113       return OS_Time_To_GNAT_Time
1114                (File_Time_Stamp (Name_Buffer'Address, Attr));
1115    end File_Time_Stamp;
1116 
1117    ----------------
1118    -- File_Stamp --
1119    ----------------
1120 
1121    function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
1122    begin
1123       if Name = No_File then
1124          return Empty_Time_Stamp;
1125       end if;
1126 
1127       Get_Name_String (Name);
1128 
1129       --  File_Time_Stamp will always return Invalid_Time if the file does
1130       --  not exist, and OS_Time_To_GNAT_Time will convert this value to
1131       --  Empty_Time_Stamp. Therefore we do not need to first test whether
1132       --  the file actually exists, which saves a system call.
1133 
1134       return OS_Time_To_GNAT_Time
1135                (File_Time_Stamp (Name_Buffer (1 .. Name_Len)));
1136    end File_Stamp;
1137 
1138    function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is
1139    begin
1140       return File_Stamp (File_Name_Type (Name));
1141    end File_Stamp;
1142 
1143    ---------------
1144    -- Find_File --
1145    ---------------
1146 
1147    function Find_File
1148      (N         : File_Name_Type;
1149       T         : File_Type;
1150       Full_Name : Boolean := False) return File_Name_Type
1151    is
1152       Attr  : aliased File_Attributes;
1153       Found : File_Name_Type;
1154    begin
1155       Find_File (N, T, Found, Attr'Access, Full_Name);
1156       return Found;
1157    end Find_File;
1158 
1159    ---------------
1160    -- Find_File --
1161    ---------------
1162 
1163    procedure Find_File
1164      (N         : File_Name_Type;
1165       T         : File_Type;
1166       Found     : out File_Name_Type;
1167       Attr      : access File_Attributes;
1168       Full_Name : Boolean := False)
1169    is
1170    begin
1171       Get_Name_String (N);
1172 
1173       declare
1174          File_Name : String renames Name_Buffer (1 .. Name_Len);
1175          File      : File_Name_Type := No_File;
1176          Last_Dir  : Natural;
1177 
1178       begin
1179          --  If we are looking for a config file, look only in the current
1180          --  directory, i.e. return input argument unchanged. Also look only in
1181          --  the current directory if we are looking for a .dg file (happens in
1182          --  -gnatD mode).
1183 
1184          if T = Config
1185            or else (Debug_Generated_Code
1186                      and then Name_Len > 3
1187                      and then Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg")
1188          then
1189             Found := N;
1190             Attr.all  := Unknown_Attributes;
1191 
1192             if T = Config and then Full_Name then
1193                declare
1194                   Full_Path : constant String :=
1195                                 Normalize_Pathname (Get_Name_String (N));
1196                   Full_Size : constant Natural := Full_Path'Length;
1197                begin
1198                   Name_Buffer (1 .. Full_Size) := Full_Path;
1199                   Name_Len := Full_Size;
1200                   Found := Name_Find;
1201                end;
1202             end if;
1203 
1204             return;
1205 
1206          --  If we are trying to find the current main file just look in the
1207          --  directory where the user said it was.
1208 
1209          elsif Look_In_Primary_Directory_For_Current_Main
1210            and then Current_Main = N
1211          then
1212             Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
1213             return;
1214 
1215          --  Otherwise do standard search for source file
1216 
1217          else
1218             --  Check the mapping of this file name
1219 
1220             File := Mapped_Path_Name (N);
1221 
1222             --  If the file name is mapped to a path name, return the
1223             --  corresponding path name
1224 
1225             if File /= No_File then
1226 
1227                --  For locally removed file, Error_Name is returned; then
1228                --  return No_File, indicating the file is not a source.
1229 
1230                if File = Error_File_Name then
1231                   Found := No_File;
1232                else
1233                   Found := File;
1234                end if;
1235 
1236                Attr.all := Unknown_Attributes;
1237                return;
1238             end if;
1239 
1240             --  First place to look is in the primary directory (i.e. the same
1241             --  directory as the source) unless this has been disabled with -I-
1242 
1243             if Opt.Look_In_Primary_Dir then
1244                Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
1245 
1246                if Found /= No_File then
1247                   return;
1248                end if;
1249             end if;
1250 
1251             --  Finally look in directories specified with switches -I/-aI/-aO
1252 
1253             if T = Library then
1254                Last_Dir := Lib_Search_Directories.Last;
1255             else
1256                Last_Dir := Src_Search_Directories.Last;
1257             end if;
1258 
1259             for D in Primary_Directory + 1 .. Last_Dir loop
1260                Locate_File (N, T, D, File_Name, Found, Attr);
1261 
1262                if Found /= No_File then
1263                   return;
1264                end if;
1265             end loop;
1266 
1267             Attr.all := Unknown_Attributes;
1268             Found := No_File;
1269          end if;
1270       end;
1271    end Find_File;
1272 
1273    -----------------------
1274    -- Find_Program_Name --
1275    -----------------------
1276 
1277    procedure Find_Program_Name is
1278       Command_Name : String (1 .. Len_Arg (0));
1279       Cindex1      : Integer := Command_Name'First;
1280       Cindex2      : Integer := Command_Name'Last;
1281 
1282    begin
1283       Fill_Arg (Command_Name'Address, 0);
1284 
1285       if Command_Name = "" then
1286          Name_Len := 0;
1287          return;
1288       end if;
1289 
1290       --  The program name might be specified by a full path name. However,
1291       --  we don't want to print that all out in an error message, so the
1292       --  path might need to be stripped away.
1293 
1294       for J in reverse Cindex1 .. Cindex2 loop
1295          if Is_Directory_Separator (Command_Name (J)) then
1296             Cindex1 := J + 1;
1297             exit;
1298          end if;
1299       end loop;
1300 
1301       --  Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
1302       --  POSIX command "basename argv[0]"
1303 
1304       --  Strip off any executable extension (usually nothing or .exe)
1305       --  but formally reported by autoconf in the variable EXEEXT
1306 
1307       if Cindex2 - Cindex1 >= 4 then
1308          if To_Lower (Command_Name (Cindex2 - 3)) = '.'
1309             and then To_Lower (Command_Name (Cindex2 - 2)) = 'e'
1310             and then To_Lower (Command_Name (Cindex2 - 1)) = 'x'
1311             and then To_Lower (Command_Name (Cindex2)) = 'e'
1312          then
1313             Cindex2 := Cindex2 - 4;
1314          end if;
1315       end if;
1316 
1317       Name_Len := Cindex2 - Cindex1 + 1;
1318       Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
1319    end Find_Program_Name;
1320 
1321    ------------------------
1322    -- Full_Lib_File_Name --
1323    ------------------------
1324 
1325    procedure Full_Lib_File_Name
1326      (N        : File_Name_Type;
1327       Lib_File : out File_Name_Type;
1328       Attr     : out File_Attributes)
1329    is
1330       A : aliased File_Attributes;
1331    begin
1332       --  ??? seems we could use Smart_Find_File here
1333       Find_File (N, Library, Lib_File, A'Access);
1334       Attr := A;
1335    end Full_Lib_File_Name;
1336 
1337    ------------------------
1338    -- Full_Lib_File_Name --
1339    ------------------------
1340 
1341    function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
1342       Attr : File_Attributes;
1343       File : File_Name_Type;
1344    begin
1345       Full_Lib_File_Name (N, File, Attr);
1346       return File;
1347    end Full_Lib_File_Name;
1348 
1349    ----------------------------
1350    -- Full_Library_Info_Name --
1351    ----------------------------
1352 
1353    function Full_Library_Info_Name return File_Name_Type is
1354    begin
1355       return Current_Full_Lib_Name;
1356    end Full_Library_Info_Name;
1357 
1358    ---------------------------
1359    -- Full_Object_File_Name --
1360    ---------------------------
1361 
1362    function Full_Object_File_Name return File_Name_Type is
1363    begin
1364       return Current_Full_Obj_Name;
1365    end Full_Object_File_Name;
1366 
1367    ----------------------
1368    -- Full_Source_Name --
1369    ----------------------
1370 
1371    function Full_Source_Name return File_Name_Type is
1372    begin
1373       return Current_Full_Source_Name;
1374    end Full_Source_Name;
1375 
1376    ----------------------
1377    -- Full_Source_Name --
1378    ----------------------
1379 
1380    function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
1381    begin
1382       return Smart_Find_File (N, Source);
1383    end Full_Source_Name;
1384 
1385    ----------------------
1386    -- Full_Source_Name --
1387    ----------------------
1388 
1389    procedure Full_Source_Name
1390      (N         : File_Name_Type;
1391       Full_File : out File_Name_Type;
1392       Attr      : access File_Attributes) is
1393    begin
1394       Smart_Find_File (N, Source, Full_File, Attr.all);
1395    end Full_Source_Name;
1396 
1397    -------------------
1398    -- Get_Directory --
1399    -------------------
1400 
1401    function Get_Directory (Name : File_Name_Type) return File_Name_Type is
1402    begin
1403       Get_Name_String (Name);
1404 
1405       for J in reverse 1 .. Name_Len loop
1406          if Is_Directory_Separator (Name_Buffer (J)) then
1407             Name_Len := J;
1408             return Name_Find;
1409          end if;
1410       end loop;
1411 
1412       Name_Len := Hostparm.Normalized_CWD'Length;
1413       Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
1414       return Name_Find;
1415    end Get_Directory;
1416 
1417    --------------------------
1418    -- Get_Next_Dir_In_Path --
1419    --------------------------
1420 
1421    Search_Path_Pos : Integer;
1422    --  Keeps track of current position in search path. Initialized by the
1423    --  call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
1424 
1425    function Get_Next_Dir_In_Path
1426      (Search_Path : String_Access) return String_Access
1427    is
1428       Lower_Bound : Positive := Search_Path_Pos;
1429       Upper_Bound : Positive;
1430 
1431    begin
1432       loop
1433          while Lower_Bound <= Search_Path'Last
1434            and then Search_Path.all (Lower_Bound) = Path_Separator
1435          loop
1436             Lower_Bound := Lower_Bound + 1;
1437          end loop;
1438 
1439          exit when Lower_Bound > Search_Path'Last;
1440 
1441          Upper_Bound := Lower_Bound;
1442          while Upper_Bound <= Search_Path'Last
1443            and then Search_Path.all (Upper_Bound) /= Path_Separator
1444          loop
1445             Upper_Bound := Upper_Bound + 1;
1446          end loop;
1447 
1448          Search_Path_Pos := Upper_Bound;
1449          return new String'(Search_Path.all (Lower_Bound .. Upper_Bound - 1));
1450       end loop;
1451 
1452       return null;
1453    end Get_Next_Dir_In_Path;
1454 
1455    -------------------------------
1456    -- Get_Next_Dir_In_Path_Init --
1457    -------------------------------
1458 
1459    procedure Get_Next_Dir_In_Path_Init (Search_Path : String_Access) is
1460    begin
1461       Search_Path_Pos := Search_Path'First;
1462    end Get_Next_Dir_In_Path_Init;
1463 
1464    --------------------------------------
1465    -- Get_Primary_Src_Search_Directory --
1466    --------------------------------------
1467 
1468    function Get_Primary_Src_Search_Directory return String_Ptr is
1469    begin
1470       return Src_Search_Directories.Table (Primary_Directory);
1471    end Get_Primary_Src_Search_Directory;
1472 
1473    ------------------------
1474    -- Get_RTS_Search_Dir --
1475    ------------------------
1476 
1477    function Get_RTS_Search_Dir
1478      (Search_Dir : String;
1479       File_Type  : Search_File_Type) return String_Ptr
1480    is
1481       procedure Get_Current_Dir
1482         (Dir    : System.Address;
1483          Length : System.Address);
1484       pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
1485 
1486       Max_Path : Integer;
1487       pragma Import (C, Max_Path, "__gnat_max_path_len");
1488       --  Maximum length of a path name
1489 
1490       Current_Dir        : String_Ptr;
1491       Default_Search_Dir : String_Access;
1492       Default_Suffix_Dir : String_Access;
1493       Local_Search_Dir   : String_Access;
1494       Norm_Search_Dir    : String_Access;
1495       Result_Search_Dir  : String_Access;
1496       Search_File        : String_Access;
1497       Temp_String        : String_Ptr;
1498 
1499    begin
1500       --  Add a directory separator at the end of the directory if necessary
1501       --  so that we can directly append a file to the directory
1502 
1503       if Search_Dir (Search_Dir'Last) /= Directory_Separator then
1504          Local_Search_Dir :=
1505            new String'(Search_Dir & String'(1 => Directory_Separator));
1506       else
1507          Local_Search_Dir := new String'(Search_Dir);
1508       end if;
1509 
1510       if File_Type = Include then
1511          Search_File := Include_Search_File;
1512          Default_Suffix_Dir := new String'("adainclude");
1513       else
1514          Search_File := Objects_Search_File;
1515          Default_Suffix_Dir := new String'("adalib");
1516       end if;
1517 
1518       Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all);
1519 
1520       if Is_Absolute_Path (Norm_Search_Dir.all) then
1521 
1522          --  We first verify if there is a directory Include_Search_Dir
1523          --  containing default search directories
1524 
1525          Result_Search_Dir :=
1526            Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1527          Default_Search_Dir :=
1528            new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1529          Free (Norm_Search_Dir);
1530 
1531          if Result_Search_Dir /= null then
1532             return String_Ptr (Result_Search_Dir);
1533          elsif Is_Directory (Default_Search_Dir.all) then
1534             return String_Ptr (Default_Search_Dir);
1535          else
1536             return null;
1537          end if;
1538 
1539       --  Search in the current directory
1540 
1541       else
1542          --  Get the current directory
1543 
1544          declare
1545             Buffer   : String (1 .. Max_Path + 2);
1546             Path_Len : Natural := Max_Path;
1547 
1548          begin
1549             Get_Current_Dir (Buffer'Address, Path_Len'Address);
1550 
1551             if Buffer (Path_Len) /= Directory_Separator then
1552                Path_Len := Path_Len + 1;
1553                Buffer (Path_Len) := Directory_Separator;
1554             end if;
1555 
1556             Current_Dir := new String'(Buffer (1 .. Path_Len));
1557          end;
1558 
1559          Norm_Search_Dir :=
1560            new String'(Current_Dir.all & Local_Search_Dir.all);
1561 
1562          Result_Search_Dir :=
1563            Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1564 
1565          Default_Search_Dir :=
1566            new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1567 
1568          Free (Norm_Search_Dir);
1569 
1570          if Result_Search_Dir /= null then
1571             return String_Ptr (Result_Search_Dir);
1572 
1573          elsif Is_Directory (Default_Search_Dir.all) then
1574             return String_Ptr (Default_Search_Dir);
1575 
1576          else
1577             --  Search in Search_Dir_Prefix/Search_Dir
1578 
1579             Norm_Search_Dir :=
1580               new String'
1581                (Update_Path (Search_Dir_Prefix).all & Local_Search_Dir.all);
1582 
1583             Result_Search_Dir :=
1584               Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1585 
1586             Default_Search_Dir :=
1587               new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1588 
1589             Free (Norm_Search_Dir);
1590 
1591             if Result_Search_Dir /= null then
1592                return String_Ptr (Result_Search_Dir);
1593 
1594             elsif Is_Directory (Default_Search_Dir.all) then
1595                return String_Ptr (Default_Search_Dir);
1596 
1597             else
1598                --  We finally search in Search_Dir_Prefix/rts-Search_Dir
1599 
1600                Temp_String :=
1601                  new String'(Update_Path (Search_Dir_Prefix).all & "rts-");
1602 
1603                Norm_Search_Dir :=
1604                  new String'(Temp_String.all & Local_Search_Dir.all);
1605 
1606                Result_Search_Dir :=
1607                  Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1608 
1609                Default_Search_Dir :=
1610                  new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1611                Free (Norm_Search_Dir);
1612 
1613                if Result_Search_Dir /= null then
1614                   return String_Ptr (Result_Search_Dir);
1615 
1616                elsif Is_Directory (Default_Search_Dir.all) then
1617                   return String_Ptr (Default_Search_Dir);
1618 
1619                else
1620                   return null;
1621                end if;
1622             end if;
1623          end if;
1624       end if;
1625    end Get_RTS_Search_Dir;
1626 
1627    --------------------------------
1628    -- Include_Dir_Default_Prefix --
1629    --------------------------------
1630 
1631    function Include_Dir_Default_Prefix return String_Access is
1632    begin
1633       if The_Include_Dir_Default_Prefix = null then
1634          The_Include_Dir_Default_Prefix :=
1635            String_Access (Update_Path (Include_Dir_Default_Name));
1636       end if;
1637 
1638       return The_Include_Dir_Default_Prefix;
1639    end Include_Dir_Default_Prefix;
1640 
1641    function Include_Dir_Default_Prefix return String is
1642    begin
1643       return Include_Dir_Default_Prefix.all;
1644    end Include_Dir_Default_Prefix;
1645 
1646    ----------------
1647    -- Initialize --
1648    ----------------
1649 
1650    procedure Initialize is
1651    begin
1652       Number_File_Names       := 0;
1653       Current_File_Name_Index := 0;
1654 
1655       Src_Search_Directories.Init;
1656       Lib_Search_Directories.Init;
1657 
1658       --  Start off by setting all suppress options, to False. The special
1659       --  overflow fields are set to Not_Set (they will be set by -gnatp, or
1660       --  by -gnato, or, if neither of these appear, in Adjust_Global_Switches
1661       --  in Gnat1drv).
1662 
1663       Suppress_Options := ((others => False), Not_Set, Not_Set);
1664 
1665       --  Reserve the first slot in the search paths table. This is the
1666       --  directory of the main source file or main library file and is filled
1667       --  in by each call to Next_Main_Source/Next_Main_Lib_File with the
1668       --  directory specified for this main source or library file. This is the
1669       --  directory which is searched first by default. This default search is
1670       --  inhibited by the option -I- for both source and library files.
1671 
1672       Src_Search_Directories.Set_Last (Primary_Directory);
1673       Src_Search_Directories.Table (Primary_Directory) := new String'("");
1674 
1675       Lib_Search_Directories.Set_Last (Primary_Directory);
1676       Lib_Search_Directories.Table (Primary_Directory) := new String'("");
1677    end Initialize;
1678 
1679    ------------------
1680    -- Is_Directory --
1681    ------------------
1682 
1683    function Is_Directory
1684      (Name : C_File_Name; Attr : access File_Attributes) return Boolean
1685    is
1686       function Internal (N : C_File_Name; A : System.Address) return Integer;
1687       pragma Import (C, Internal, "__gnat_is_directory_attr");
1688    begin
1689       return Internal (Name, Attr.all'Address) /= 0;
1690    end Is_Directory;
1691 
1692    ----------------------------
1693    -- Is_Directory_Separator --
1694    ----------------------------
1695 
1696    function Is_Directory_Separator (C : Character) return Boolean is
1697    begin
1698       --  In addition to the default directory_separator allow the '/' to
1699       --  act as separator since this is allowed in MS-DOS and Windows.
1700 
1701       return C = Directory_Separator or else C = '/';
1702    end Is_Directory_Separator;
1703 
1704    -------------------------
1705    -- Is_Readonly_Library --
1706    -------------------------
1707 
1708    function Is_Readonly_Library (File : File_Name_Type) return Boolean is
1709    begin
1710       Get_Name_String (File);
1711 
1712       pragma Assert (Name_Buffer (Name_Len - 3 .. Name_Len) = ".ali");
1713 
1714       return not Is_Writable_File (Name_Buffer (1 .. Name_Len));
1715    end Is_Readonly_Library;
1716 
1717    ------------------------
1718    -- Is_Executable_File --
1719    ------------------------
1720 
1721    function Is_Executable_File
1722      (Name : C_File_Name; Attr : access File_Attributes) return Boolean
1723    is
1724       function Internal (N : C_File_Name; A : System.Address) return Integer;
1725       pragma Import (C, Internal, "__gnat_is_executable_file_attr");
1726    begin
1727       return Internal (Name, Attr.all'Address) /= 0;
1728    end Is_Executable_File;
1729 
1730    ----------------------
1731    -- Is_Readable_File --
1732    ----------------------
1733 
1734    function Is_Readable_File
1735      (Name : C_File_Name; Attr : access File_Attributes) return Boolean
1736    is
1737       function Internal (N : C_File_Name; A : System.Address) return Integer;
1738       pragma Import (C, Internal, "__gnat_is_readable_file_attr");
1739    begin
1740       return Internal (Name, Attr.all'Address) /= 0;
1741    end Is_Readable_File;
1742 
1743    ---------------------
1744    -- Is_Regular_File --
1745    ---------------------
1746 
1747    function Is_Regular_File
1748      (Name : C_File_Name; Attr : access File_Attributes) return Boolean
1749    is
1750       function Internal (N : C_File_Name; A : System.Address) return Integer;
1751       pragma Import (C, Internal, "__gnat_is_regular_file_attr");
1752    begin
1753       return Internal (Name, Attr.all'Address) /= 0;
1754    end Is_Regular_File;
1755 
1756    ----------------------
1757    -- Is_Symbolic_Link --
1758    ----------------------
1759 
1760    function Is_Symbolic_Link
1761      (Name : C_File_Name; Attr : access File_Attributes) return Boolean
1762    is
1763       function Internal (N : C_File_Name; A : System.Address) return Integer;
1764       pragma Import (C, Internal, "__gnat_is_symbolic_link_attr");
1765    begin
1766       return Internal (Name, Attr.all'Address) /= 0;
1767    end Is_Symbolic_Link;
1768 
1769    ----------------------
1770    -- Is_Writable_File --
1771    ----------------------
1772 
1773    function Is_Writable_File
1774      (Name : C_File_Name; Attr : access File_Attributes) return Boolean
1775    is
1776       function Internal (N : C_File_Name; A : System.Address) return Integer;
1777       pragma Import (C, Internal, "__gnat_is_writable_file_attr");
1778    begin
1779       return Internal (Name, Attr.all'Address) /= 0;
1780    end Is_Writable_File;
1781 
1782    -------------------
1783    -- Lib_File_Name --
1784    -------------------
1785 
1786    function Lib_File_Name
1787      (Source_File : File_Name_Type;
1788       Munit_Index : Nat := 0) return File_Name_Type
1789    is
1790    begin
1791       Get_Name_String (Source_File);
1792 
1793       for J in reverse 2 .. Name_Len loop
1794          if Name_Buffer (J) = '.' then
1795             Name_Len := J - 1;
1796             exit;
1797          end if;
1798       end loop;
1799 
1800       if Munit_Index /= 0 then
1801          Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
1802          Add_Nat_To_Name_Buffer (Munit_Index);
1803       end if;
1804 
1805       Add_Char_To_Name_Buffer ('.');
1806       Add_Str_To_Name_Buffer (ALI_Suffix.all);
1807       return Name_Find;
1808    end Lib_File_Name;
1809 
1810    -----------------
1811    -- Locate_File --
1812    -----------------
1813 
1814    procedure Locate_File
1815      (N     : File_Name_Type;
1816       T     : File_Type;
1817       Dir   : Natural;
1818       Name  : String;
1819       Found : out File_Name_Type;
1820       Attr  : access File_Attributes)
1821    is
1822       Dir_Name : String_Ptr;
1823 
1824    begin
1825       --  If Name is already an absolute path, do not look for a directory
1826 
1827       if Is_Absolute_Path (Name) then
1828          Dir_Name := No_Dir;
1829 
1830       elsif T = Library then
1831          Dir_Name := Lib_Search_Directories.Table (Dir);
1832 
1833       else
1834          pragma Assert (T /= Config);
1835          Dir_Name := Src_Search_Directories.Table (Dir);
1836       end if;
1837 
1838       declare
1839          Full_Name : String (1 .. Dir_Name'Length + Name'Length + 1);
1840 
1841       begin
1842          Full_Name (1 .. Dir_Name'Length) := Dir_Name.all;
1843          Full_Name (Dir_Name'Length + 1 .. Full_Name'Last - 1) := Name;
1844          Full_Name (Full_Name'Last) := ASCII.NUL;
1845 
1846          Attr.all := Unknown_Attributes;
1847 
1848          if not Is_Regular_File (Full_Name'Address, Attr) then
1849             Found := No_File;
1850 
1851          else
1852             --  If the file is in the current directory then return N itself
1853 
1854             if Dir_Name'Length = 0 then
1855                Found := N;
1856             else
1857                Name_Len := Full_Name'Length - 1;
1858                Name_Buffer (1 .. Name_Len) :=
1859                  Full_Name (1 .. Full_Name'Last - 1);
1860                Found := Name_Find;  --  ??? Was Name_Enter, no obvious reason
1861             end if;
1862          end if;
1863       end;
1864    end Locate_File;
1865 
1866    -------------------------------
1867    -- Matching_Full_Source_Name --
1868    -------------------------------
1869 
1870    function Matching_Full_Source_Name
1871      (N : File_Name_Type;
1872       T : Time_Stamp_Type) return File_Name_Type
1873    is
1874    begin
1875       Get_Name_String (N);
1876 
1877       declare
1878          File_Name : constant String := Name_Buffer (1 .. Name_Len);
1879          File      : File_Name_Type := No_File;
1880          Attr      : aliased File_Attributes;
1881          Last_Dir  : Natural;
1882 
1883       begin
1884          if Opt.Look_In_Primary_Dir then
1885             Locate_File
1886               (N, Source, Primary_Directory, File_Name, File, Attr'Access);
1887 
1888             if File /= No_File and then T = File_Stamp (N) then
1889                return File;
1890             end if;
1891          end if;
1892 
1893          Last_Dir := Src_Search_Directories.Last;
1894 
1895          for D in Primary_Directory + 1 .. Last_Dir loop
1896             Locate_File (N, Source, D, File_Name, File, Attr'Access);
1897 
1898             if File /= No_File and then T = File_Stamp (File) then
1899                return File;
1900             end if;
1901          end loop;
1902 
1903          return No_File;
1904       end;
1905    end Matching_Full_Source_Name;
1906 
1907    ----------------
1908    -- More_Files --
1909    ----------------
1910 
1911    function More_Files return Boolean is
1912    begin
1913       return (Current_File_Name_Index < Number_File_Names);
1914    end More_Files;
1915 
1916    -------------------------------
1917    -- Nb_Dir_In_Obj_Search_Path --
1918    -------------------------------
1919 
1920    function Nb_Dir_In_Obj_Search_Path return Natural is
1921    begin
1922       if Opt.Look_In_Primary_Dir then
1923          return Lib_Search_Directories.Last -  Primary_Directory + 1;
1924       else
1925          return Lib_Search_Directories.Last -  Primary_Directory;
1926       end if;
1927    end Nb_Dir_In_Obj_Search_Path;
1928 
1929    -------------------------------
1930    -- Nb_Dir_In_Src_Search_Path --
1931    -------------------------------
1932 
1933    function Nb_Dir_In_Src_Search_Path return Natural is
1934    begin
1935       if Opt.Look_In_Primary_Dir then
1936          return Src_Search_Directories.Last -  Primary_Directory + 1;
1937       else
1938          return Src_Search_Directories.Last -  Primary_Directory;
1939       end if;
1940    end Nb_Dir_In_Src_Search_Path;
1941 
1942    --------------------
1943    -- Next_Main_File --
1944    --------------------
1945 
1946    function Next_Main_File return File_Name_Type is
1947       File_Name : String_Ptr;
1948       Dir_Name  : String_Ptr;
1949       Fptr      : Natural;
1950 
1951    begin
1952       pragma Assert (More_Files);
1953 
1954       Current_File_Name_Index := Current_File_Name_Index + 1;
1955 
1956       --  Get the file and directory name
1957 
1958       File_Name := File_Names (Current_File_Name_Index);
1959       Fptr := File_Name'First;
1960 
1961       for J in reverse File_Name'Range loop
1962          if File_Name (J) = Directory_Separator
1963            or else File_Name (J) = '/'
1964          then
1965             if J = File_Name'Last then
1966                Fail ("File name missing");
1967             end if;
1968 
1969             Fptr := J + 1;
1970             exit;
1971          end if;
1972       end loop;
1973 
1974       --  Save name of directory in which main unit resides for use in
1975       --  locating other units
1976 
1977       Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1));
1978 
1979       case Running_Program is
1980 
1981          when Compiler =>
1982             Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1983             Look_In_Primary_Directory_For_Current_Main := True;
1984 
1985          when Make =>
1986             Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1987 
1988             if Fptr > File_Name'First then
1989                Look_In_Primary_Directory_For_Current_Main := True;
1990             end if;
1991 
1992          when Binder | Gnatls =>
1993             Dir_Name := Normalize_Directory_Name (Dir_Name.all);
1994             Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
1995 
1996          when Unspecified =>
1997             null;
1998       end case;
1999 
2000       Name_Len := File_Name'Last - Fptr + 1;
2001       Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
2002       Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
2003       Current_Main := Name_Find;
2004 
2005       --  In the gnatmake case, the main file may have not have the
2006       --  extension. Try ".adb" first then ".ads"
2007 
2008       if Running_Program = Make then
2009          declare
2010             Orig_Main : constant File_Name_Type := Current_Main;
2011 
2012          begin
2013             if Strip_Suffix (Orig_Main) = Orig_Main then
2014                Current_Main :=
2015                  Append_Suffix_To_File_Name (Orig_Main, ".adb");
2016 
2017                if Full_Source_Name (Current_Main) = No_File then
2018                   Current_Main :=
2019                     Append_Suffix_To_File_Name (Orig_Main, ".ads");
2020 
2021                   if Full_Source_Name (Current_Main) = No_File then
2022                      Current_Main := Orig_Main;
2023                   end if;
2024                end if;
2025             end if;
2026          end;
2027       end if;
2028 
2029       return Current_Main;
2030    end Next_Main_File;
2031 
2032    ------------------------------
2033    -- Normalize_Directory_Name --
2034    ------------------------------
2035 
2036    function Normalize_Directory_Name (Directory : String) return String_Ptr is
2037 
2038       function Is_Quoted (Path : String) return Boolean;
2039       pragma Inline (Is_Quoted);
2040       --  Returns true if Path is quoted (either double or single quotes)
2041 
2042       ---------------
2043       -- Is_Quoted --
2044       ---------------
2045 
2046       function Is_Quoted (Path : String) return Boolean is
2047          First : constant Character := Path (Path'First);
2048          Last  : constant Character := Path (Path'Last);
2049 
2050       begin
2051          if (First = ''' and then Last = ''')
2052                or else
2053             (First = '"' and then Last = '"')
2054          then
2055             return True;
2056          else
2057             return False;
2058          end if;
2059       end Is_Quoted;
2060 
2061       Result : String_Ptr;
2062 
2063    --  Start of processing for Normalize_Directory_Name
2064 
2065    begin
2066       if Directory'Length = 0 then
2067          Result := new String'(Hostparm.Normalized_CWD);
2068 
2069       elsif Is_Directory_Separator (Directory (Directory'Last)) then
2070          Result := new String'(Directory);
2071 
2072       elsif Is_Quoted (Directory) then
2073 
2074          --  This is a quoted string, it certainly means that the directory
2075          --  contains some spaces for example. We can safely remove the quotes
2076          --  here as the OS_Lib.Normalize_Arguments will be called before any
2077          --  spawn routines. This ensure that quotes will be added when needed.
2078 
2079          Result := new String (1 .. Directory'Length - 1);
2080          Result (1 .. Directory'Length - 2) :=
2081            Directory (Directory'First + 1 .. Directory'Last - 1);
2082          Result (Result'Last) := Directory_Separator;
2083 
2084       else
2085          Result := new String (1 .. Directory'Length + 1);
2086          Result (1 .. Directory'Length) := Directory;
2087          Result (Directory'Length + 1) := Directory_Separator;
2088       end if;
2089 
2090       return Result;
2091    end Normalize_Directory_Name;
2092 
2093    ---------------------
2094    -- Number_Of_Files --
2095    ---------------------
2096 
2097    function Number_Of_Files return Nat is
2098    begin
2099       return Number_File_Names;
2100    end Number_Of_Files;
2101 
2102    -------------------------------
2103    -- Object_Dir_Default_Prefix --
2104    -------------------------------
2105 
2106    function Object_Dir_Default_Prefix return String is
2107       Object_Dir : String_Access :=
2108                      String_Access (Update_Path (Object_Dir_Default_Name));
2109 
2110    begin
2111       if Object_Dir = null then
2112          return "";
2113 
2114       else
2115          declare
2116             Result : constant String := Object_Dir.all;
2117          begin
2118             Free (Object_Dir);
2119             return Result;
2120          end;
2121       end if;
2122    end Object_Dir_Default_Prefix;
2123 
2124    ----------------------
2125    -- Object_File_Name --
2126    ----------------------
2127 
2128    function Object_File_Name (N : File_Name_Type) return File_Name_Type is
2129    begin
2130       if N = No_File then
2131          return No_File;
2132       end if;
2133 
2134       Get_Name_String (N);
2135       Name_Len := Name_Len - ALI_Suffix'Length - 1;
2136 
2137       for J in Target_Object_Suffix'Range loop
2138          Name_Len := Name_Len + 1;
2139          Name_Buffer (Name_Len) := Target_Object_Suffix (J);
2140       end loop;
2141 
2142       return Name_Enter;
2143    end Object_File_Name;
2144 
2145    -------------------------------
2146    -- OS_Exit_Through_Exception --
2147    -------------------------------
2148 
2149    procedure OS_Exit_Through_Exception (Status : Integer) is
2150    begin
2151       Current_Exit_Status := Status;
2152       raise Types.Terminate_Program;
2153    end OS_Exit_Through_Exception;
2154 
2155    --------------------------
2156    -- OS_Time_To_GNAT_Time --
2157    --------------------------
2158 
2159    function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
2160       GNAT_Time : Time_Stamp_Type;
2161 
2162       Y  : Year_Type;
2163       Mo : Month_Type;
2164       D  : Day_Type;
2165       H  : Hour_Type;
2166       Mn : Minute_Type;
2167       S  : Second_Type;
2168 
2169    begin
2170       if T = Invalid_Time then
2171          return Empty_Time_Stamp;
2172       end if;
2173 
2174       GM_Split (T, Y, Mo, D, H, Mn, S);
2175       Make_Time_Stamp
2176         (Year    => Nat (Y),
2177          Month   => Nat (Mo),
2178          Day     => Nat (D),
2179          Hour    => Nat (H),
2180          Minutes => Nat (Mn),
2181          Seconds => Nat (S),
2182          TS      => GNAT_Time);
2183 
2184       return GNAT_Time;
2185    end OS_Time_To_GNAT_Time;
2186 
2187    -----------------
2188    -- Prep_Suffix --
2189    -----------------
2190 
2191    function Prep_Suffix return String is
2192    begin
2193       return ".prep";
2194    end Prep_Suffix;
2195 
2196    ------------------
2197    -- Program_Name --
2198    ------------------
2199 
2200    function Program_Name (Nam : String; Prog : String) return String_Access is
2201       End_Of_Prefix   : Natural := 0;
2202       Start_Of_Prefix : Positive := 1;
2203       Start_Of_Suffix : Positive;
2204 
2205    begin
2206       --  Get the name of the current program being executed
2207 
2208       Find_Program_Name;
2209 
2210       Start_Of_Suffix := Name_Len + 1;
2211 
2212       --  Find the target prefix if any, for the cross compilation case.
2213       --  For instance in "powerpc-elf-gcc" the target prefix is
2214       --  "powerpc-elf-"
2215       --  Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1"
2216 
2217       for J in reverse 1 .. Name_Len loop
2218          if Name_Buffer (J) = '/'
2219            or else Name_Buffer (J) = Directory_Separator
2220            or else Name_Buffer (J) = ':'
2221          then
2222             Start_Of_Prefix := J + 1;
2223             exit;
2224          end if;
2225       end loop;
2226 
2227       --  Find End_Of_Prefix
2228 
2229       for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop
2230          if Name_Buffer (J .. J + Prog'Length - 1) = Prog then
2231             End_Of_Prefix := J - 1;
2232             exit;
2233          end if;
2234       end loop;
2235 
2236       if End_Of_Prefix > 1 then
2237          Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1;
2238       end if;
2239 
2240       --  Create the new program name
2241 
2242       return new String'
2243         (Name_Buffer (Start_Of_Prefix .. End_Of_Prefix)
2244          & Nam
2245          & Name_Buffer (Start_Of_Suffix .. Name_Len));
2246    end Program_Name;
2247 
2248    ------------------------------
2249    -- Read_Default_Search_Dirs --
2250    ------------------------------
2251 
2252    function Read_Default_Search_Dirs
2253      (Search_Dir_Prefix       : String_Access;
2254       Search_File             : String_Access;
2255       Search_Dir_Default_Name : String_Access) return String_Access
2256    is
2257       Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
2258       Buffer     : String (1 .. Prefix_Len + Search_File.all'Length + 1);
2259       File_FD    : File_Descriptor;
2260       S, S1      : String_Access;
2261       Len        : Integer;
2262       Curr       : Integer;
2263       Actual_Len : Integer;
2264       J1         : Integer;
2265 
2266       Prev_Was_Separator : Boolean;
2267       Nb_Relative_Dir    : Integer;
2268 
2269       function Is_Relative (S : String; K : Positive) return Boolean;
2270       pragma Inline (Is_Relative);
2271       --  Returns True if a relative directory specification is found
2272       --  in S at position K, False otherwise.
2273 
2274       -----------------
2275       -- Is_Relative --
2276       -----------------
2277 
2278       function Is_Relative (S : String; K : Positive) return Boolean is
2279       begin
2280          return not Is_Absolute_Path (S (K .. S'Last));
2281       end Is_Relative;
2282 
2283    --  Start of processing for Read_Default_Search_Dirs
2284 
2285    begin
2286       --  Construct a C compatible character string buffer
2287 
2288       Buffer (1 .. Search_Dir_Prefix.all'Length)
2289         := Search_Dir_Prefix.all;
2290       Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1)
2291         := Search_File.all;
2292       Buffer (Buffer'Last) := ASCII.NUL;
2293 
2294       File_FD := Open_Read (Buffer'Address, Binary);
2295       if File_FD = Invalid_FD then
2296          return Search_Dir_Default_Name;
2297       end if;
2298 
2299       Len := Integer (File_Length (File_FD));
2300 
2301       --  An extra character for a trailing Path_Separator is allocated
2302 
2303       S := new String (1 .. Len + 1);
2304       S (Len + 1) := Path_Separator;
2305 
2306       --  Read the file. Note that the loop is probably not necessary since the
2307       --  whole file is read at once but the loop is harmless and that way we
2308       --  are sure to accomodate systems where this is not the case.
2309 
2310       Curr := 1;
2311       Actual_Len := Len;
2312       while Actual_Len /= 0 loop
2313          Actual_Len := Read (File_FD, S (Curr)'Address, Len);
2314          Curr := Curr + Actual_Len;
2315       end loop;
2316 
2317       --  Process the file, dealing with path separators
2318 
2319       Prev_Was_Separator := True;
2320       Nb_Relative_Dir := 0;
2321       for J in 1 .. Len loop
2322 
2323          --  Treat any control character as a path separator. Note that we do
2324          --  not treat space as a path separator (we used to treat space as a
2325          --  path separator in an earlier version). That way space can appear
2326          --  as a legitimate character in a path name.
2327 
2328          --  Why do we treat all control characters as path separators???
2329 
2330          if S (J) in ASCII.NUL .. ASCII.US then
2331             S (J) := Path_Separator;
2332          end if;
2333 
2334          --  Test for explicit path separator (or control char as above)
2335 
2336          if S (J) = Path_Separator then
2337             Prev_Was_Separator := True;
2338 
2339          --  If not path separator, register use of relative directory
2340 
2341          else
2342             if Prev_Was_Separator and then Is_Relative (S.all, J) then
2343                Nb_Relative_Dir := Nb_Relative_Dir + 1;
2344             end if;
2345 
2346             Prev_Was_Separator := False;
2347          end if;
2348       end loop;
2349 
2350       if Nb_Relative_Dir = 0 then
2351          return S;
2352       end if;
2353 
2354       --  Add the Search_Dir_Prefix to all relative paths
2355 
2356       S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len);
2357       J1 := 1;
2358       Prev_Was_Separator := True;
2359       for J in 1 .. Len + 1 loop
2360          if S (J) = Path_Separator then
2361             Prev_Was_Separator := True;
2362 
2363          else
2364             if Prev_Was_Separator and then Is_Relative (S.all, J) then
2365                S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all;
2366                J1 := J1 + Prefix_Len;
2367             end if;
2368 
2369             Prev_Was_Separator := False;
2370          end if;
2371          S1 (J1) := S (J);
2372          J1 := J1 + 1;
2373       end loop;
2374 
2375       Free (S);
2376       return S1;
2377    end Read_Default_Search_Dirs;
2378 
2379    -----------------------
2380    -- Read_Library_Info --
2381    -----------------------
2382 
2383    function Read_Library_Info
2384      (Lib_File  : File_Name_Type;
2385       Fatal_Err : Boolean := False) return Text_Buffer_Ptr
2386    is
2387       File : File_Name_Type;
2388       Attr : aliased File_Attributes;
2389    begin
2390       Find_File (Lib_File, Library, File, Attr'Access);
2391       return Read_Library_Info_From_Full
2392         (Full_Lib_File => File,
2393          Lib_File_Attr => Attr'Access,
2394          Fatal_Err     => Fatal_Err);
2395    end Read_Library_Info;
2396 
2397    ---------------------------------
2398    -- Read_Library_Info_From_Full --
2399    ---------------------------------
2400 
2401    function Read_Library_Info_From_Full
2402      (Full_Lib_File : File_Name_Type;
2403       Lib_File_Attr : access File_Attributes;
2404       Fatal_Err     : Boolean := False) return Text_Buffer_Ptr
2405    is
2406       Lib_FD : File_Descriptor;
2407       --  The file descriptor for the current library file. A negative value
2408       --  indicates failure to open the specified source file.
2409 
2410       Len : Integer;
2411       --  Length of source file text (ALI). If it doesn't fit in an integer
2412       --  we're probably stuck anyway (>2 gigs of source seems a lot, and
2413       --  there are other places in the compiler that make this assumption).
2414 
2415       Text : Text_Buffer_Ptr;
2416       --  Allocated text buffer
2417 
2418       Status : Boolean;
2419       pragma Warnings (Off, Status);
2420       --  For the calls to Close
2421 
2422    begin
2423       Current_Full_Lib_Name := Full_Lib_File;
2424       Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name);
2425 
2426       if Current_Full_Lib_Name = No_File then
2427          if Fatal_Err then
2428             Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
2429          else
2430             Current_Full_Obj_Stamp := Empty_Time_Stamp;
2431             return null;
2432          end if;
2433       end if;
2434 
2435       Get_Name_String (Current_Full_Lib_Name);
2436       Name_Buffer (Name_Len + 1) := ASCII.NUL;
2437 
2438       --  Open the library FD, note that we open in binary mode, because as
2439       --  documented in the spec, the caller is expected to handle either
2440       --  DOS or Unix mode files, and there is no point in wasting time on
2441       --  text translation when it is not required.
2442 
2443       Lib_FD := Open_Read (Name_Buffer'Address, Binary);
2444 
2445       if Lib_FD = Invalid_FD then
2446          if Fatal_Err then
2447             Fail ("Cannot open: " & Name_Buffer (1 .. Name_Len));
2448          else
2449             Current_Full_Obj_Stamp := Empty_Time_Stamp;
2450             return null;
2451          end if;
2452       end if;
2453 
2454       --  Compute the length of the file (potentially also preparing other data
2455       --  like the timestamp and whether the file is read-only, for future use)
2456 
2457       Len := Integer (File_Length (Name_Buffer'Address, Lib_File_Attr));
2458 
2459       --  Check for object file consistency if requested
2460 
2461       if Opt.Check_Object_Consistency then
2462          --  On most systems, this does not result in an extra system call
2463 
2464          Current_Full_Lib_Stamp :=
2465            OS_Time_To_GNAT_Time
2466              (File_Time_Stamp (Name_Buffer'Address, Lib_File_Attr));
2467 
2468          --  ??? One system call here
2469 
2470          Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name);
2471 
2472          if Current_Full_Obj_Stamp (1) = ' ' then
2473 
2474             --  When the library is readonly always assume object is consistent
2475             --  The call to Is_Writable_File only results in a system call on
2476             --  some systems, but in most cases it has already been computed as
2477             --  part of the call to File_Length above.
2478 
2479             Get_Name_String (Current_Full_Lib_Name);
2480             Name_Buffer (Name_Len + 1) := ASCII.NUL;
2481 
2482             if not Is_Writable_File (Name_Buffer'Address, Lib_File_Attr) then
2483                Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
2484 
2485             elsif Fatal_Err then
2486                Get_Name_String (Current_Full_Obj_Name);
2487                Close (Lib_FD, Status);
2488 
2489                --  No need to check the status, we fail anyway
2490 
2491                Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
2492 
2493             else
2494                Current_Full_Obj_Stamp := Empty_Time_Stamp;
2495                Close (Lib_FD, Status);
2496 
2497                --  No need to check the status, we return null anyway
2498 
2499                return null;
2500             end if;
2501 
2502          elsif Current_Full_Obj_Stamp < Current_Full_Lib_Stamp then
2503             Close (Lib_FD, Status);
2504 
2505             --  No need to check the status, we return null anyway
2506 
2507             return null;
2508          end if;
2509       end if;
2510 
2511       --  Read data from the file
2512 
2513       declare
2514          Actual_Len : Integer := 0;
2515 
2516          Lo : constant Text_Ptr := 0;
2517          --  Low bound for allocated text buffer
2518 
2519          Hi : Text_Ptr := Text_Ptr (Len);
2520          --  High bound for allocated text buffer. Note length is Len + 1
2521          --  which allows for extra EOF character at the end of the buffer.
2522 
2523       begin
2524          --  Allocate text buffer. Note extra character at end for EOF
2525 
2526          Text := new Text_Buffer (Lo .. Hi);
2527 
2528          --  Some systems have file types that require one read per line,
2529          --  so read until we get the Len bytes or until there are no more
2530          --  characters.
2531 
2532          Hi := Lo;
2533          loop
2534             Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len);
2535             Hi := Hi + Text_Ptr (Actual_Len);
2536             exit when Actual_Len = Len or else Actual_Len <= 0;
2537          end loop;
2538 
2539          Text (Hi) := EOF;
2540       end;
2541 
2542       --  Read is complete, close file and we are done
2543 
2544       Close (Lib_FD, Status);
2545       --  The status should never be False. But, if it is, what can we do?
2546       --  So, we don't test it.
2547 
2548       return Text;
2549 
2550    end Read_Library_Info_From_Full;
2551 
2552    ----------------------
2553    -- Read_Source_File --
2554    ----------------------
2555 
2556    procedure Read_Source_File
2557      (N   : File_Name_Type;
2558       Lo  : Source_Ptr;
2559       Hi  : out Source_Ptr;
2560       Src : out Source_Buffer_Ptr;
2561       T   : File_Type := Source)
2562    is
2563       Source_File_FD : File_Descriptor;
2564       --  The file descriptor for the current source file. A negative value
2565       --  indicates failure to open the specified source file.
2566 
2567       Len : Integer;
2568       --  Length of file, assume no more than 2 gigabytes of source
2569 
2570       Actual_Len : Integer;
2571 
2572       Status : Boolean;
2573       pragma Warnings (Off, Status);
2574       --  For the call to Close
2575 
2576    begin
2577       Current_Full_Source_Name  := Find_File (N, T, Full_Name => True);
2578       Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
2579 
2580       if Current_Full_Source_Name = No_File then
2581 
2582          --  If we were trying to access the main file and we could not find
2583          --  it, we have an error.
2584 
2585          if N = Current_Main then
2586             Get_Name_String (N);
2587             Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
2588          end if;
2589 
2590          Src := null;
2591          Hi  := No_Location;
2592          return;
2593       end if;
2594 
2595       Get_Name_String (Current_Full_Source_Name);
2596       Name_Buffer (Name_Len + 1) := ASCII.NUL;
2597 
2598       --  Open the source FD, note that we open in binary mode, because as
2599       --  documented in the spec, the caller is expected to handle either
2600       --  DOS or Unix mode files, and there is no point in wasting time on
2601       --  text translation when it is not required.
2602 
2603       Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
2604 
2605       if Source_File_FD = Invalid_FD then
2606          Src := null;
2607          Hi  := No_Location;
2608          return;
2609       end if;
2610 
2611       --  If it's a Source file, print out the file name, if requested, and if
2612       --  it's not part of the runtimes, store it in File_Name_Chars. We don't
2613       --  want to print non-Source files, like GNAT-TEMP-000001.TMP used to
2614       --  pass information from gprbuild to gcc. We don't want to save runtime
2615       --  file names, because we don't want users to send them in bug reports.
2616 
2617       if T = Source then
2618          declare
2619             Name : String renames Name_Buffer (1 .. Name_Len);
2620             Inc  : String renames Include_Dir_Default_Prefix.all;
2621 
2622             Part_Of_Runtimes : constant Boolean :=
2623               Inc /= ""
2624                 and then Inc'Length < Name_Len
2625                 and then Name_Buffer (1 .. Inc'Length) = Inc;
2626 
2627          begin
2628             if Debug.Debug_Flag_Dot_N then
2629                Write_Line (Name);
2630             end if;
2631 
2632             if not Part_Of_Runtimes then
2633                File_Name_Chars.Append_All (File_Name_Chars.Table_Type (Name));
2634                File_Name_Chars.Append (ASCII.LF);
2635             end if;
2636          end;
2637       end if;
2638 
2639       --  Prepare to read data from the file
2640 
2641       Len := Integer (File_Length (Source_File_FD));
2642 
2643       --  Set Hi so that length is one more than the physical length,
2644       --  allowing for the extra EOF character at the end of the buffer
2645 
2646       Hi := Lo + Source_Ptr (Len);
2647 
2648       --  Do the actual read operation
2649 
2650       declare
2651          subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
2652          --  Physical buffer allocated
2653 
2654          type Actual_Source_Ptr is access Actual_Source_Buffer;
2655          --  This is the pointer type for the physical buffer allocated
2656 
2657          Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
2658          --  And this is the actual physical buffer
2659 
2660       begin
2661          --  Allocate source buffer, allowing extra character at end for EOF
2662 
2663          --  Some systems have file types that require one read per line,
2664          --  so read until we get the Len bytes or until there are no more
2665          --  characters.
2666 
2667          Hi := Lo;
2668          loop
2669             Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
2670             Hi := Hi + Source_Ptr (Actual_Len);
2671             exit when Actual_Len = Len or else Actual_Len <= 0;
2672          end loop;
2673 
2674          Actual_Ptr (Hi) := EOF;
2675 
2676          --  Now we need to work out the proper virtual origin pointer to
2677          --  return. This is exactly Actual_Ptr (0)'Address, but we have to
2678          --  be careful to suppress checks to compute this address.
2679 
2680          declare
2681             pragma Suppress (All_Checks);
2682 
2683             pragma Warnings (Off);
2684             --  This use of unchecked conversion is aliasing safe
2685 
2686             function To_Source_Buffer_Ptr is new
2687               Unchecked_Conversion (Address, Source_Buffer_Ptr);
2688 
2689             pragma Warnings (On);
2690 
2691          begin
2692             Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
2693          end;
2694       end;
2695 
2696       --  Read is complete, get time stamp and close file and we are done
2697 
2698       Close (Source_File_FD, Status);
2699 
2700       --  The status should never be False. But, if it is, what can we do?
2701       --  So, we don't test it.
2702 
2703    end Read_Source_File;
2704 
2705    -------------------
2706    -- Relocate_Path --
2707    -------------------
2708 
2709    function Relocate_Path
2710      (Prefix : String;
2711       Path   : String) return String_Ptr
2712    is
2713       S : String_Ptr;
2714 
2715       procedure set_std_prefix (S : String; Len : Integer);
2716       pragma Import (C, set_std_prefix);
2717 
2718    begin
2719       if Std_Prefix = null then
2720          Std_Prefix := Executable_Prefix;
2721 
2722          if Std_Prefix.all /= "" then
2723 
2724             --  Remove trailing directory separator when calling set_std_prefix
2725 
2726             set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1);
2727          end if;
2728       end if;
2729 
2730       if Path'Last >= Prefix'Last and then Path (Prefix'Range) = Prefix then
2731          if Std_Prefix.all /= "" then
2732             S := new String
2733               (1 .. Std_Prefix'Length + Path'Last - Prefix'Last);
2734             S (1 .. Std_Prefix'Length) := Std_Prefix.all;
2735             S (Std_Prefix'Length + 1 .. S'Last) :=
2736               Path (Prefix'Last + 1 .. Path'Last);
2737             return S;
2738          end if;
2739       end if;
2740 
2741       return new String'(Path);
2742    end Relocate_Path;
2743 
2744    -----------------
2745    -- Set_Program --
2746    -----------------
2747 
2748    procedure Set_Program (P : Program_Type) is
2749    begin
2750       if Program_Set then
2751          Fail ("Set_Program called twice");
2752       end if;
2753 
2754       Program_Set := True;
2755       Running_Program := P;
2756    end Set_Program;
2757 
2758    ----------------
2759    -- Shared_Lib --
2760    ----------------
2761 
2762    function Shared_Lib (Name : String) return String is
2763       Library : String (1 .. Name'Length + Library_Version'Length + 3);
2764       --  3 = 2 for "-l" + 1 for "-" before lib version
2765 
2766    begin
2767       Library (1 .. 2)                          := "-l";
2768       Library (3 .. 2 + Name'Length)            := Name;
2769       Library (3 + Name'Length)                 := '-';
2770       Library (4 + Name'Length .. Library'Last) := Library_Version;
2771       return Library;
2772    end Shared_Lib;
2773 
2774    ----------------------
2775    -- Smart_File_Stamp --
2776    ----------------------
2777 
2778    function Smart_File_Stamp
2779      (N : File_Name_Type;
2780       T : File_Type) return Time_Stamp_Type
2781    is
2782       File : File_Name_Type;
2783       Attr : aliased File_Attributes;
2784 
2785    begin
2786       if not File_Cache_Enabled then
2787          Find_File (N, T, File, Attr'Access);
2788       else
2789          Smart_Find_File (N, T, File, Attr);
2790       end if;
2791 
2792       if File = No_File then
2793          return Empty_Time_Stamp;
2794       else
2795          Get_Name_String (File);
2796          Name_Buffer (Name_Len + 1) := ASCII.NUL;
2797          return
2798            OS_Time_To_GNAT_Time
2799              (File_Time_Stamp (Name_Buffer'Address, Attr'Access));
2800       end if;
2801    end Smart_File_Stamp;
2802 
2803    ---------------------
2804    -- Smart_Find_File --
2805    ---------------------
2806 
2807    function Smart_Find_File
2808      (N : File_Name_Type;
2809       T : File_Type) return File_Name_Type
2810    is
2811       File : File_Name_Type;
2812       Attr : File_Attributes;
2813    begin
2814       Smart_Find_File (N, T, File, Attr);
2815       return File;
2816    end Smart_Find_File;
2817 
2818    ---------------------
2819    -- Smart_Find_File --
2820    ---------------------
2821 
2822    procedure Smart_Find_File
2823      (N     : File_Name_Type;
2824       T     : File_Type;
2825       Found : out File_Name_Type;
2826       Attr  : out File_Attributes)
2827    is
2828       Info : File_Info_Cache;
2829 
2830    begin
2831       if not File_Cache_Enabled then
2832          Find_File (N, T, Info.File, Info.Attr'Access);
2833 
2834       else
2835          Info := File_Name_Hash_Table.Get (N);
2836 
2837          if Info.File = No_File then
2838             Find_File (N, T, Info.File, Info.Attr'Access);
2839             File_Name_Hash_Table.Set (N, Info);
2840          end if;
2841       end if;
2842 
2843       Found := Info.File;
2844       Attr  := Info.Attr;
2845    end Smart_Find_File;
2846 
2847    ----------------------
2848    -- Source_File_Data --
2849    ----------------------
2850 
2851    procedure Source_File_Data (Cache : Boolean) is
2852    begin
2853       File_Cache_Enabled := Cache;
2854    end Source_File_Data;
2855 
2856    -----------------------
2857    -- Source_File_Stamp --
2858    -----------------------
2859 
2860    function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
2861    begin
2862       return Smart_File_Stamp (N, Source);
2863    end Source_File_Stamp;
2864 
2865    ---------------------
2866    -- Strip_Directory --
2867    ---------------------
2868 
2869    function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
2870    begin
2871       Get_Name_String (Name);
2872 
2873       for J in reverse 1 .. Name_Len - 1 loop
2874 
2875          --  If we find the last directory separator
2876 
2877          if Is_Directory_Separator (Name_Buffer (J)) then
2878 
2879             --  Return part of Name that follows this last directory separator
2880 
2881             Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
2882             Name_Len := Name_Len - J;
2883             return Name_Find;
2884          end if;
2885       end loop;
2886 
2887       --  There were no directory separator, just return Name
2888 
2889       return Name;
2890    end Strip_Directory;
2891 
2892    ------------------
2893    -- Strip_Suffix --
2894    ------------------
2895 
2896    function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
2897    begin
2898       Get_Name_String (Name);
2899 
2900       for J in reverse 2 .. Name_Len loop
2901 
2902          --  If we found the last '.', return part of Name that precedes it
2903 
2904          if Name_Buffer (J) = '.' then
2905             Name_Len := J - 1;
2906             return Name_Enter;
2907          end if;
2908       end loop;
2909 
2910       return Name;
2911    end Strip_Suffix;
2912 
2913    ---------------------------
2914    -- To_Canonical_Dir_Spec --
2915    ---------------------------
2916 
2917    function To_Canonical_Dir_Spec
2918      (Host_Dir     : String;
2919       Prefix_Style : Boolean) return String_Access
2920    is
2921       function To_Canonical_Dir_Spec
2922         (Host_Dir    : Address;
2923          Prefix_Flag : Integer) return Address;
2924       pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
2925 
2926       C_Host_Dir         : String (1 .. Host_Dir'Length + 1);
2927       Canonical_Dir_Addr : Address;
2928       Canonical_Dir_Len  : CRTL.size_t;
2929 
2930    begin
2931       C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir;
2932       C_Host_Dir (C_Host_Dir'Last)      := ASCII.NUL;
2933 
2934       if Prefix_Style then
2935          Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1);
2936       else
2937          Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
2938       end if;
2939 
2940       Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);
2941 
2942       if Canonical_Dir_Len = 0 then
2943          return null;
2944       else
2945          return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len);
2946       end if;
2947 
2948    exception
2949       when others =>
2950          Fail ("invalid directory spec: " & Host_Dir);
2951          return null;
2952    end To_Canonical_Dir_Spec;
2953 
2954    ---------------------------
2955    -- To_Canonical_File_List --
2956    ---------------------------
2957 
2958    function To_Canonical_File_List
2959      (Wildcard_Host_File : String;
2960       Only_Dirs          : Boolean) return String_Access_List_Access
2961    is
2962       function To_Canonical_File_List_Init
2963         (Host_File : Address;
2964          Only_Dirs : Integer) return Integer;
2965       pragma Import (C, To_Canonical_File_List_Init,
2966                      "__gnat_to_canonical_file_list_init");
2967 
2968       function To_Canonical_File_List_Next return Address;
2969       pragma Import (C, To_Canonical_File_List_Next,
2970                      "__gnat_to_canonical_file_list_next");
2971 
2972       procedure To_Canonical_File_List_Free;
2973       pragma Import (C, To_Canonical_File_List_Free,
2974                      "__gnat_to_canonical_file_list_free");
2975 
2976       Num_Files            : Integer;
2977       C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
2978 
2979    begin
2980       C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
2981         Wildcard_Host_File;
2982       C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
2983 
2984       --  Do the expansion and say how many there are
2985 
2986       Num_Files := To_Canonical_File_List_Init
2987          (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
2988 
2989       declare
2990          Canonical_File_List : String_Access_List (1 .. Num_Files);
2991          Canonical_File_Addr : Address;
2992          Canonical_File_Len  : CRTL.size_t;
2993 
2994       begin
2995          --  Retrieve the expanded directory names and build the list
2996 
2997          for J in 1 .. Num_Files loop
2998             Canonical_File_Addr := To_Canonical_File_List_Next;
2999             Canonical_File_Len  := C_String_Length (Canonical_File_Addr);
3000             Canonical_File_List (J) := To_Path_String_Access
3001                   (Canonical_File_Addr, Canonical_File_Len);
3002          end loop;
3003 
3004          --  Free up the storage
3005 
3006          To_Canonical_File_List_Free;
3007 
3008          return new String_Access_List'(Canonical_File_List);
3009       end;
3010    end To_Canonical_File_List;
3011 
3012    ----------------------------
3013    -- To_Canonical_File_Spec --
3014    ----------------------------
3015 
3016    function To_Canonical_File_Spec
3017      (Host_File : String) return String_Access
3018    is
3019       function To_Canonical_File_Spec (Host_File : Address) return Address;
3020       pragma Import
3021         (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
3022 
3023       C_Host_File         : String (1 .. Host_File'Length + 1);
3024       Canonical_File_Addr : Address;
3025       Canonical_File_Len  : CRTL.size_t;
3026 
3027    begin
3028       C_Host_File (1 .. Host_File'Length) := Host_File;
3029       C_Host_File (C_Host_File'Last)      := ASCII.NUL;
3030 
3031       Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address);
3032       Canonical_File_Len  := C_String_Length (Canonical_File_Addr);
3033 
3034       if Canonical_File_Len = 0 then
3035          return null;
3036       else
3037          return To_Path_String_Access
3038                   (Canonical_File_Addr, Canonical_File_Len);
3039       end if;
3040 
3041    exception
3042       when others =>
3043          Fail ("invalid file spec: " & Host_File);
3044          return null;
3045    end To_Canonical_File_Spec;
3046 
3047    ----------------------------
3048    -- To_Canonical_Path_Spec --
3049    ----------------------------
3050 
3051    function To_Canonical_Path_Spec
3052      (Host_Path : String) return String_Access
3053    is
3054       function To_Canonical_Path_Spec (Host_Path : Address) return Address;
3055       pragma Import
3056         (C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec");
3057 
3058       C_Host_Path         : String (1 .. Host_Path'Length + 1);
3059       Canonical_Path_Addr : Address;
3060       Canonical_Path_Len  : CRTL.size_t;
3061 
3062    begin
3063       C_Host_Path (1 .. Host_Path'Length) := Host_Path;
3064       C_Host_Path (C_Host_Path'Last)      := ASCII.NUL;
3065 
3066       Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address);
3067       Canonical_Path_Len  := C_String_Length (Canonical_Path_Addr);
3068 
3069       --  Return a null string (vice a null) for zero length paths, for
3070       --  compatibility with getenv().
3071 
3072       return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len);
3073 
3074    exception
3075       when others =>
3076          Fail ("invalid path spec: " & Host_Path);
3077          return null;
3078    end To_Canonical_Path_Spec;
3079 
3080    ----------------------
3081    -- To_Host_Dir_Spec --
3082    ----------------------
3083 
3084    function To_Host_Dir_Spec
3085      (Canonical_Dir : String;
3086       Prefix_Style  : Boolean) return String_Access
3087    is
3088       function To_Host_Dir_Spec
3089         (Canonical_Dir : Address;
3090          Prefix_Flag   : Integer) return Address;
3091       pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
3092 
3093       C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
3094       Host_Dir_Addr   : Address;
3095       Host_Dir_Len    : CRTL.size_t;
3096 
3097    begin
3098       C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir;
3099       C_Canonical_Dir (C_Canonical_Dir'Last)      := ASCII.NUL;
3100 
3101       if Prefix_Style then
3102          Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1);
3103       else
3104          Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0);
3105       end if;
3106       Host_Dir_Len := C_String_Length (Host_Dir_Addr);
3107 
3108       if Host_Dir_Len = 0 then
3109          return null;
3110       else
3111          return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len);
3112       end if;
3113    end To_Host_Dir_Spec;
3114 
3115    -----------------------
3116    -- To_Host_File_Spec --
3117    -----------------------
3118 
3119    function To_Host_File_Spec
3120      (Canonical_File : String) return String_Access
3121    is
3122       function To_Host_File_Spec (Canonical_File : Address) return Address;
3123       pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
3124 
3125       C_Canonical_File      : String (1 .. Canonical_File'Length + 1);
3126       Host_File_Addr : Address;
3127       Host_File_Len  : CRTL.size_t;
3128 
3129    begin
3130       C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File;
3131       C_Canonical_File (C_Canonical_File'Last)      := ASCII.NUL;
3132 
3133       Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address);
3134       Host_File_Len  := C_String_Length (Host_File_Addr);
3135 
3136       if Host_File_Len = 0 then
3137          return null;
3138       else
3139          return To_Path_String_Access
3140                   (Host_File_Addr, Host_File_Len);
3141       end if;
3142    end To_Host_File_Spec;
3143 
3144    ---------------------------
3145    -- To_Path_String_Access --
3146    ---------------------------
3147 
3148    function To_Path_String_Access
3149      (Path_Addr : Address;
3150       Path_Len  : CRTL.size_t) return String_Access
3151    is
3152       subtype Path_String is String (1 .. Integer (Path_Len));
3153       type Path_String_Access is access Path_String;
3154 
3155       function Address_To_Access is new
3156         Unchecked_Conversion (Source => Address,
3157                               Target => Path_String_Access);
3158 
3159       Path_Access : constant Path_String_Access :=
3160                       Address_To_Access (Path_Addr);
3161 
3162       Return_Val : String_Access;
3163 
3164    begin
3165       Return_Val := new String (1 .. Integer (Path_Len));
3166 
3167       for J in 1 .. Integer (Path_Len) loop
3168          Return_Val (J) := Path_Access (J);
3169       end loop;
3170 
3171       return Return_Val;
3172    end To_Path_String_Access;
3173 
3174    -----------------
3175    -- Update_Path --
3176    -----------------
3177 
3178    function Update_Path (Path : String_Ptr) return String_Ptr is
3179 
3180       function C_Update_Path (Path, Component : Address) return Address;
3181       pragma Import (C, C_Update_Path, "update_path");
3182 
3183       In_Length      : constant Integer := Path'Length;
3184       In_String      : String (1 .. In_Length + 1);
3185       Component_Name : aliased String := "GCC" & ASCII.NUL;
3186       Result_Ptr     : Address;
3187       Result_Length  : CRTL.size_t;
3188       Out_String     : String_Ptr;
3189 
3190    begin
3191       In_String (1 .. In_Length) := Path.all;
3192       In_String (In_Length + 1) := ASCII.NUL;
3193       Result_Ptr := C_Update_Path (In_String'Address, Component_Name'Address);
3194       Result_Length := CRTL.strlen (Result_Ptr);
3195 
3196       Out_String := new String (1 .. Integer (Result_Length));
3197       CRTL.strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
3198       return Out_String;
3199    end Update_Path;
3200 
3201    ----------------
3202    -- Write_Info --
3203    ----------------
3204 
3205    procedure Write_Info (Info : String) is
3206    begin
3207       Write_With_Check (Info'Address, Info'Length);
3208       Write_With_Check (EOL'Address, 1);
3209    end Write_Info;
3210 
3211    ------------------------
3212    -- Write_Program_Name --
3213    ------------------------
3214 
3215    procedure Write_Program_Name is
3216       Save_Buffer : constant String (1 .. Name_Len) :=
3217                       Name_Buffer (1 .. Name_Len);
3218 
3219    begin
3220       Find_Program_Name;
3221 
3222       --  Convert the name to lower case so error messages are the same on
3223       --  all systems.
3224 
3225       for J in 1 .. Name_Len loop
3226          if Name_Buffer (J) in 'A' .. 'Z' then
3227             Name_Buffer (J) :=
3228               Character'Val (Character'Pos (Name_Buffer (J)) + 32);
3229          end if;
3230       end loop;
3231 
3232       Write_Str (Name_Buffer (1 .. Name_Len));
3233 
3234       --  Restore Name_Buffer which was clobbered by the call to
3235       --  Find_Program_Name
3236 
3237       Name_Len := Save_Buffer'Last;
3238       Name_Buffer (1 .. Name_Len) := Save_Buffer;
3239    end Write_Program_Name;
3240 
3241    ----------------------
3242    -- Write_With_Check --
3243    ----------------------
3244 
3245    procedure Write_With_Check (A  : Address; N  : Integer) is
3246       Ignore : Boolean;
3247    begin
3248       if N = Write (Output_FD, A, N) then
3249          return;
3250       else
3251          Write_Str ("error: disk full writing ");
3252          Write_Name_Decoded (Output_File_Name);
3253          Write_Eol;
3254          Name_Len := Name_Len + 1;
3255          Name_Buffer (Name_Len) := ASCII.NUL;
3256          Delete_File (Name_Buffer'Address, Ignore);
3257          Exit_Program (E_Fatal);
3258       end if;
3259    end Write_With_Check;
3260 
3261 ----------------------------
3262 -- Package Initialization --
3263 ----------------------------
3264 
3265    procedure Reset_File_Attributes (Attr : System.Address);
3266    pragma Import (C, Reset_File_Attributes, "__gnat_reset_attributes");
3267 
3268 begin
3269    Initialization : declare
3270 
3271       function Get_Default_Identifier_Character_Set return Character;
3272       pragma Import (C, Get_Default_Identifier_Character_Set,
3273                        "__gnat_get_default_identifier_character_set");
3274       --  Function to determine the default identifier character set,
3275       --  which is system dependent. See Opt package spec for a list of
3276       --  the possible character codes and their interpretations.
3277 
3278       function Get_Maximum_File_Name_Length return Int;
3279       pragma Import (C, Get_Maximum_File_Name_Length,
3280                     "__gnat_get_maximum_file_name_length");
3281       --  Function to get maximum file name length for system
3282 
3283       Sizeof_File_Attributes : Integer;
3284       pragma Import (C, Sizeof_File_Attributes,
3285                      "__gnat_size_of_file_attributes");
3286 
3287    begin
3288       pragma Assert (Sizeof_File_Attributes <= File_Attributes_Size);
3289 
3290       Reset_File_Attributes (Unknown_Attributes'Address);
3291 
3292       Identifier_Character_Set := Get_Default_Identifier_Character_Set;
3293       Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
3294 
3295       --  Following should be removed by having above function return
3296       --  Integer'Last as indication of no maximum instead of -1 ???
3297 
3298       if Maximum_File_Name_Length = -1 then
3299          Maximum_File_Name_Length := Int'Last;
3300       end if;
3301 
3302       Src_Search_Directories.Set_Last (Primary_Directory);
3303       Src_Search_Directories.Table (Primary_Directory) := new String'("");
3304 
3305       Lib_Search_Directories.Set_Last (Primary_Directory);
3306       Lib_Search_Directories.Table (Primary_Directory) := new String'("");
3307 
3308       Osint.Initialize;
3309    end Initialization;
3310 
3311 end Osint;