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