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