gcc/ada/osint.adb

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