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