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