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