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