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