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