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    -- Library_File_Stamp --
1534    ------------------------
1535
1536    function Library_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
1537    begin
1538       return File_Stamp (Find_File (N, Library));
1539    end Library_File_Stamp;
1540
1541    -----------------
1542    -- Locate_File --
1543    -----------------
1544
1545    function Locate_File
1546      (N    : File_Name_Type;
1547       T    : File_Type;
1548       Dir  : Natural;
1549       Name : String) return File_Name_Type
1550    is
1551       Dir_Name : String_Ptr;
1552
1553    begin
1554       --  If Name is already an absolute path, do not look for a directory
1555
1556       if Is_Absolute_Path (Name) then
1557          Dir_Name := No_Dir;
1558
1559       elsif T = Library then
1560          Dir_Name := Lib_Search_Directories.Table (Dir);
1561
1562       else pragma Assert (T /= Config);
1563          Dir_Name := Src_Search_Directories.Table (Dir);
1564       end if;
1565
1566       declare
1567          Full_Name : String (1 .. Dir_Name'Length + Name'Length);
1568
1569       begin
1570          Full_Name (1 .. Dir_Name'Length) := Dir_Name.all;
1571          Full_Name (Dir_Name'Length + 1 .. Full_Name'Length) := Name;
1572
1573          if not Is_Regular_File (Full_Name) then
1574             return No_File;
1575
1576          else
1577             --  If the file is in the current directory then return N itself
1578
1579             if Dir_Name'Length = 0 then
1580                return N;
1581             else
1582                Name_Len := Full_Name'Length;
1583                Name_Buffer (1 .. Name_Len) := Full_Name;
1584                return Name_Enter;
1585             end if;
1586          end if;
1587       end;
1588    end Locate_File;
1589
1590    -------------------------------
1591    -- Matching_Full_Source_Name --
1592    -------------------------------
1593
1594    function Matching_Full_Source_Name
1595      (N : File_Name_Type;
1596       T : Time_Stamp_Type) return File_Name_Type
1597    is
1598    begin
1599       Get_Name_String (N);
1600
1601       declare
1602          File_Name : constant String := Name_Buffer (1 .. Name_Len);
1603          File      : File_Name_Type := No_File;
1604          Last_Dir  : Natural;
1605
1606       begin
1607          if Opt.Look_In_Primary_Dir then
1608             File := Locate_File (N, Source, Primary_Directory, File_Name);
1609
1610             if File /= No_File and then T = File_Stamp (N) then
1611                return File;
1612             end if;
1613          end if;
1614
1615          Last_Dir := Src_Search_Directories.Last;
1616
1617          for D in Primary_Directory + 1 .. Last_Dir loop
1618             File := Locate_File (N, Source, D, File_Name);
1619
1620             if File /= No_File and then T = File_Stamp (File) then
1621                return File;
1622             end if;
1623          end loop;
1624
1625          return No_File;
1626       end;
1627    end Matching_Full_Source_Name;
1628
1629    ----------------
1630    -- More_Files --
1631    ----------------
1632
1633    function More_Files return Boolean is
1634    begin
1635       return (Current_File_Name_Index < Number_File_Names);
1636    end More_Files;
1637
1638    -------------------------------
1639    -- Nb_Dir_In_Obj_Search_Path --
1640    -------------------------------
1641
1642    function Nb_Dir_In_Obj_Search_Path return Natural is
1643    begin
1644       if Opt.Look_In_Primary_Dir then
1645          return Lib_Search_Directories.Last -  Primary_Directory + 1;
1646       else
1647          return Lib_Search_Directories.Last -  Primary_Directory;
1648       end if;
1649    end Nb_Dir_In_Obj_Search_Path;
1650
1651    -------------------------------
1652    -- Nb_Dir_In_Src_Search_Path --
1653    -------------------------------
1654
1655    function Nb_Dir_In_Src_Search_Path return Natural is
1656    begin
1657       if Opt.Look_In_Primary_Dir then
1658          return Src_Search_Directories.Last -  Primary_Directory + 1;
1659       else
1660          return Src_Search_Directories.Last -  Primary_Directory;
1661       end if;
1662    end Nb_Dir_In_Src_Search_Path;
1663
1664    --------------------
1665    -- Next_Main_File --
1666    --------------------
1667
1668    function Next_Main_File return File_Name_Type is
1669       File_Name : String_Ptr;
1670       Dir_Name  : String_Ptr;
1671       Fptr      : Natural;
1672
1673    begin
1674       pragma Assert (More_Files);
1675
1676       Current_File_Name_Index := Current_File_Name_Index + 1;
1677
1678       --  Get the file and directory name
1679
1680       File_Name := File_Names (Current_File_Name_Index);
1681       Fptr := File_Name'First;
1682
1683       for J in reverse File_Name'Range loop
1684          if File_Name (J) = Directory_Separator
1685            or else File_Name (J) = '/'
1686          then
1687             if J = File_Name'Last then
1688                Fail ("File name missing");
1689             end if;
1690
1691             Fptr := J + 1;
1692             exit;
1693          end if;
1694       end loop;
1695
1696       --  Save name of directory in which main unit resides for use in
1697       --  locating other units
1698
1699       Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1));
1700
1701       case Running_Program is
1702
1703          when Compiler =>
1704             Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1705             Look_In_Primary_Directory_For_Current_Main := True;
1706
1707          when Make =>
1708             Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1709
1710             if Fptr > File_Name'First then
1711                Look_In_Primary_Directory_For_Current_Main := True;
1712             end if;
1713
1714          when Binder | Gnatls =>
1715             Dir_Name := Normalize_Directory_Name (Dir_Name.all);
1716             Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
1717
1718          when Unspecified =>
1719             null;
1720       end case;
1721
1722       Name_Len := File_Name'Last - Fptr + 1;
1723       Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
1724       Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1725       Current_Main := Name_Find;
1726
1727       --  In the gnatmake case, the main file may have not have the
1728       --  extension. Try ".adb" first then ".ads"
1729
1730       if Running_Program = Make then
1731          declare
1732             Orig_Main : constant File_Name_Type := Current_Main;
1733
1734          begin
1735             if Strip_Suffix (Orig_Main) = Orig_Main then
1736                Current_Main :=
1737                  Append_Suffix_To_File_Name (Orig_Main, ".adb");
1738
1739                if Full_Source_Name (Current_Main) = No_File then
1740                   Current_Main :=
1741                     Append_Suffix_To_File_Name (Orig_Main, ".ads");
1742
1743                   if Full_Source_Name (Current_Main) = No_File then
1744                      Current_Main := Orig_Main;
1745                   end if;
1746                end if;
1747             end if;
1748          end;
1749       end if;
1750
1751       return Current_Main;
1752    end Next_Main_File;
1753
1754    ------------------------------
1755    -- Normalize_Directory_Name --
1756    ------------------------------
1757
1758    function Normalize_Directory_Name (Directory : String) return String_Ptr is
1759
1760       function Is_Quoted (Path : String) return Boolean;
1761       pragma Inline (Is_Quoted);
1762       --  Returns true if Path is quoted (either double or single quotes)
1763
1764       ---------------
1765       -- Is_Quoted --
1766       ---------------
1767
1768       function Is_Quoted (Path : String) return Boolean is
1769          First : constant Character := Path (Path'First);
1770          Last  : constant Character := Path (Path'Last);
1771
1772       begin
1773          if (First = ''' and then Last = ''')
1774                or else
1775             (First = '"' and then Last = '"')
1776          then
1777             return True;
1778          else
1779             return False;
1780          end if;
1781       end Is_Quoted;
1782
1783       Result : String_Ptr;
1784
1785    --  Start of processing for Normalize_Directory_Name
1786
1787    begin
1788       if Directory'Length = 0 then
1789          Result := new String'(Hostparm.Normalized_CWD);
1790
1791       elsif Is_Directory_Separator (Directory (Directory'Last)) then
1792          Result := new String'(Directory);
1793
1794       elsif Is_Quoted (Directory) then
1795
1796          --  This is a quoted string, it certainly means that the directory
1797          --  contains some spaces for example. We can safely remove the quotes
1798          --  here as the OS_Lib.Normalize_Arguments will be called before any
1799          --  spawn routines. This ensure that quotes will be added when needed.
1800
1801          Result := new String (1 .. Directory'Length - 1);
1802          Result (1 .. Directory'Length - 2) :=
1803            Directory (Directory'First + 1 .. Directory'Last - 1);
1804          Result (Result'Last) := Directory_Separator;
1805
1806       else
1807          Result := new String (1 .. Directory'Length + 1);
1808          Result (1 .. Directory'Length) := Directory;
1809          Result (Directory'Length + 1) := Directory_Separator;
1810       end if;
1811
1812       return Result;
1813    end Normalize_Directory_Name;
1814
1815    ---------------------
1816    -- Number_Of_Files --
1817    ---------------------
1818
1819    function Number_Of_Files return Int is
1820    begin
1821       return Number_File_Names;
1822    end Number_Of_Files;
1823
1824    -------------------------------
1825    -- Object_Dir_Default_Prefix --
1826    -------------------------------
1827
1828    function Object_Dir_Default_Prefix return String is
1829       Object_Dir : String_Access :=
1830                      String_Access (Update_Path (Object_Dir_Default_Name));
1831
1832    begin
1833       if Object_Dir = null then
1834          return "";
1835
1836       else
1837          declare
1838             Result : constant String := Object_Dir.all;
1839          begin
1840             Free (Object_Dir);
1841             return Result;
1842          end;
1843       end if;
1844    end Object_Dir_Default_Prefix;
1845
1846    ----------------------
1847    -- Object_File_Name --
1848    ----------------------
1849
1850    function Object_File_Name (N : File_Name_Type) return File_Name_Type is
1851    begin
1852       if N = No_File then
1853          return No_File;
1854       end if;
1855
1856       Get_Name_String (N);
1857       Name_Len := Name_Len - ALI_Suffix'Length - 1;
1858
1859       for J in Target_Object_Suffix'Range loop
1860          Name_Len := Name_Len + 1;
1861          Name_Buffer (Name_Len) := Target_Object_Suffix (J);
1862       end loop;
1863
1864       return Name_Enter;
1865    end Object_File_Name;
1866
1867    -------------------------------
1868    -- OS_Exit_Through_Exception --
1869    -------------------------------
1870
1871    procedure OS_Exit_Through_Exception (Status : Integer) is
1872    begin
1873       Current_Exit_Status := Status;
1874       raise Types.Terminate_Program;
1875    end OS_Exit_Through_Exception;
1876
1877    --------------------------
1878    -- OS_Time_To_GNAT_Time --
1879    --------------------------
1880
1881    function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
1882       GNAT_Time : Time_Stamp_Type;
1883
1884       Y  : Year_Type;
1885       Mo : Month_Type;
1886       D  : Day_Type;
1887       H  : Hour_Type;
1888       Mn : Minute_Type;
1889       S  : Second_Type;
1890
1891    begin
1892       if T = Invalid_Time then
1893          return Empty_Time_Stamp;
1894       end if;
1895
1896       GM_Split (T, Y, Mo, D, H, Mn, S);
1897       Make_Time_Stamp
1898         (Year    => Nat (Y),
1899          Month   => Nat (Mo),
1900          Day     => Nat (D),
1901          Hour    => Nat (H),
1902          Minutes => Nat (Mn),
1903          Seconds => Nat (S),
1904          TS      => GNAT_Time);
1905
1906       return GNAT_Time;
1907    end OS_Time_To_GNAT_Time;
1908
1909    ------------------
1910    -- Program_Name --
1911    ------------------
1912
1913    function Program_Name (Nam : String; Prog : String) return String_Access is
1914       End_Of_Prefix   : Natural := 0;
1915       Start_Of_Prefix : Positive := 1;
1916       Start_Of_Suffix : Positive;
1917
1918    begin
1919       --  GNAAMP tool names require special treatment
1920
1921       if AAMP_On_Target then
1922
1923          --  The name "gcc" is mapped to "gnaamp" (the compiler driver)
1924
1925          if Nam = "gcc" then
1926             return new String'("gnaamp");
1927
1928          --  Tool names starting with "gnat" are mapped by substituting the
1929          --  string "gnaamp" for "gnat" (for example, "gnatpp" => "gnaamppp").
1930
1931          elsif Nam'Length >= 4
1932            and then Nam (Nam'First .. Nam'First + 3) = "gnat"
1933          then
1934             return new String'("gnaamp" & Nam (Nam'First + 4 .. Nam'Last));
1935
1936          --  No other mapping rules, so we continue and handle any other forms
1937          --  of tool names the same as on other targets.
1938
1939          else
1940             null;
1941          end if;
1942       end if;
1943
1944       --  Get the name of the current program being executed
1945
1946       Find_Program_Name;
1947
1948       Start_Of_Suffix := Name_Len + 1;
1949
1950       --  Find the target prefix if any, for the cross compilation case.
1951       --  For instance in "powerpc-elf-gcc" the target prefix is
1952       --  "powerpc-elf-"
1953       --  Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1"
1954
1955       for J in reverse 1 .. Name_Len loop
1956          if Name_Buffer (J) = '/'
1957            or else Name_Buffer (J) = Directory_Separator
1958            or else Name_Buffer (J) = ':'
1959          then
1960             Start_Of_Prefix := J + 1;
1961             exit;
1962          end if;
1963       end loop;
1964
1965       --  Find End_Of_Prefix
1966
1967       for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop
1968          if Name_Buffer (J .. J + Prog'Length - 1) = Prog then
1969             End_Of_Prefix := J - 1;
1970             exit;
1971          end if;
1972       end loop;
1973
1974       if End_Of_Prefix > 1 then
1975          Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1;
1976       end if;
1977
1978       --  Create the new program name
1979
1980       return new String'
1981         (Name_Buffer (Start_Of_Prefix .. End_Of_Prefix)
1982          & Nam
1983          & Name_Buffer (Start_Of_Suffix .. Name_Len));
1984    end Program_Name;
1985
1986    ------------------------------
1987    -- Read_Default_Search_Dirs --
1988    ------------------------------
1989
1990    function Read_Default_Search_Dirs
1991      (Search_Dir_Prefix       : String_Access;
1992       Search_File             : String_Access;
1993       Search_Dir_Default_Name : String_Access) return String_Access
1994    is
1995       Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
1996       Buffer     : String (1 .. Prefix_Len + Search_File.all'Length + 1);
1997       File_FD    : File_Descriptor;
1998       S, S1      : String_Access;
1999       Len        : Integer;
2000       Curr       : Integer;
2001       Actual_Len : Integer;
2002       J1         : Integer;
2003
2004       Prev_Was_Separator : Boolean;
2005       Nb_Relative_Dir    : Integer;
2006
2007       function Is_Relative (S : String; K : Positive) return Boolean;
2008       pragma Inline (Is_Relative);
2009       --  Returns True if a relative directory specification is found
2010       --  in S at position K, False otherwise.
2011
2012       -----------------
2013       -- Is_Relative --
2014       -----------------
2015
2016       function Is_Relative (S : String; K : Positive) return Boolean is
2017       begin
2018          return not Is_Absolute_Path (S (K .. S'Last));
2019       end Is_Relative;
2020
2021    --  Start of processing for Read_Default_Search_Dirs
2022
2023    begin
2024       --  Construct a C compatible character string buffer
2025
2026       Buffer (1 .. Search_Dir_Prefix.all'Length)
2027         := Search_Dir_Prefix.all;
2028       Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1)
2029         := Search_File.all;
2030       Buffer (Buffer'Last) := ASCII.NUL;
2031
2032       File_FD := Open_Read (Buffer'Address, Binary);
2033       if File_FD = Invalid_FD then
2034          return Search_Dir_Default_Name;
2035       end if;
2036
2037       Len := Integer (File_Length (File_FD));
2038
2039       --  An extra character for a trailing Path_Separator is allocated
2040
2041       S := new String (1 .. Len + 1);
2042       S (Len + 1) := Path_Separator;
2043
2044       --  Read the file. Note that the loop is not necessary since the
2045       --  whole file is read at once except on VMS.
2046
2047       Curr := 1;
2048       Actual_Len := Len;
2049       while Actual_Len /= 0 loop
2050          Actual_Len := Read (File_FD, S (Curr)'Address, Len);
2051          Curr := Curr + Actual_Len;
2052       end loop;
2053
2054       --  Process the file, dealing with path separators
2055
2056       Prev_Was_Separator := True;
2057       Nb_Relative_Dir := 0;
2058       for J in 1 .. Len loop
2059
2060          --  Treat any control character as a path separator. Note that we do
2061          --  not treat space as a path separator (we used to treat space as a
2062          --  path separator in an earlier version). That way space can appear
2063          --  as a legitimate character in a path name.
2064
2065          --  Why do we treat all control characters as path separators???
2066
2067          if S (J) in ASCII.NUL .. ASCII.US then
2068             S (J) := Path_Separator;
2069          end if;
2070
2071          --  Test for explicit path separator (or control char as above)
2072
2073          if S (J) = Path_Separator then
2074             Prev_Was_Separator := True;
2075
2076          --  If not path separator, register use of relative directory
2077
2078          else
2079             if Prev_Was_Separator and then Is_Relative (S.all, J) then
2080                Nb_Relative_Dir := Nb_Relative_Dir + 1;
2081             end if;
2082
2083             Prev_Was_Separator := False;
2084          end if;
2085       end loop;
2086
2087       if Nb_Relative_Dir = 0 then
2088          return S;
2089       end if;
2090
2091       --  Add the Search_Dir_Prefix to all relative paths
2092
2093       S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len);
2094       J1 := 1;
2095       Prev_Was_Separator := True;
2096       for J in 1 .. Len + 1 loop
2097          if S (J) = Path_Separator then
2098             Prev_Was_Separator := True;
2099
2100          else
2101             if Prev_Was_Separator and then Is_Relative (S.all, J) then
2102                S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all;
2103                J1 := J1 + Prefix_Len;
2104             end if;
2105
2106             Prev_Was_Separator := False;
2107          end if;
2108          S1 (J1) := S (J);
2109          J1 := J1 + 1;
2110       end loop;
2111
2112       Free (S);
2113       return S1;
2114    end Read_Default_Search_Dirs;
2115
2116    -----------------------
2117    -- Read_Library_Info --
2118    -----------------------
2119
2120    function Read_Library_Info
2121      (Lib_File  : File_Name_Type;
2122       Fatal_Err : Boolean := False) return Text_Buffer_Ptr
2123    is
2124       Lib_FD : File_Descriptor;
2125       --  The file descriptor for the current library file. A negative value
2126       --  indicates failure to open the specified source file.
2127
2128       Text : Text_Buffer_Ptr;
2129       --  Allocated text buffer
2130
2131       Status : Boolean;
2132       pragma Warnings (Off, Status);
2133       --  For the calls to Close
2134
2135    begin
2136       Current_Full_Lib_Name := Find_File (Lib_File, Library);
2137       Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name);
2138
2139       if Current_Full_Lib_Name = No_File then
2140          if Fatal_Err then
2141             Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
2142          else
2143             Current_Full_Obj_Stamp := Empty_Time_Stamp;
2144             return null;
2145          end if;
2146       end if;
2147
2148       Get_Name_String (Current_Full_Lib_Name);
2149       Name_Buffer (Name_Len + 1) := ASCII.NUL;
2150
2151       --  Open the library FD, note that we open in binary mode, because as
2152       --  documented in the spec, the caller is expected to handle either
2153       --  DOS or Unix mode files, and there is no point in wasting time on
2154       --  text translation when it is not required.
2155
2156       Lib_FD := Open_Read (Name_Buffer'Address, Binary);
2157
2158       if Lib_FD = Invalid_FD then
2159          if Fatal_Err then
2160             Fail ("Cannot open: " & Name_Buffer (1 .. Name_Len));
2161          else
2162             Current_Full_Obj_Stamp := Empty_Time_Stamp;
2163             return null;
2164          end if;
2165       end if;
2166
2167       --  Check for object file consistency if requested
2168
2169       if Opt.Check_Object_Consistency then
2170          Current_Full_Lib_Stamp := File_Stamp (Current_Full_Lib_Name);
2171          Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name);
2172
2173          if Current_Full_Obj_Stamp (1) = ' ' then
2174
2175             --  When the library is readonly always assume object is consistent
2176
2177             if Is_Readonly_Library (Current_Full_Lib_Name) then
2178                Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
2179
2180             elsif Fatal_Err then
2181                Get_Name_String (Current_Full_Obj_Name);
2182                Close (Lib_FD, Status);
2183
2184                --  No need to check the status, we fail anyway
2185
2186                Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
2187
2188             else
2189                Current_Full_Obj_Stamp := Empty_Time_Stamp;
2190                Close (Lib_FD, Status);
2191
2192                --  No need to check the status, we return null anyway
2193
2194                return null;
2195             end if;
2196          end if;
2197       end if;
2198
2199       --  Read data from the file
2200
2201       declare
2202          Len : constant Integer := Integer (File_Length (Lib_FD));
2203          --  Length of source file text. If it doesn't fit in an integer
2204          --  we're probably stuck anyway (>2 gigs of source seems a lot!)
2205
2206          Actual_Len : Integer := 0;
2207
2208          Lo : constant Text_Ptr := 0;
2209          --  Low bound for allocated text buffer
2210
2211          Hi : Text_Ptr := Text_Ptr (Len);
2212          --  High bound for allocated text buffer. Note length is Len + 1
2213          --  which allows for extra EOF character at the end of the buffer.
2214
2215       begin
2216          --  Allocate text buffer. Note extra character at end for EOF
2217
2218          Text := new Text_Buffer (Lo .. Hi);
2219
2220          --  Some systems (e.g. VMS) have file types that require one
2221          --  read per line, so read until we get the Len bytes or until
2222          --  there are no more characters.
2223
2224          Hi := Lo;
2225          loop
2226             Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len);
2227             Hi := Hi + Text_Ptr (Actual_Len);
2228             exit when Actual_Len = Len or else Actual_Len <= 0;
2229          end loop;
2230
2231          Text (Hi) := EOF;
2232       end;
2233
2234       --  Read is complete, close file and we are done
2235
2236       Close (Lib_FD, Status);
2237       --  The status should never be False. But, if it is, what can we do?
2238       --  So, we don't test it.
2239
2240       return Text;
2241
2242    end Read_Library_Info;
2243
2244    ----------------------
2245    -- Read_Source_File --
2246    ----------------------
2247
2248    procedure Read_Source_File
2249      (N   : File_Name_Type;
2250       Lo  : Source_Ptr;
2251       Hi  : out Source_Ptr;
2252       Src : out Source_Buffer_Ptr;
2253       T   : File_Type := Source)
2254    is
2255       Source_File_FD : File_Descriptor;
2256       --  The file descriptor for the current source file. A negative value
2257       --  indicates failure to open the specified source file.
2258
2259       Len : Integer;
2260       --  Length of file. Assume no more than 2 gigabytes of source!
2261
2262       Actual_Len : Integer;
2263
2264       Status : Boolean;
2265       pragma Warnings (Off, Status);
2266       --  For the call to Close
2267
2268    begin
2269       Current_Full_Source_Name  := Find_File (N, T);
2270       Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
2271
2272       if Current_Full_Source_Name = No_File then
2273
2274          --  If we were trying to access the main file and we could not find
2275          --  it, we have an error.
2276
2277          if N = Current_Main then
2278             Get_Name_String (N);
2279             Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
2280          end if;
2281
2282          Src := null;
2283          Hi  := No_Location;
2284          return;
2285       end if;
2286
2287       Get_Name_String (Current_Full_Source_Name);
2288       Name_Buffer (Name_Len + 1) := ASCII.NUL;
2289
2290       --  Open the source FD, note that we open in binary mode, because as
2291       --  documented in the spec, the caller is expected to handle either
2292       --  DOS or Unix mode files, and there is no point in wasting time on
2293       --  text translation when it is not required.
2294
2295       Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
2296
2297       if Source_File_FD = Invalid_FD then
2298          Src := null;
2299          Hi  := No_Location;
2300          return;
2301       end if;
2302
2303       --  Print out the file name, if requested, and if it's not part of the
2304       --  runtimes, store it in File_Name_Chars.
2305
2306       declare
2307          Name : String renames Name_Buffer (1 .. Name_Len);
2308          Inc  : String renames Include_Dir_Default_Prefix.all;
2309
2310       begin
2311          if Debug.Debug_Flag_Dot_N then
2312             Write_Line (Name);
2313          end if;
2314
2315          if Inc /= ""
2316            and then Inc'Length < Name_Len
2317            and then Name_Buffer (1 .. Inc'Length) = Inc
2318          then
2319             --  Part of runtimes, so ignore it
2320
2321             null;
2322
2323          else
2324             File_Name_Chars.Append_All (File_Name_Chars.Table_Type (Name));
2325             File_Name_Chars.Append (ASCII.LF);
2326          end if;
2327       end;
2328
2329       --  Prepare to read data from the file
2330
2331       Len := Integer (File_Length (Source_File_FD));
2332
2333       --  Set Hi so that length is one more than the physical length,
2334       --  allowing for the extra EOF character at the end of the buffer
2335
2336       Hi := Lo + Source_Ptr (Len);
2337
2338       --  Do the actual read operation
2339
2340       declare
2341          subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
2342          --  Physical buffer allocated
2343
2344          type Actual_Source_Ptr is access Actual_Source_Buffer;
2345          --  This is the pointer type for the physical buffer allocated
2346
2347          Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
2348          --  And this is the actual physical buffer
2349
2350       begin
2351          --  Allocate source buffer, allowing extra character at end for EOF
2352
2353          --  Some systems (e.g. VMS) have file types that require one read per
2354          --  line, so read until we get the Len bytes or until there are no
2355          --  more characters.
2356
2357          Hi := Lo;
2358          loop
2359             Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
2360             Hi := Hi + Source_Ptr (Actual_Len);
2361             exit when Actual_Len = Len or else Actual_Len <= 0;
2362          end loop;
2363
2364          Actual_Ptr (Hi) := EOF;
2365
2366          --  Now we need to work out the proper virtual origin pointer to
2367          --  return. This is exactly Actual_Ptr (0)'Address, but we have to
2368          --  be careful to suppress checks to compute this address.
2369
2370          declare
2371             pragma Suppress (All_Checks);
2372
2373             pragma Warnings (Off);
2374             --  This use of unchecked conversion is aliasing safe
2375
2376             function To_Source_Buffer_Ptr is new
2377               Unchecked_Conversion (Address, Source_Buffer_Ptr);
2378
2379             pragma Warnings (On);
2380
2381          begin
2382             Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
2383          end;
2384       end;
2385
2386       --  Read is complete, get time stamp and close file and we are done
2387
2388       Close (Source_File_FD, Status);
2389
2390       --  The status should never be False. But, if it is, what can we do?
2391       --  So, we don't test it.
2392
2393    end Read_Source_File;
2394
2395    -------------------
2396    -- Relocate_Path --
2397    -------------------
2398
2399    function Relocate_Path
2400      (Prefix : String;
2401       Path   : String) return String_Ptr
2402    is
2403       S : String_Ptr;
2404
2405       procedure set_std_prefix (S : String; Len : Integer);
2406       pragma Import (C, set_std_prefix);
2407
2408    begin
2409       if Std_Prefix = null then
2410          Std_Prefix := Executable_Prefix;
2411
2412          if Std_Prefix.all /= "" then
2413
2414             --  Remove trailing directory separator when calling set_std_prefix
2415
2416             set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1);
2417          end if;
2418       end if;
2419
2420       if Path (Prefix'Range) = Prefix then
2421          if Std_Prefix.all /= "" then
2422             S := new String
2423               (1 .. Std_Prefix'Length + Path'Last - Prefix'Last);
2424             S (1 .. Std_Prefix'Length) := Std_Prefix.all;
2425             S (Std_Prefix'Length + 1 .. S'Last) :=
2426               Path (Prefix'Last + 1 .. Path'Last);
2427             return S;
2428          end if;
2429       end if;
2430
2431       return new String'(Path);
2432    end Relocate_Path;
2433
2434    -----------------
2435    -- Set_Program --
2436    -----------------
2437
2438    procedure Set_Program (P : Program_Type) is
2439    begin
2440       if Program_Set then
2441          Fail ("Set_Program called twice");
2442       end if;
2443
2444       Program_Set := True;
2445       Running_Program := P;
2446    end Set_Program;
2447
2448    ----------------
2449    -- Shared_Lib --
2450    ----------------
2451
2452    function Shared_Lib (Name : String) return String is
2453       Library : String (1 .. Name'Length + Library_Version'Length + 3);
2454       --  3 = 2 for "-l" + 1 for "-" before lib version
2455
2456    begin
2457       Library (1 .. 2)                          := "-l";
2458       Library (3 .. 2 + Name'Length)            := Name;
2459       Library (3 + Name'Length)                 := '-';
2460       Library (4 + Name'Length .. Library'Last) := Library_Version;
2461
2462       if OpenVMS_On_Target then
2463          for K in Library'First + 2 .. Library'Last loop
2464             if Library (K) = '.' or else Library (K) = '-' then
2465                Library (K) := '_';
2466             end if;
2467          end loop;
2468       end if;
2469
2470       return Library;
2471    end Shared_Lib;
2472
2473    ----------------------
2474    -- Smart_File_Stamp --
2475    ----------------------
2476
2477    function Smart_File_Stamp
2478      (N : File_Name_Type;
2479       T : File_Type) return Time_Stamp_Type
2480    is
2481       Time_Stamp : Time_Stamp_Type;
2482
2483    begin
2484       if not File_Cache_Enabled then
2485          return File_Stamp (Find_File (N, T));
2486       end if;
2487
2488       Time_Stamp := File_Stamp_Hash_Table.Get (N);
2489
2490       if Time_Stamp (1) = ' ' then
2491          Time_Stamp := File_Stamp (Smart_Find_File (N, T));
2492          File_Stamp_Hash_Table.Set (N, Time_Stamp);
2493       end if;
2494
2495       return Time_Stamp;
2496    end Smart_File_Stamp;
2497
2498    ---------------------
2499    -- Smart_Find_File --
2500    ---------------------
2501
2502    function Smart_Find_File
2503      (N : File_Name_Type;
2504       T : File_Type) return File_Name_Type
2505    is
2506       Full_File_Name : File_Name_Type;
2507
2508    begin
2509       if not File_Cache_Enabled then
2510          return Find_File (N, T);
2511       end if;
2512
2513       Full_File_Name := File_Name_Hash_Table.Get (N);
2514
2515       if Full_File_Name = No_File then
2516          Full_File_Name := Find_File (N, T);
2517          File_Name_Hash_Table.Set (N, Full_File_Name);
2518       end if;
2519
2520       return Full_File_Name;
2521    end Smart_Find_File;
2522
2523    ----------------------
2524    -- Source_File_Data --
2525    ----------------------
2526
2527    procedure Source_File_Data (Cache : Boolean) is
2528    begin
2529       File_Cache_Enabled := Cache;
2530    end Source_File_Data;
2531
2532    -----------------------
2533    -- Source_File_Stamp --
2534    -----------------------
2535
2536    function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
2537    begin
2538       return Smart_File_Stamp (N, Source);
2539    end Source_File_Stamp;
2540
2541    ---------------------
2542    -- Strip_Directory --
2543    ---------------------
2544
2545    function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
2546    begin
2547       Get_Name_String (Name);
2548
2549       for J in reverse 1 .. Name_Len - 1 loop
2550
2551          --  If we find the last directory separator
2552
2553          if Is_Directory_Separator (Name_Buffer (J)) then
2554
2555             --  Return the part of Name that follows this last directory
2556             --  separator.
2557
2558             Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
2559             Name_Len := Name_Len - J;
2560             return Name_Find;
2561          end if;
2562       end loop;
2563
2564       --  There were no directory separator, just return Name
2565
2566       return Name;
2567    end Strip_Directory;
2568
2569    ------------------
2570    -- Strip_Suffix --
2571    ------------------
2572
2573    function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
2574    begin
2575       Get_Name_String (Name);
2576
2577       for J in reverse 2 .. Name_Len loop
2578
2579          --  If we found the last '.', return part of Name that precedes it
2580
2581          if Name_Buffer (J) = '.' then
2582             Name_Len := J - 1;
2583             return Name_Enter;
2584          end if;
2585       end loop;
2586
2587       return Name;
2588    end Strip_Suffix;
2589
2590    ---------------------------
2591    -- To_Canonical_Dir_Spec --
2592    ---------------------------
2593
2594    function To_Canonical_Dir_Spec
2595      (Host_Dir     : String;
2596       Prefix_Style : Boolean) return String_Access
2597    is
2598       function To_Canonical_Dir_Spec
2599         (Host_Dir    : Address;
2600          Prefix_Flag : Integer) return Address;
2601       pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
2602
2603       C_Host_Dir      : String (1 .. Host_Dir'Length + 1);
2604       Canonical_Dir_Addr : Address;
2605       Canonical_Dir_Len  : Integer;
2606
2607    begin
2608       C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir;
2609       C_Host_Dir (C_Host_Dir'Last)      := ASCII.NUL;
2610
2611       if Prefix_Style then
2612          Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1);
2613       else
2614          Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
2615       end if;
2616       Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);
2617
2618       if Canonical_Dir_Len = 0 then
2619          return null;
2620       else
2621          return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len);
2622       end if;
2623
2624    exception
2625       when others =>
2626          Fail ("erroneous directory spec: " & Host_Dir);
2627          return null;
2628    end To_Canonical_Dir_Spec;
2629
2630    ---------------------------
2631    -- To_Canonical_File_List --
2632    ---------------------------
2633
2634    function To_Canonical_File_List
2635      (Wildcard_Host_File : String;
2636       Only_Dirs          : Boolean) return String_Access_List_Access
2637    is
2638       function To_Canonical_File_List_Init
2639         (Host_File : Address;
2640          Only_Dirs : Integer) return Integer;
2641       pragma Import (C, To_Canonical_File_List_Init,
2642                      "__gnat_to_canonical_file_list_init");
2643
2644       function To_Canonical_File_List_Next return Address;
2645       pragma Import (C, To_Canonical_File_List_Next,
2646                      "__gnat_to_canonical_file_list_next");
2647
2648       procedure To_Canonical_File_List_Free;
2649       pragma Import (C, To_Canonical_File_List_Free,
2650                      "__gnat_to_canonical_file_list_free");
2651
2652       Num_Files            : Integer;
2653       C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
2654
2655    begin
2656       C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
2657         Wildcard_Host_File;
2658       C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
2659
2660       --  Do the expansion and say how many there are
2661
2662       Num_Files := To_Canonical_File_List_Init
2663          (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
2664
2665       declare
2666          Canonical_File_List : String_Access_List (1 .. Num_Files);
2667          Canonical_File_Addr : Address;
2668          Canonical_File_Len  : Integer;
2669
2670       begin
2671          --  Retrieve the expanded directory names and build the list
2672
2673          for J in 1 .. Num_Files loop
2674             Canonical_File_Addr := To_Canonical_File_List_Next;
2675             Canonical_File_Len  := C_String_Length (Canonical_File_Addr);
2676             Canonical_File_List (J) := To_Path_String_Access
2677                   (Canonical_File_Addr, Canonical_File_Len);
2678          end loop;
2679
2680          --  Free up the storage
2681
2682          To_Canonical_File_List_Free;
2683
2684          return new String_Access_List'(Canonical_File_List);
2685       end;
2686    end To_Canonical_File_List;
2687
2688    ----------------------------
2689    -- To_Canonical_File_Spec --
2690    ----------------------------
2691
2692    function To_Canonical_File_Spec
2693      (Host_File : String) return String_Access
2694    is
2695       function To_Canonical_File_Spec (Host_File : Address) return Address;
2696       pragma Import
2697         (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
2698
2699       C_Host_File         : String (1 .. Host_File'Length + 1);
2700       Canonical_File_Addr : Address;
2701       Canonical_File_Len  : Integer;
2702
2703    begin
2704       C_Host_File (1 .. Host_File'Length) := Host_File;
2705       C_Host_File (C_Host_File'Last)      := ASCII.NUL;
2706
2707       Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address);
2708       Canonical_File_Len  := C_String_Length (Canonical_File_Addr);
2709
2710       if Canonical_File_Len = 0 then
2711          return null;
2712       else
2713          return To_Path_String_Access
2714                   (Canonical_File_Addr, Canonical_File_Len);
2715       end if;
2716
2717    exception
2718       when others =>
2719          Fail ("erroneous file spec: " & Host_File);
2720          return null;
2721    end To_Canonical_File_Spec;
2722
2723    ----------------------------
2724    -- To_Canonical_Path_Spec --
2725    ----------------------------
2726
2727    function To_Canonical_Path_Spec
2728      (Host_Path : String) return String_Access
2729    is
2730       function To_Canonical_Path_Spec (Host_Path : Address) return Address;
2731       pragma Import
2732         (C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec");
2733
2734       C_Host_Path         : String (1 .. Host_Path'Length + 1);
2735       Canonical_Path_Addr : Address;
2736       Canonical_Path_Len  : Integer;
2737
2738    begin
2739       C_Host_Path (1 .. Host_Path'Length) := Host_Path;
2740       C_Host_Path (C_Host_Path'Last)      := ASCII.NUL;
2741
2742       Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address);
2743       Canonical_Path_Len  := C_String_Length (Canonical_Path_Addr);
2744
2745       --  Return a null string (vice a null) for zero length paths, for
2746       --  compatibility with getenv().
2747
2748       return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len);
2749
2750    exception
2751       when others =>
2752          Fail ("erroneous path spec: " & Host_Path);
2753          return null;
2754    end To_Canonical_Path_Spec;
2755
2756    ---------------------------
2757    -- To_Host_Dir_Spec --
2758    ---------------------------
2759
2760    function To_Host_Dir_Spec
2761      (Canonical_Dir : String;
2762       Prefix_Style  : Boolean) return String_Access
2763    is
2764       function To_Host_Dir_Spec
2765         (Canonical_Dir : Address;
2766          Prefix_Flag   : Integer) return Address;
2767       pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
2768
2769       C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
2770       Host_Dir_Addr   : Address;
2771       Host_Dir_Len    : Integer;
2772
2773    begin
2774       C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir;
2775       C_Canonical_Dir (C_Canonical_Dir'Last)      := ASCII.NUL;
2776
2777       if Prefix_Style then
2778          Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1);
2779       else
2780          Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0);
2781       end if;
2782       Host_Dir_Len := C_String_Length (Host_Dir_Addr);
2783
2784       if Host_Dir_Len = 0 then
2785          return null;
2786       else
2787          return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len);
2788       end if;
2789    end To_Host_Dir_Spec;
2790
2791    ----------------------------
2792    -- To_Host_File_Spec --
2793    ----------------------------
2794
2795    function To_Host_File_Spec
2796      (Canonical_File : String) return String_Access
2797    is
2798       function To_Host_File_Spec (Canonical_File : Address) return Address;
2799       pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
2800
2801       C_Canonical_File      : String (1 .. Canonical_File'Length + 1);
2802       Host_File_Addr : Address;
2803       Host_File_Len  : Integer;
2804
2805    begin
2806       C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File;
2807       C_Canonical_File (C_Canonical_File'Last)      := ASCII.NUL;
2808
2809       Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address);
2810       Host_File_Len  := C_String_Length (Host_File_Addr);
2811
2812       if Host_File_Len = 0 then
2813          return null;
2814       else
2815          return To_Path_String_Access
2816                   (Host_File_Addr, Host_File_Len);
2817       end if;
2818    end To_Host_File_Spec;
2819
2820    ---------------------------
2821    -- To_Path_String_Access --
2822    ---------------------------
2823
2824    function To_Path_String_Access
2825      (Path_Addr : Address;
2826       Path_Len  : Integer) return String_Access
2827    is
2828       subtype Path_String is String (1 .. Path_Len);
2829       type Path_String_Access is access Path_String;
2830
2831       function Address_To_Access is new
2832         Unchecked_Conversion (Source => Address,
2833                               Target => Path_String_Access);
2834
2835       Path_Access : constant Path_String_Access :=
2836                       Address_To_Access (Path_Addr);
2837
2838       Return_Val : String_Access;
2839
2840    begin
2841       Return_Val := new String (1 .. Path_Len);
2842
2843       for J in 1 .. Path_Len loop
2844          Return_Val (J) := Path_Access (J);
2845       end loop;
2846
2847       return Return_Val;
2848    end To_Path_String_Access;
2849
2850    -----------------
2851    -- Update_Path --
2852    -----------------
2853
2854    function Update_Path (Path : String_Ptr) return String_Ptr is
2855
2856       function C_Update_Path (Path, Component : Address) return Address;
2857       pragma Import (C, C_Update_Path, "update_path");
2858
2859       function Strlen (Str : Address) return Integer;
2860       pragma Import (C, Strlen, "strlen");
2861
2862       procedure Strncpy (X : Address; Y : Address; Length : Integer);
2863       pragma Import (C, Strncpy, "strncpy");
2864
2865       In_Length      : constant Integer := Path'Length;
2866       In_String      : String (1 .. In_Length + 1);
2867       Component_Name : aliased String := "GCC" & ASCII.NUL;
2868       Result_Ptr     : Address;
2869       Result_Length  : Integer;
2870       Out_String     : String_Ptr;
2871
2872    begin
2873       In_String (1 .. In_Length) := Path.all;
2874       In_String (In_Length + 1) := ASCII.NUL;
2875       Result_Ptr := C_Update_Path (In_String'Address, Component_Name'Address);
2876       Result_Length := Strlen (Result_Ptr);
2877
2878       Out_String := new String (1 .. Result_Length);
2879       Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
2880       return Out_String;
2881    end Update_Path;
2882
2883    ----------------
2884    -- Write_Info --
2885    ----------------
2886
2887    procedure Write_Info (Info : String) is
2888    begin
2889       Write_With_Check (Info'Address, Info'Length);
2890       Write_With_Check (EOL'Address, 1);
2891    end Write_Info;
2892
2893    ------------------------
2894    -- Write_Program_Name --
2895    ------------------------
2896
2897    procedure Write_Program_Name is
2898       Save_Buffer : constant String (1 .. Name_Len) :=
2899                       Name_Buffer (1 .. Name_Len);
2900
2901    begin
2902       Find_Program_Name;
2903
2904       --  Convert the name to lower case so error messages are the same on
2905       --  all systems.
2906
2907       for J in 1 .. Name_Len loop
2908          if Name_Buffer (J) in 'A' .. 'Z' then
2909             Name_Buffer (J) :=
2910               Character'Val (Character'Pos (Name_Buffer (J)) + 32);
2911          end if;
2912       end loop;
2913
2914       Write_Str (Name_Buffer (1 .. Name_Len));
2915
2916       --  Restore Name_Buffer which was clobbered by the call to
2917       --  Find_Program_Name
2918
2919       Name_Len := Save_Buffer'Last;
2920       Name_Buffer (1 .. Name_Len) := Save_Buffer;
2921    end Write_Program_Name;
2922
2923    ----------------------
2924    -- Write_With_Check --
2925    ----------------------
2926
2927    procedure Write_With_Check (A  : Address; N  : Integer) is
2928       Ignore : Boolean;
2929       pragma Warnings (Off, Ignore);
2930
2931    begin
2932       if N = Write (Output_FD, A, N) then
2933          return;
2934
2935       else
2936          Write_Str ("error: disk full writing ");
2937          Write_Name_Decoded (Output_File_Name);
2938          Write_Eol;
2939          Name_Len := Name_Len + 1;
2940          Name_Buffer (Name_Len) := ASCII.NUL;
2941          Delete_File (Name_Buffer'Address, Ignore);
2942          Exit_Program (E_Fatal);
2943       end if;
2944    end Write_With_Check;
2945
2946 ----------------------------
2947 -- Package Initialization --
2948 ----------------------------
2949
2950 begin
2951    Initialization : declare
2952
2953       function Get_Default_Identifier_Character_Set return Character;
2954       pragma Import (C, Get_Default_Identifier_Character_Set,
2955                        "__gnat_get_default_identifier_character_set");
2956       --  Function to determine the default identifier character set,
2957       --  which is system dependent. See Opt package spec for a list of
2958       --  the possible character codes and their interpretations.
2959
2960       function Get_Maximum_File_Name_Length return Int;
2961       pragma Import (C, Get_Maximum_File_Name_Length,
2962                     "__gnat_get_maximum_file_name_length");
2963       --  Function to get maximum file name length for system
2964
2965    begin
2966       Identifier_Character_Set := Get_Default_Identifier_Character_Set;
2967       Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
2968
2969       --  Following should be removed by having above function return
2970       --  Integer'Last as indication of no maximum instead of -1 ???
2971
2972       if Maximum_File_Name_Length = -1 then
2973          Maximum_File_Name_Length := Int'Last;
2974       end if;
2975
2976       Src_Search_Directories.Set_Last (Primary_Directory);
2977       Src_Search_Directories.Table (Primary_Directory) := new String'("");
2978
2979       Lib_Search_Directories.Set_Last (Primary_Directory);
2980       Lib_Search_Directories.Table (Primary_Directory) := new String'("");
2981
2982       Osint.Initialize;
2983    end Initialization;
2984
2985 end Osint;