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