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