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