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 (S1 : String; S2 : String := ""; S3 : 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 (S1);
 912       Write_Str (S2);
 913       Write_Str (S3);
 914       Write_Eol;
 915
 916       Exit_Program (E_Fatal);
 917    end Fail;
 918
 919    ---------------
 920    -- File_Hash --
 921    ---------------
 922
 923    function File_Hash (F : File_Name_Type) return File_Hash_Num is
 924    begin
 925       return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
 926    end File_Hash;
 927
 928    ----------------
 929    -- File_Stamp --
 930    ----------------
 931
 932    function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
 933    begin
 934       if Name = No_File then
 935          return Empty_Time_Stamp;
 936       end if;
 937
 938       Get_Name_String (Name);
 939
 940       if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
 941          return Empty_Time_Stamp;
 942       else
 943          Name_Buffer (Name_Len + 1) := ASCII.NUL;
 944          return OS_Time_To_GNAT_Time (File_Time_Stamp (Name_Buffer));
 945       end if;
 946    end File_Stamp;
 947
 948    function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is
 949    begin
 950       return File_Stamp (File_Name_Type (Name));
 951    end File_Stamp;
 952
 953    ---------------
 954    -- Find_File --
 955    ---------------
 956
 957    function Find_File
 958      (N : File_Name_Type;
 959       T : File_Type) return File_Name_Type
 960    is
 961    begin
 962       Get_Name_String (N);
 963
 964       declare
 965          File_Name : String renames Name_Buffer (1 .. Name_Len);
 966          File      : File_Name_Type := No_File;
 967          Last_Dir  : Natural;
 968
 969       begin
 970          --  If we are looking for a config file, look only in the current
 971          --  directory, i.e. return input argument unchanged. Also look
 972          --  only in the current directory if we are looking for a .dg
 973          --  file (happens in -gnatD mode).
 974
 975          if T = Config
 976            or else (Debug_Generated_Code
 977                       and then Name_Len > 3
 978                       and then
 979                       (Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg"
 980                        or else
 981                        (Hostparm.OpenVMS and then
 982                         Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg")))
 983          then
 984             return N;
 985
 986          --  If we are trying to find the current main file just look in the
 987          --  directory where the user said it was.
 988
 989          elsif Look_In_Primary_Directory_For_Current_Main
 990            and then Current_Main = N
 991          then
 992             return Locate_File (N, T, Primary_Directory, File_Name);
 993
 994          --  Otherwise do standard search for source file
 995
 996          else
 997             --  Check the mapping of this file name
 998
 999             File := Mapped_Path_Name (N);
1000
1001             --  If the file name is mapped to a path name, return the
1002             --  corresponding path name
1003
1004             if File /= No_File then
1005
1006                --  For locally removed file, Error_Name is returned; then
1007                --  return No_File, indicating the file is not a source.
1008
1009                if File = Error_File_Name then
1010                   return No_File;
1011
1012                else
1013                   return File;
1014                end if;
1015             end if;
1016
1017             --  First place to look is in the primary directory (i.e. the same
1018             --  directory as the source) unless this has been disabled with -I-
1019
1020             if Opt.Look_In_Primary_Dir then
1021                File := Locate_File (N, T, Primary_Directory, File_Name);
1022
1023                if File /= No_File then
1024                   return File;
1025                end if;
1026             end if;
1027
1028             --  Finally look in directories specified with switches -I/-aI/-aO
1029
1030             if T = Library then
1031                Last_Dir := Lib_Search_Directories.Last;
1032             else
1033                Last_Dir := Src_Search_Directories.Last;
1034             end if;
1035
1036             for D in Primary_Directory + 1 .. Last_Dir loop
1037                File := Locate_File (N, T, D, File_Name);
1038
1039                if File /= No_File then
1040                   return File;
1041                end if;
1042             end loop;
1043
1044             return No_File;
1045          end if;
1046       end;
1047    end Find_File;
1048
1049    -----------------------
1050    -- Find_Program_Name --
1051    -----------------------
1052
1053    procedure Find_Program_Name is
1054       Command_Name : String (1 .. Len_Arg (0));
1055       Cindex1      : Integer := Command_Name'First;
1056       Cindex2      : Integer := Command_Name'Last;
1057
1058    begin
1059       Fill_Arg (Command_Name'Address, 0);
1060
1061       if Command_Name = "" then
1062          Name_Len := 0;
1063          return;
1064       end if;
1065
1066       --  The program name might be specified by a full path name. However,
1067       --  we don't want to print that all out in an error message, so the
1068       --  path might need to be stripped away.
1069
1070       for J in reverse Cindex1 .. Cindex2 loop
1071          if Is_Directory_Separator (Command_Name (J)) then
1072             Cindex1 := J + 1;
1073             exit;
1074          end if;
1075       end loop;
1076
1077       --  Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
1078       --  POSIX command "basename argv[0]"
1079
1080       --  Strip off any versioning information such as found on VMS.
1081       --  This would take the form of TOOL.exe followed by a ";" or "."
1082       --  and a sequence of one or more numbers.
1083
1084       if Command_Name (Cindex2) in '0' .. '9' then
1085          for J in reverse Cindex1 .. Cindex2 loop
1086             if Command_Name (J) = '.' or Command_Name (J) = ';' then
1087                Cindex2 := J - 1;
1088                exit;
1089             end if;
1090
1091             exit when Command_Name (J) not in '0' .. '9';
1092          end loop;
1093       end if;
1094
1095       --  Strip off any executable extension (usually nothing or .exe)
1096       --  but formally reported by autoconf in the variable EXEEXT
1097
1098       if Cindex2 - Cindex1 >= 4 then
1099          if To_Lower (Command_Name (Cindex2 - 3)) = '.'
1100             and then To_Lower (Command_Name (Cindex2 - 2)) = 'e'
1101             and then To_Lower (Command_Name (Cindex2 - 1)) = 'x'
1102             and then To_Lower (Command_Name (Cindex2)) = 'e'
1103          then
1104             Cindex2 := Cindex2 - 4;
1105          end if;
1106       end if;
1107
1108       Name_Len := Cindex2 - Cindex1 + 1;
1109       Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
1110    end Find_Program_Name;
1111
1112    ------------------------
1113    -- Full_Lib_File_Name --
1114    ------------------------
1115
1116    function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
1117    begin
1118       return Find_File (N, Library);
1119    end Full_Lib_File_Name;
1120
1121    ----------------------------
1122    -- Full_Library_Info_Name --
1123    ----------------------------
1124
1125    function Full_Library_Info_Name return File_Name_Type is
1126    begin
1127       return Current_Full_Lib_Name;
1128    end Full_Library_Info_Name;
1129
1130    ---------------------------
1131    -- Full_Object_File_Name --
1132    ---------------------------
1133
1134    function Full_Object_File_Name return File_Name_Type is
1135    begin
1136       return Current_Full_Obj_Name;
1137    end Full_Object_File_Name;
1138
1139    ----------------------
1140    -- Full_Source_Name --
1141    ----------------------
1142
1143    function Full_Source_Name return File_Name_Type is
1144    begin
1145       return Current_Full_Source_Name;
1146    end Full_Source_Name;
1147
1148    ----------------------
1149    -- Full_Source_Name --
1150    ----------------------
1151
1152    function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
1153    begin
1154       return Smart_Find_File (N, Source);
1155    end Full_Source_Name;
1156
1157    -------------------
1158    -- Get_Directory --
1159    -------------------
1160
1161    function Get_Directory (Name : File_Name_Type) return File_Name_Type is
1162    begin
1163       Get_Name_String (Name);
1164
1165       for J in reverse 1 .. Name_Len loop
1166          if Is_Directory_Separator (Name_Buffer (J)) then
1167             Name_Len := J;
1168             return Name_Find;
1169          end if;
1170       end loop;
1171
1172       Name_Len := Hostparm.Normalized_CWD'Length;
1173       Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
1174       return Name_Find;
1175    end Get_Directory;
1176
1177    --------------------------
1178    -- Get_Next_Dir_In_Path --
1179    --------------------------
1180
1181    Search_Path_Pos : Integer;
1182    --  Keeps track of current position in search path. Initialized by the
1183    --  call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
1184
1185    function Get_Next_Dir_In_Path
1186      (Search_Path : String_Access) return String_Access
1187    is
1188       Lower_Bound : Positive := Search_Path_Pos;
1189       Upper_Bound : Positive;
1190
1191    begin
1192       loop
1193          while Lower_Bound <= Search_Path'Last
1194            and then Search_Path.all (Lower_Bound) = Path_Separator
1195          loop
1196             Lower_Bound := Lower_Bound + 1;
1197          end loop;
1198
1199          exit when Lower_Bound > Search_Path'Last;
1200
1201          Upper_Bound := Lower_Bound;
1202          while Upper_Bound <= Search_Path'Last
1203            and then Search_Path.all (Upper_Bound) /= Path_Separator
1204          loop
1205             Upper_Bound := Upper_Bound + 1;
1206          end loop;
1207
1208          Search_Path_Pos := Upper_Bound;
1209          return new String'(Search_Path.all (Lower_Bound .. Upper_Bound - 1));
1210       end loop;
1211
1212       return null;
1213    end Get_Next_Dir_In_Path;
1214
1215    -------------------------------
1216    -- Get_Next_Dir_In_Path_Init --
1217    -------------------------------
1218
1219    procedure Get_Next_Dir_In_Path_Init (Search_Path : String_Access) is
1220    begin
1221       Search_Path_Pos := Search_Path'First;
1222    end Get_Next_Dir_In_Path_Init;
1223
1224    --------------------------------------
1225    -- Get_Primary_Src_Search_Directory --
1226    --------------------------------------
1227
1228    function Get_Primary_Src_Search_Directory return String_Ptr is
1229    begin
1230       return Src_Search_Directories.Table (Primary_Directory);
1231    end Get_Primary_Src_Search_Directory;
1232
1233    ------------------------
1234    -- Get_RTS_Search_Dir --
1235    ------------------------
1236
1237    function Get_RTS_Search_Dir
1238      (Search_Dir : String;
1239       File_Type  : Search_File_Type) return String_Ptr
1240    is
1241       procedure Get_Current_Dir
1242         (Dir    : System.Address;
1243          Length : System.Address);
1244       pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
1245
1246       Max_Path : Integer;
1247       pragma Import (C, Max_Path, "__gnat_max_path_len");
1248       --  Maximum length of a path name
1249
1250       Current_Dir        : String_Ptr;
1251       Default_Search_Dir : String_Access;
1252       Default_Suffix_Dir : String_Access;
1253       Local_Search_Dir   : String_Access;
1254       Norm_Search_Dir    : String_Access;
1255       Result_Search_Dir  : String_Access;
1256       Search_File        : String_Access;
1257       Temp_String        : String_Ptr;
1258
1259    begin
1260       --  Add a directory separator at the end of the directory if necessary
1261       --  so that we can directly append a file to the directory
1262
1263       if Search_Dir (Search_Dir'Last) /= Directory_Separator then
1264          Local_Search_Dir :=
1265            new String'(Search_Dir & String'(1 => Directory_Separator));
1266       else
1267          Local_Search_Dir := new String'(Search_Dir);
1268       end if;
1269
1270       if File_Type = Include then
1271          Search_File := Include_Search_File;
1272          Default_Suffix_Dir := new String'("adainclude");
1273       else
1274          Search_File := Objects_Search_File;
1275          Default_Suffix_Dir := new String'("adalib");
1276       end if;
1277
1278       Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all);
1279
1280       if Is_Absolute_Path (Norm_Search_Dir.all) then
1281
1282          --  We first verify if there is a directory Include_Search_Dir
1283          --  containing default search directories
1284
1285          Result_Search_Dir :=
1286            Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1287          Default_Search_Dir :=
1288            new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1289          Free (Norm_Search_Dir);
1290
1291          if Result_Search_Dir /= null then
1292             return String_Ptr (Result_Search_Dir);
1293          elsif Is_Directory (Default_Search_Dir.all) then
1294             return String_Ptr (Default_Search_Dir);
1295          else
1296             return null;
1297          end if;
1298
1299       --  Search in the current directory
1300
1301       else
1302          --  Get the current directory
1303
1304          declare
1305             Buffer   : String (1 .. Max_Path + 2);
1306             Path_Len : Natural := Max_Path;
1307
1308          begin
1309             Get_Current_Dir (Buffer'Address, Path_Len'Address);
1310
1311             if Buffer (Path_Len) /= Directory_Separator then
1312                Path_Len := Path_Len + 1;
1313                Buffer (Path_Len) := Directory_Separator;
1314             end if;
1315
1316             Current_Dir := new String'(Buffer (1 .. Path_Len));
1317          end;
1318
1319          Norm_Search_Dir :=
1320            new String'(Current_Dir.all & Local_Search_Dir.all);
1321
1322          Result_Search_Dir :=
1323            Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1324
1325          Default_Search_Dir :=
1326            new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1327
1328          Free (Norm_Search_Dir);
1329
1330          if Result_Search_Dir /= null then
1331             return String_Ptr (Result_Search_Dir);
1332
1333          elsif Is_Directory (Default_Search_Dir.all) then
1334             return String_Ptr (Default_Search_Dir);
1335
1336          else
1337             --  Search in Search_Dir_Prefix/Search_Dir
1338
1339             Norm_Search_Dir :=
1340               new String'
1341                (Update_Path (Search_Dir_Prefix).all & Local_Search_Dir.all);
1342
1343             Result_Search_Dir :=
1344               Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1345
1346             Default_Search_Dir :=
1347               new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1348
1349             Free (Norm_Search_Dir);
1350
1351             if Result_Search_Dir /= null then
1352                return String_Ptr (Result_Search_Dir);
1353
1354             elsif Is_Directory (Default_Search_Dir.all) then
1355                return String_Ptr (Default_Search_Dir);
1356
1357             else
1358                --  We finally search in Search_Dir_Prefix/rts-Search_Dir
1359
1360                Temp_String :=
1361                  new String'(Update_Path (Search_Dir_Prefix).all & "rts-");
1362
1363                Norm_Search_Dir :=
1364                  new String'(Temp_String.all & Local_Search_Dir.all);
1365
1366                Result_Search_Dir :=
1367                  Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1368
1369                Default_Search_Dir :=
1370                  new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1371                Free (Norm_Search_Dir);
1372
1373                if Result_Search_Dir /= null then
1374                   return String_Ptr (Result_Search_Dir);
1375
1376                elsif Is_Directory (Default_Search_Dir.all) then
1377                   return String_Ptr (Default_Search_Dir);
1378
1379                else
1380                   return null;
1381                end if;
1382             end if;
1383          end if;
1384       end if;
1385    end Get_RTS_Search_Dir;
1386
1387    --------------------------------
1388    -- Include_Dir_Default_Prefix --
1389    --------------------------------
1390
1391    function Include_Dir_Default_Prefix return String is
1392       Include_Dir : String_Access :=
1393                       String_Access (Update_Path (Include_Dir_Default_Name));
1394
1395    begin
1396       if Include_Dir = null then
1397          return "";
1398
1399       else
1400          declare
1401             Result : constant String := Include_Dir.all;
1402          begin
1403             Free (Include_Dir);
1404             return Result;
1405          end;
1406       end if;
1407    end Include_Dir_Default_Prefix;
1408
1409    ----------------
1410    -- Initialize --
1411    ----------------
1412
1413    procedure Initialize is
1414    begin
1415       Number_File_Names       := 0;
1416       Current_File_Name_Index := 0;
1417
1418       Src_Search_Directories.Init;
1419       Lib_Search_Directories.Init;
1420
1421       --  Start off by setting all suppress options to False, these will
1422       --  be reset later (turning some on if -gnato is not specified, and
1423       --  turning all of them on if -gnatp is specified).
1424
1425       Suppress_Options := (others => False);
1426
1427       --  Reserve the first slot in the search paths table. This is the
1428       --  directory of the main source file or main library file and is filled
1429       --  in by each call to Next_Main_Source/Next_Main_Lib_File with the
1430       --  directory specified for this main source or library file. This is the
1431       --  directory which is searched first by default. This default search is
1432       --  inhibited by the option -I- for both source and library files.
1433
1434       Src_Search_Directories.Set_Last (Primary_Directory);
1435       Src_Search_Directories.Table (Primary_Directory) := new String'("");
1436
1437       Lib_Search_Directories.Set_Last (Primary_Directory);
1438       Lib_Search_Directories.Table (Primary_Directory) := new String'("");
1439    end Initialize;
1440
1441    ----------------------------
1442    -- Is_Directory_Separator --
1443    ----------------------------
1444
1445    function Is_Directory_Separator (C : Character) return Boolean is
1446    begin
1447       --  In addition to the default directory_separator allow the '/' to
1448       --  act as separator since this is allowed in MS-DOS, Windows 95/NT,
1449       --  and OS2 ports. On VMS, the situation is more complicated because
1450       --  there are two characters to check for.
1451
1452       return
1453         C = Directory_Separator
1454           or else C = '/'
1455           or else (Hostparm.OpenVMS
1456                     and then (C = ']' or else C = ':'));
1457    end Is_Directory_Separator;
1458
1459    -------------------------
1460    -- Is_Readonly_Library --
1461    -------------------------
1462
1463    function Is_Readonly_Library (File : File_Name_Type) return Boolean is
1464    begin
1465       Get_Name_String (File);
1466
1467       pragma Assert (Name_Buffer (Name_Len - 3 .. Name_Len) = ".ali");
1468
1469       return not Is_Writable_File (Name_Buffer (1 .. Name_Len));
1470    end Is_Readonly_Library;
1471
1472    -------------------
1473    -- Lib_File_Name --
1474    -------------------
1475
1476    function Lib_File_Name
1477      (Source_File : File_Name_Type;
1478       Munit_Index : Nat := 0) return File_Name_Type
1479    is
1480    begin
1481       Get_Name_String (Source_File);
1482
1483       for J in reverse 2 .. Name_Len loop
1484          if Name_Buffer (J) = '.' then
1485             Name_Len := J - 1;
1486             exit;
1487          end if;
1488       end loop;
1489
1490       if Munit_Index /= 0 then
1491          Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
1492          Add_Nat_To_Name_Buffer (Munit_Index);
1493       end if;
1494
1495       Add_Char_To_Name_Buffer ('.');
1496       Add_Str_To_Name_Buffer (ALI_Suffix.all);
1497       return Name_Find;
1498    end Lib_File_Name;
1499
1500    ------------------------
1501    -- Library_File_Stamp --
1502    ------------------------
1503
1504    function Library_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
1505    begin
1506       return File_Stamp (Find_File (N, Library));
1507    end Library_File_Stamp;
1508
1509    -----------------
1510    -- Locate_File --
1511    -----------------
1512
1513    function Locate_File
1514      (N    : File_Name_Type;
1515       T    : File_Type;
1516       Dir  : Natural;
1517       Name : String) return File_Name_Type
1518    is
1519       Dir_Name : String_Ptr;
1520
1521    begin
1522       --  If Name is already an absolute path, do not look for a directory
1523
1524       if Is_Absolute_Path (Name) then
1525          Dir_Name := No_Dir;
1526
1527       elsif T = Library then
1528          Dir_Name := Lib_Search_Directories.Table (Dir);
1529
1530       else pragma Assert (T /= Config);
1531          Dir_Name := Src_Search_Directories.Table (Dir);
1532       end if;
1533
1534       declare
1535          Full_Name : String (1 .. Dir_Name'Length + Name'Length);
1536
1537       begin
1538          Full_Name (1 .. Dir_Name'Length) := Dir_Name.all;
1539          Full_Name (Dir_Name'Length + 1 .. Full_Name'Length) := Name;
1540
1541          if not Is_Regular_File (Full_Name) then
1542             return No_File;
1543
1544          else
1545             --  If the file is in the current directory then return N itself
1546
1547             if Dir_Name'Length = 0 then
1548                return N;
1549             else
1550                Name_Len := Full_Name'Length;
1551                Name_Buffer (1 .. Name_Len) := Full_Name;
1552                return Name_Enter;
1553             end if;
1554          end if;
1555       end;
1556    end Locate_File;
1557
1558    -------------------------------
1559    -- Matching_Full_Source_Name --
1560    -------------------------------
1561
1562    function Matching_Full_Source_Name
1563      (N : File_Name_Type;
1564       T : Time_Stamp_Type) return File_Name_Type
1565    is
1566    begin
1567       Get_Name_String (N);
1568
1569       declare
1570          File_Name : constant String := Name_Buffer (1 .. Name_Len);
1571          File      : File_Name_Type := No_File;
1572          Last_Dir  : Natural;
1573
1574       begin
1575          if Opt.Look_In_Primary_Dir then
1576             File := Locate_File (N, Source, Primary_Directory, File_Name);
1577
1578             if File /= No_File and then T = File_Stamp (N) then
1579                return File;
1580             end if;
1581          end if;
1582
1583          Last_Dir := Src_Search_Directories.Last;
1584
1585          for D in Primary_Directory + 1 .. Last_Dir loop
1586             File := Locate_File (N, Source, D, File_Name);
1587
1588             if File /= No_File and then T = File_Stamp (File) then
1589                return File;
1590             end if;
1591          end loop;
1592
1593          return No_File;
1594       end;
1595    end Matching_Full_Source_Name;
1596
1597    ----------------
1598    -- More_Files --
1599    ----------------
1600
1601    function More_Files return Boolean is
1602    begin
1603       return (Current_File_Name_Index < Number_File_Names);
1604    end More_Files;
1605
1606    -------------------------------
1607    -- Nb_Dir_In_Obj_Search_Path --
1608    -------------------------------
1609
1610    function Nb_Dir_In_Obj_Search_Path return Natural is
1611    begin
1612       if Opt.Look_In_Primary_Dir then
1613          return Lib_Search_Directories.Last -  Primary_Directory + 1;
1614       else
1615          return Lib_Search_Directories.Last -  Primary_Directory;
1616       end if;
1617    end Nb_Dir_In_Obj_Search_Path;
1618
1619    -------------------------------
1620    -- Nb_Dir_In_Src_Search_Path --
1621    -------------------------------
1622
1623    function Nb_Dir_In_Src_Search_Path return Natural is
1624    begin
1625       if Opt.Look_In_Primary_Dir then
1626          return Src_Search_Directories.Last -  Primary_Directory + 1;
1627       else
1628          return Src_Search_Directories.Last -  Primary_Directory;
1629       end if;
1630    end Nb_Dir_In_Src_Search_Path;
1631
1632    --------------------
1633    -- Next_Main_File --
1634    --------------------
1635
1636    function Next_Main_File return File_Name_Type is
1637       File_Name : String_Ptr;
1638       Dir_Name  : String_Ptr;
1639       Fptr      : Natural;
1640
1641    begin
1642       pragma Assert (More_Files);
1643
1644       Current_File_Name_Index := Current_File_Name_Index + 1;
1645
1646       --  Get the file and directory name
1647
1648       File_Name := File_Names (Current_File_Name_Index);
1649       Fptr := File_Name'First;
1650
1651       for J in reverse File_Name'Range loop
1652          if File_Name (J) = Directory_Separator
1653            or else File_Name (J) = '/'
1654          then
1655             if J = File_Name'Last then
1656                Fail ("File name missing");
1657             end if;
1658
1659             Fptr := J + 1;
1660             exit;
1661          end if;
1662       end loop;
1663
1664       --  Save name of directory in which main unit resides for use in
1665       --  locating other units
1666
1667       Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1));
1668
1669       case Running_Program is
1670
1671          when Compiler =>
1672             Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1673             Look_In_Primary_Directory_For_Current_Main := True;
1674
1675          when Make =>
1676             Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1677
1678             if Fptr > File_Name'First then
1679                Look_In_Primary_Directory_For_Current_Main := True;
1680             end if;
1681
1682          when Binder | Gnatls =>
1683             Dir_Name := Normalize_Directory_Name (Dir_Name.all);
1684             Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
1685
1686          when Unspecified =>
1687             null;
1688       end case;
1689
1690       Name_Len := File_Name'Last - Fptr + 1;
1691       Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
1692       Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1693       Current_Main := Name_Find;
1694
1695       --  In the gnatmake case, the main file may have not have the
1696       --  extension. Try ".adb" first then ".ads"
1697
1698       if Running_Program = Make then
1699          declare
1700             Orig_Main : constant File_Name_Type := Current_Main;
1701
1702          begin
1703             if Strip_Suffix (Orig_Main) = Orig_Main then
1704                Current_Main :=
1705                  Append_Suffix_To_File_Name (Orig_Main, ".adb");
1706
1707                if Full_Source_Name (Current_Main) = No_File then
1708                   Current_Main :=
1709                     Append_Suffix_To_File_Name (Orig_Main, ".ads");
1710
1711                   if Full_Source_Name (Current_Main) = No_File then
1712                      Current_Main := Orig_Main;
1713                   end if;
1714                end if;
1715             end if;
1716          end;
1717       end if;
1718
1719       return Current_Main;
1720    end Next_Main_File;
1721
1722    ------------------------------
1723    -- Normalize_Directory_Name --
1724    ------------------------------
1725
1726    function Normalize_Directory_Name (Directory : String) return String_Ptr is
1727
1728       function Is_Quoted (Path : String) return Boolean;
1729       pragma Inline (Is_Quoted);
1730       --  Returns true if Path is quoted (either double or single quotes)
1731
1732       ---------------
1733       -- Is_Quoted --
1734       ---------------
1735
1736       function Is_Quoted (Path : String) return Boolean is
1737          First : constant Character := Path (Path'First);
1738          Last  : constant Character := Path (Path'Last);
1739
1740       begin
1741          if (First = ''' and then Last = ''')
1742                or else
1743             (First = '"' and then Last = '"')
1744          then
1745             return True;
1746          else
1747             return False;
1748          end if;
1749       end Is_Quoted;
1750
1751       Result : String_Ptr;
1752
1753    --  Start of processing for Normalize_Directory_Name
1754
1755    begin
1756       if Directory'Length = 0 then
1757          Result := new String'(Hostparm.Normalized_CWD);
1758
1759       elsif Is_Directory_Separator (Directory (Directory'Last)) then
1760          Result := new String'(Directory);
1761
1762       elsif Is_Quoted (Directory) then
1763
1764          --  This is a quoted string, it certainly means that the directory
1765          --  contains some spaces for example. We can safely remove the quotes
1766          --  here as the OS_Lib.Normalize_Arguments will be called before any
1767          --  spawn routines. This ensure that quotes will be added when needed.
1768
1769          Result := new String (1 .. Directory'Length - 1);
1770          Result (1 .. Directory'Length - 2) :=
1771            Directory (Directory'First + 1 .. Directory'Last - 1);
1772          Result (Result'Last) := Directory_Separator;
1773
1774       else
1775          Result := new String (1 .. Directory'Length + 1);
1776          Result (1 .. Directory'Length) := Directory;
1777          Result (Directory'Length + 1) := Directory_Separator;
1778       end if;
1779
1780       return Result;
1781    end Normalize_Directory_Name;
1782
1783    ---------------------
1784    -- Number_Of_Files --
1785    ---------------------
1786
1787    function Number_Of_Files return Int is
1788    begin
1789       return Number_File_Names;
1790    end Number_Of_Files;
1791
1792    -------------------------------
1793    -- Object_Dir_Default_Prefix --
1794    -------------------------------
1795
1796    function Object_Dir_Default_Prefix return String is
1797       Object_Dir : String_Access :=
1798                      String_Access (Update_Path (Object_Dir_Default_Name));
1799
1800    begin
1801       if Object_Dir = null then
1802          return "";
1803
1804       else
1805          declare
1806             Result : constant String := Object_Dir.all;
1807          begin
1808             Free (Object_Dir);
1809             return Result;
1810          end;
1811       end if;
1812    end Object_Dir_Default_Prefix;
1813
1814    ----------------------
1815    -- Object_File_Name --
1816    ----------------------
1817
1818    function Object_File_Name (N : File_Name_Type) return File_Name_Type is
1819    begin
1820       if N = No_File then
1821          return No_File;
1822       end if;
1823
1824       Get_Name_String (N);
1825       Name_Len := Name_Len - ALI_Suffix'Length - 1;
1826
1827       for J in Target_Object_Suffix'Range loop
1828          Name_Len := Name_Len + 1;
1829          Name_Buffer (Name_Len) := Target_Object_Suffix (J);
1830       end loop;
1831
1832       return Name_Enter;
1833    end Object_File_Name;
1834
1835    -------------------------------
1836    -- OS_Exit_Through_Exception --
1837    -------------------------------
1838
1839    procedure OS_Exit_Through_Exception (Status : Integer) is
1840    begin
1841       Current_Exit_Status := Status;
1842       raise Types.Terminate_Program;
1843    end OS_Exit_Through_Exception;
1844
1845    --------------------------
1846    -- OS_Time_To_GNAT_Time --
1847    --------------------------
1848
1849    function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
1850       GNAT_Time : Time_Stamp_Type;
1851
1852       Y  : Year_Type;
1853       Mo : Month_Type;
1854       D  : Day_Type;
1855       H  : Hour_Type;
1856       Mn : Minute_Type;
1857       S  : Second_Type;
1858
1859    begin
1860       GM_Split (T, Y, Mo, D, H, Mn, S);
1861       Make_Time_Stamp
1862         (Year    => Nat (Y),
1863          Month   => Nat (Mo),
1864          Day     => Nat (D),
1865          Hour    => Nat (H),
1866          Minutes => Nat (Mn),
1867          Seconds => Nat (S),
1868          TS      => GNAT_Time);
1869
1870       return GNAT_Time;
1871    end OS_Time_To_GNAT_Time;
1872
1873    ------------------
1874    -- Program_Name --
1875    ------------------
1876
1877    function Program_Name (Nam : String) return String_Access is
1878       Res : String_Access;
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       --  Find the target prefix if any, for the cross compilation case.
1911       --  For instance in "alpha-dec-vxworks-gcc" the target prefix is
1912       --  "alpha-dec-vxworks-"
1913
1914       while Name_Len > 0  loop
1915
1916          --  All done if we find the last hyphen
1917
1918          if Name_Buffer (Name_Len) = '-' then
1919             exit;
1920
1921          --  If directory separator found, we don't want to look further
1922          --  since in this case, no prefix has been found.
1923
1924          elsif Is_Directory_Separator (Name_Buffer (Name_Len)) then
1925             Name_Len := 0;
1926             exit;
1927          end if;
1928
1929          Name_Len := Name_Len - 1;
1930       end loop;
1931
1932       --  Create the new program name
1933
1934       Res := new String (1 .. Name_Len + Nam'Length);
1935       Res.all (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1936       Res.all (Name_Len + 1 .. Name_Len + Nam'Length) := Nam;
1937       return Res;
1938    end Program_Name;
1939
1940    ------------------------------
1941    -- Read_Default_Search_Dirs --
1942    ------------------------------
1943
1944    function Read_Default_Search_Dirs
1945      (Search_Dir_Prefix       : String_Access;
1946       Search_File             : String_Access;
1947       Search_Dir_Default_Name : String_Access) return String_Access
1948    is
1949       Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
1950       Buffer     : String (1 .. Prefix_Len + Search_File.all'Length + 1);
1951       File_FD    : File_Descriptor;
1952       S, S1      : String_Access;
1953       Len        : Integer;
1954       Curr       : Integer;
1955       Actual_Len : Integer;
1956       J1         : Integer;
1957
1958       Prev_Was_Separator : Boolean;
1959       Nb_Relative_Dir    : Integer;
1960
1961       function Is_Relative (S : String; K : Positive) return Boolean;
1962       pragma Inline (Is_Relative);
1963       --  Returns True if a relative directory specification is found
1964       --  in S at position K, False otherwise.
1965
1966       -----------------
1967       -- Is_Relative --
1968       -----------------
1969
1970       function Is_Relative (S : String; K : Positive) return Boolean is
1971       begin
1972          return not Is_Absolute_Path (S (K .. S'Last));
1973       end Is_Relative;
1974
1975    --  Start of processing for Read_Default_Search_Dirs
1976
1977    begin
1978       --  Construct a C compatible character string buffer
1979
1980       Buffer (1 .. Search_Dir_Prefix.all'Length)
1981         := Search_Dir_Prefix.all;
1982       Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1)
1983         := Search_File.all;
1984       Buffer (Buffer'Last) := ASCII.NUL;
1985
1986       File_FD := Open_Read (Buffer'Address, Binary);
1987       if File_FD = Invalid_FD then
1988          return Search_Dir_Default_Name;
1989       end if;
1990
1991       Len := Integer (File_Length (File_FD));
1992
1993       --  An extra character for a trailing Path_Separator is allocated
1994
1995       S := new String (1 .. Len + 1);
1996       S (Len + 1) := Path_Separator;
1997
1998       --  Read the file. Note that the loop is not necessary since the
1999       --  whole file is read at once except on VMS.
2000
2001       Curr := 1;
2002       Actual_Len := Len;
2003       while Actual_Len /= 0 loop
2004          Actual_Len := Read (File_FD, S (Curr)'Address, Len);
2005          Curr := Curr + Actual_Len;
2006       end loop;
2007
2008       --  Process the file, dealing with path separators
2009
2010       Prev_Was_Separator := True;
2011       Nb_Relative_Dir := 0;
2012       for J in 1 .. Len loop
2013
2014          --  Treat any control character as a path separator. Note that we do
2015          --  not treat space as a path separator (we used to treat space as a
2016          --  path separator in an earlier version). That way space can appear
2017          --  as a legitimate character in a path name.
2018
2019          --  Why do we treat all control characters as path separators???
2020
2021          if S (J) in ASCII.NUL .. ASCII.US then
2022             S (J) := Path_Separator;
2023          end if;
2024
2025          --  Test for explicit path separator (or control char as above)
2026
2027          if S (J) = Path_Separator then
2028             Prev_Was_Separator := True;
2029
2030          --  If not path separator, register use of relative directory
2031
2032          else
2033             if Prev_Was_Separator and then Is_Relative (S.all, J) then
2034                Nb_Relative_Dir := Nb_Relative_Dir + 1;
2035             end if;
2036
2037             Prev_Was_Separator := False;
2038          end if;
2039       end loop;
2040
2041       if Nb_Relative_Dir = 0 then
2042          return S;
2043       end if;
2044
2045       --  Add the Search_Dir_Prefix to all relative paths
2046
2047       S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len);
2048       J1 := 1;
2049       Prev_Was_Separator := True;
2050       for J in 1 .. Len + 1 loop
2051          if S (J) = Path_Separator then
2052             Prev_Was_Separator := True;
2053
2054          else
2055             if Prev_Was_Separator and then Is_Relative (S.all, J) then
2056                S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all;
2057                J1 := J1 + Prefix_Len;
2058             end if;
2059
2060             Prev_Was_Separator := False;
2061          end if;
2062          S1 (J1) := S (J);
2063          J1 := J1 + 1;
2064       end loop;
2065
2066       Free (S);
2067       return S1;
2068    end Read_Default_Search_Dirs;
2069
2070    -----------------------
2071    -- Read_Library_Info --
2072    -----------------------
2073
2074    function Read_Library_Info
2075      (Lib_File  : File_Name_Type;
2076       Fatal_Err : Boolean := False) return Text_Buffer_Ptr
2077    is
2078       Lib_FD : File_Descriptor;
2079       --  The file descriptor for the current library file. A negative value
2080       --  indicates failure to open the specified source file.
2081
2082       Text : Text_Buffer_Ptr;
2083       --  Allocated text buffer
2084
2085       Status : Boolean;
2086       pragma Warnings (Off, Status);
2087       --  For the calls to Close
2088
2089    begin
2090       Current_Full_Lib_Name := Find_File (Lib_File, Library);
2091       Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name);
2092
2093       if Current_Full_Lib_Name = No_File then
2094          if Fatal_Err then
2095             Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
2096          else
2097             Current_Full_Obj_Stamp := Empty_Time_Stamp;
2098             return null;
2099          end if;
2100       end if;
2101
2102       Get_Name_String (Current_Full_Lib_Name);
2103       Name_Buffer (Name_Len + 1) := ASCII.NUL;
2104
2105       --  Open the library FD, note that we open in binary mode, because as
2106       --  documented in the spec, the caller is expected to handle either
2107       --  DOS or Unix mode files, and there is no point in wasting time on
2108       --  text translation when it is not required.
2109
2110       Lib_FD := Open_Read (Name_Buffer'Address, Binary);
2111
2112       if Lib_FD = Invalid_FD then
2113          if Fatal_Err then
2114             Fail ("Cannot open: ",  Name_Buffer (1 .. Name_Len));
2115          else
2116             Current_Full_Obj_Stamp := Empty_Time_Stamp;
2117             return null;
2118          end if;
2119       end if;
2120
2121       --  Check for object file consistency if requested
2122
2123       if Opt.Check_Object_Consistency then
2124          Current_Full_Lib_Stamp := File_Stamp (Current_Full_Lib_Name);
2125          Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name);
2126
2127          if Current_Full_Obj_Stamp (1) = ' ' then
2128
2129             --  When the library is readonly always assume object is consistent
2130
2131             if Is_Readonly_Library (Current_Full_Lib_Name) then
2132                Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
2133
2134             elsif Fatal_Err then
2135                Get_Name_String (Current_Full_Obj_Name);
2136                Close (Lib_FD, Status);
2137
2138                --  No need to check the status, we fail anyway
2139
2140                Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
2141
2142             else
2143                Current_Full_Obj_Stamp := Empty_Time_Stamp;
2144                Close (Lib_FD, Status);
2145
2146                --  No need to check the status, we return null anyway
2147
2148                return null;
2149             end if;
2150          end if;
2151       end if;
2152
2153       --  Read data from the file
2154
2155       declare
2156          Len : constant Integer := Integer (File_Length (Lib_FD));
2157          --  Length of source file text. If it doesn't fit in an integer
2158          --  we're probably stuck anyway (>2 gigs of source seems a lot!)
2159
2160          Actual_Len : Integer := 0;
2161
2162          Lo : constant Text_Ptr := 0;
2163          --  Low bound for allocated text buffer
2164
2165          Hi : Text_Ptr := Text_Ptr (Len);
2166          --  High bound for allocated text buffer. Note length is Len + 1
2167          --  which allows for extra EOF character at the end of the buffer.
2168
2169       begin
2170          --  Allocate text buffer. Note extra character at end for EOF
2171
2172          Text := new Text_Buffer (Lo .. Hi);
2173
2174          --  Some systems (e.g. VMS) have file types that require one
2175          --  read per line, so read until we get the Len bytes or until
2176          --  there are no more characters.
2177
2178          Hi := Lo;
2179          loop
2180             Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len);
2181             Hi := Hi + Text_Ptr (Actual_Len);
2182             exit when Actual_Len = Len or Actual_Len <= 0;
2183          end loop;
2184
2185          Text (Hi) := EOF;
2186       end;
2187
2188       --  Read is complete, close file and we are done
2189
2190       Close (Lib_FD, Status);
2191       --  The status should never be False. But, if it is, what can we do?
2192       --  So, we don't test it.
2193
2194       return Text;
2195
2196    end Read_Library_Info;
2197
2198    ----------------------
2199    -- Read_Source_File --
2200    ----------------------
2201
2202    procedure Read_Source_File
2203      (N   : File_Name_Type;
2204       Lo  : Source_Ptr;
2205       Hi  : out Source_Ptr;
2206       Src : out Source_Buffer_Ptr;
2207       T   : File_Type := Source)
2208    is
2209       Source_File_FD : File_Descriptor;
2210       --  The file descriptor for the current source file. A negative value
2211       --  indicates failure to open the specified source file.
2212
2213       Len : Integer;
2214       --  Length of file. Assume no more than 2 gigabytes of source!
2215
2216       Actual_Len : Integer;
2217
2218       Status : Boolean;
2219       pragma Warnings (Off, Status);
2220       --  For the call to Close
2221
2222    begin
2223       Current_Full_Source_Name  := Find_File (N, T);
2224       Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
2225
2226       if Current_Full_Source_Name = No_File then
2227
2228          --  If we were trying to access the main file and we could not find
2229          --  it, we have an error.
2230
2231          if N = Current_Main then
2232             Get_Name_String (N);
2233             Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
2234          end if;
2235
2236          Src := null;
2237          Hi  := No_Location;
2238          return;
2239       end if;
2240
2241       Get_Name_String (Current_Full_Source_Name);
2242       Name_Buffer (Name_Len + 1) := ASCII.NUL;
2243
2244       --  Open the source FD, note that we open in binary mode, because as
2245       --  documented in the spec, the caller is expected to handle either
2246       --  DOS or Unix mode files, and there is no point in wasting time on
2247       --  text translation when it is not required.
2248
2249       Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
2250
2251       if Source_File_FD = Invalid_FD then
2252          Src := null;
2253          Hi  := No_Location;
2254          return;
2255       end if;
2256
2257       --  Prepare to read data from the file
2258
2259       Len := Integer (File_Length (Source_File_FD));
2260
2261       --  Set Hi so that length is one more than the physical length,
2262       --  allowing for the extra EOF character at the end of the buffer
2263
2264       Hi := Lo + Source_Ptr (Len);
2265
2266       --  Do the actual read operation
2267
2268       declare
2269          subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
2270          --  Physical buffer allocated
2271
2272          type Actual_Source_Ptr is access Actual_Source_Buffer;
2273          --  This is the pointer type for the physical buffer allocated
2274
2275          Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
2276          --  And this is the actual physical buffer
2277
2278       begin
2279          --  Allocate source buffer, allowing extra character at end for EOF
2280
2281          --  Some systems (e.g. VMS) have file types that require one
2282          --  read per line, so read until we get the Len bytes or until
2283          --  there are no more characters.
2284
2285          Hi := Lo;
2286          loop
2287             Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
2288             Hi := Hi + Source_Ptr (Actual_Len);
2289             exit when Actual_Len = Len or Actual_Len <= 0;
2290          end loop;
2291
2292          Actual_Ptr (Hi) := EOF;
2293
2294          --  Now we need to work out the proper virtual origin pointer to
2295          --  return. This is exactly Actual_Ptr (0)'Address, but we have
2296          --  to be careful to suppress checks to compute this address.
2297
2298          declare
2299             pragma Suppress (All_Checks);
2300
2301             pragma Warnings (Off);
2302             --  This use of unchecked conversion is aliasing safe
2303
2304             function To_Source_Buffer_Ptr is new
2305               Unchecked_Conversion (Address, Source_Buffer_Ptr);
2306
2307             pragma Warnings (On);
2308
2309          begin
2310             Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
2311          end;
2312       end;
2313
2314       --  Read is complete, get time stamp and close file and we are done
2315
2316       Close (Source_File_FD, Status);
2317
2318       --  The status should never be False. But, if it is, what can we do?
2319       --  So, we don't test it.
2320
2321    end Read_Source_File;
2322
2323    -------------------
2324    -- Relocate_Path --
2325    -------------------
2326
2327    function Relocate_Path
2328      (Prefix : String;
2329       Path   : String) return String_Ptr
2330    is
2331       S : String_Ptr;
2332
2333       procedure set_std_prefix (S : String; Len : Integer);
2334       pragma Import (C, set_std_prefix);
2335
2336    begin
2337       if Std_Prefix = null then
2338          Std_Prefix := Executable_Prefix;
2339
2340          if Std_Prefix.all /= "" then
2341
2342             --  Remove trailing directory separator when calling set_std_prefix
2343
2344             set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1);
2345          end if;
2346       end if;
2347
2348       if Path (Prefix'Range) = Prefix then
2349          if Std_Prefix.all /= "" then
2350             S := new String
2351               (1 .. Std_Prefix'Length + Path'Last - Prefix'Last);
2352             S (1 .. Std_Prefix'Length) := Std_Prefix.all;
2353             S (Std_Prefix'Length + 1 .. S'Last) :=
2354               Path (Prefix'Last + 1 .. Path'Last);
2355             return S;
2356          end if;
2357       end if;
2358
2359       return new String'(Path);
2360    end Relocate_Path;
2361
2362    -----------------
2363    -- Set_Program --
2364    -----------------
2365
2366    procedure Set_Program (P : Program_Type) is
2367    begin
2368       if Program_Set then
2369          Fail ("Set_Program called twice");
2370       end if;
2371
2372       Program_Set := True;
2373       Running_Program := P;
2374    end Set_Program;
2375
2376    ----------------
2377    -- Shared_Lib --
2378    ----------------
2379
2380    function Shared_Lib (Name : String) return String is
2381       Library : String (1 .. Name'Length + Library_Version'Length + 3);
2382       --  3 = 2 for "-l" + 1 for "-" before lib version
2383
2384    begin
2385       Library (1 .. 2)                          := "-l";
2386       Library (3 .. 2 + Name'Length)            := Name;
2387       Library (3 + Name'Length)                 := '-';
2388       Library (4 + Name'Length .. Library'Last) := Library_Version;
2389
2390       if OpenVMS_On_Target then
2391          for K in Library'First + 2 .. Library'Last loop
2392             if Library (K) = '.' or else Library (K) = '-' then
2393                Library (K) := '_';
2394             end if;
2395          end loop;
2396       end if;
2397
2398       return Library;
2399    end Shared_Lib;
2400
2401    ----------------------
2402    -- Smart_File_Stamp --
2403    ----------------------
2404
2405    function Smart_File_Stamp
2406      (N : File_Name_Type;
2407       T : File_Type) return Time_Stamp_Type
2408    is
2409       Time_Stamp : Time_Stamp_Type;
2410
2411    begin
2412       if not File_Cache_Enabled then
2413          return File_Stamp (Find_File (N, T));
2414       end if;
2415
2416       Time_Stamp := File_Stamp_Hash_Table.Get (N);
2417
2418       if Time_Stamp (1) = ' ' then
2419          Time_Stamp := File_Stamp (Smart_Find_File (N, T));
2420          File_Stamp_Hash_Table.Set (N, Time_Stamp);
2421       end if;
2422
2423       return Time_Stamp;
2424    end Smart_File_Stamp;
2425
2426    ---------------------
2427    -- Smart_Find_File --
2428    ---------------------
2429
2430    function Smart_Find_File
2431      (N : File_Name_Type;
2432       T : File_Type) return File_Name_Type
2433    is
2434       Full_File_Name : File_Name_Type;
2435
2436    begin
2437       if not File_Cache_Enabled then
2438          return Find_File (N, T);
2439       end if;
2440
2441       Full_File_Name := File_Name_Hash_Table.Get (N);
2442
2443       if Full_File_Name = No_File then
2444          Full_File_Name := Find_File (N, T);
2445          File_Name_Hash_Table.Set (N, Full_File_Name);
2446       end if;
2447
2448       return Full_File_Name;
2449    end Smart_Find_File;
2450
2451    ----------------------
2452    -- Source_File_Data --
2453    ----------------------
2454
2455    procedure Source_File_Data (Cache : Boolean) is
2456    begin
2457       File_Cache_Enabled := Cache;
2458    end Source_File_Data;
2459
2460    -----------------------
2461    -- Source_File_Stamp --
2462    -----------------------
2463
2464    function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
2465    begin
2466       return Smart_File_Stamp (N, Source);
2467    end Source_File_Stamp;
2468
2469    ---------------------
2470    -- Strip_Directory --
2471    ---------------------
2472
2473    function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
2474    begin
2475       Get_Name_String (Name);
2476
2477       for J in reverse 1 .. Name_Len - 1 loop
2478
2479          --  If we find the last directory separator
2480
2481          if Is_Directory_Separator (Name_Buffer (J)) then
2482
2483             --  Return the part of Name that follows this last directory
2484             --  separator.
2485
2486             Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
2487             Name_Len := Name_Len - J;
2488             return Name_Find;
2489          end if;
2490       end loop;
2491
2492       --  There were no directory separator, just return Name
2493
2494       return Name;
2495    end Strip_Directory;
2496
2497    ------------------
2498    -- Strip_Suffix --
2499    ------------------
2500
2501    function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
2502    begin
2503       Get_Name_String (Name);
2504
2505       for J in reverse 2 .. Name_Len loop
2506
2507          --  If we found the last '.', return part of Name that precedes it
2508
2509          if Name_Buffer (J) = '.' then
2510             Name_Len := J - 1;
2511             return Name_Enter;
2512          end if;
2513       end loop;
2514
2515       return Name;
2516    end Strip_Suffix;
2517
2518    ---------------------------
2519    -- To_Canonical_Dir_Spec --
2520    ---------------------------
2521
2522    function To_Canonical_Dir_Spec
2523      (Host_Dir     : String;
2524       Prefix_Style : Boolean) return String_Access
2525    is
2526       function To_Canonical_Dir_Spec
2527         (Host_Dir    : Address;
2528          Prefix_Flag : Integer) return Address;
2529       pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
2530
2531       C_Host_Dir      : String (1 .. Host_Dir'Length + 1);
2532       Canonical_Dir_Addr : Address;
2533       Canonical_Dir_Len  : Integer;
2534
2535    begin
2536       C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir;
2537       C_Host_Dir (C_Host_Dir'Last)      := ASCII.NUL;
2538
2539       if Prefix_Style then
2540          Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1);
2541       else
2542          Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
2543       end if;
2544       Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);
2545
2546       if Canonical_Dir_Len = 0 then
2547          return null;
2548       else
2549          return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len);
2550       end if;
2551
2552    exception
2553       when others =>
2554          Fail ("erroneous directory spec: ", Host_Dir);
2555          return null;
2556    end To_Canonical_Dir_Spec;
2557
2558    ---------------------------
2559    -- To_Canonical_File_List --
2560    ---------------------------
2561
2562    function To_Canonical_File_List
2563      (Wildcard_Host_File : String;
2564       Only_Dirs          : Boolean) return String_Access_List_Access
2565    is
2566       function To_Canonical_File_List_Init
2567         (Host_File : Address;
2568          Only_Dirs : Integer) return Integer;
2569       pragma Import (C, To_Canonical_File_List_Init,
2570                      "__gnat_to_canonical_file_list_init");
2571
2572       function To_Canonical_File_List_Next return Address;
2573       pragma Import (C, To_Canonical_File_List_Next,
2574                      "__gnat_to_canonical_file_list_next");
2575
2576       procedure To_Canonical_File_List_Free;
2577       pragma Import (C, To_Canonical_File_List_Free,
2578                      "__gnat_to_canonical_file_list_free");
2579
2580       Num_Files            : Integer;
2581       C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
2582
2583    begin
2584       C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
2585         Wildcard_Host_File;
2586       C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
2587
2588       --  Do the expansion and say how many there are
2589
2590       Num_Files := To_Canonical_File_List_Init
2591          (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
2592
2593       declare
2594          Canonical_File_List : String_Access_List (1 .. Num_Files);
2595          Canonical_File_Addr : Address;
2596          Canonical_File_Len  : Integer;
2597
2598       begin
2599          --  Retrieve the expanded directory names and build the list
2600
2601          for J in 1 .. Num_Files loop
2602             Canonical_File_Addr := To_Canonical_File_List_Next;
2603             Canonical_File_Len  := C_String_Length (Canonical_File_Addr);
2604             Canonical_File_List (J) := To_Path_String_Access
2605                   (Canonical_File_Addr, Canonical_File_Len);
2606          end loop;
2607
2608          --  Free up the storage
2609
2610          To_Canonical_File_List_Free;
2611
2612          return new String_Access_List'(Canonical_File_List);
2613       end;
2614    end To_Canonical_File_List;
2615
2616    ----------------------------
2617    -- To_Canonical_File_Spec --
2618    ----------------------------
2619
2620    function To_Canonical_File_Spec
2621      (Host_File : String) return String_Access
2622    is
2623       function To_Canonical_File_Spec (Host_File : Address) return Address;
2624       pragma Import
2625         (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
2626
2627       C_Host_File         : String (1 .. Host_File'Length + 1);
2628       Canonical_File_Addr : Address;
2629       Canonical_File_Len  : Integer;
2630
2631    begin
2632       C_Host_File (1 .. Host_File'Length) := Host_File;
2633       C_Host_File (C_Host_File'Last)      := ASCII.NUL;
2634
2635       Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address);
2636       Canonical_File_Len  := C_String_Length (Canonical_File_Addr);
2637
2638       if Canonical_File_Len = 0 then
2639          return null;
2640       else
2641          return To_Path_String_Access
2642                   (Canonical_File_Addr, Canonical_File_Len);
2643       end if;
2644
2645    exception
2646       when others =>
2647          Fail ("erroneous file spec: ", Host_File);
2648          return null;
2649    end To_Canonical_File_Spec;
2650
2651    ----------------------------
2652    -- To_Canonical_Path_Spec --
2653    ----------------------------
2654
2655    function To_Canonical_Path_Spec
2656      (Host_Path : String) return String_Access
2657    is
2658       function To_Canonical_Path_Spec (Host_Path : Address) return Address;
2659       pragma Import
2660         (C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec");
2661
2662       C_Host_Path         : String (1 .. Host_Path'Length + 1);
2663       Canonical_Path_Addr : Address;
2664       Canonical_Path_Len  : Integer;
2665
2666    begin
2667       C_Host_Path (1 .. Host_Path'Length) := Host_Path;
2668       C_Host_Path (C_Host_Path'Last)      := ASCII.NUL;
2669
2670       Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address);
2671       Canonical_Path_Len  := C_String_Length (Canonical_Path_Addr);
2672
2673       --  Return a null string (vice a null) for zero length paths, for
2674       --  compatibility with getenv().
2675
2676       return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len);
2677
2678    exception
2679       when others =>
2680          Fail ("erroneous path spec: ", Host_Path);
2681          return null;
2682    end To_Canonical_Path_Spec;
2683
2684    ---------------------------
2685    -- To_Host_Dir_Spec --
2686    ---------------------------
2687
2688    function To_Host_Dir_Spec
2689      (Canonical_Dir : String;
2690       Prefix_Style  : Boolean) return String_Access
2691    is
2692       function To_Host_Dir_Spec
2693         (Canonical_Dir : Address;
2694          Prefix_Flag   : Integer) return Address;
2695       pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
2696
2697       C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
2698       Host_Dir_Addr   : Address;
2699       Host_Dir_Len    : Integer;
2700
2701    begin
2702       C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir;
2703       C_Canonical_Dir (C_Canonical_Dir'Last)      := ASCII.NUL;
2704
2705       if Prefix_Style then
2706          Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1);
2707       else
2708          Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0);
2709       end if;
2710       Host_Dir_Len := C_String_Length (Host_Dir_Addr);
2711
2712       if Host_Dir_Len = 0 then
2713          return null;
2714       else
2715          return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len);
2716       end if;
2717    end To_Host_Dir_Spec;
2718
2719    ----------------------------
2720    -- To_Host_File_Spec --
2721    ----------------------------
2722
2723    function To_Host_File_Spec
2724      (Canonical_File : String) return String_Access
2725    is
2726       function To_Host_File_Spec (Canonical_File : Address) return Address;
2727       pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
2728
2729       C_Canonical_File      : String (1 .. Canonical_File'Length + 1);
2730       Host_File_Addr : Address;
2731       Host_File_Len  : Integer;
2732
2733    begin
2734       C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File;
2735       C_Canonical_File (C_Canonical_File'Last)      := ASCII.NUL;
2736
2737       Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address);
2738       Host_File_Len  := C_String_Length (Host_File_Addr);
2739
2740       if Host_File_Len = 0 then
2741          return null;
2742       else
2743          return To_Path_String_Access
2744                   (Host_File_Addr, Host_File_Len);
2745       end if;
2746    end To_Host_File_Spec;
2747
2748    ---------------------------
2749    -- To_Path_String_Access --
2750    ---------------------------
2751
2752    function To_Path_String_Access
2753      (Path_Addr : Address;
2754       Path_Len  : Integer) return String_Access
2755    is
2756       subtype Path_String is String (1 .. Path_Len);
2757       type Path_String_Access is access Path_String;
2758
2759       function Address_To_Access is new
2760         Unchecked_Conversion (Source => Address,
2761                               Target => Path_String_Access);
2762
2763       Path_Access : constant Path_String_Access :=
2764                       Address_To_Access (Path_Addr);
2765
2766       Return_Val : String_Access;
2767
2768    begin
2769       Return_Val := new String (1 .. Path_Len);
2770
2771       for J in 1 .. Path_Len loop
2772          Return_Val (J) := Path_Access (J);
2773       end loop;
2774
2775       return Return_Val;
2776    end To_Path_String_Access;
2777
2778    -----------------
2779    -- Update_Path --
2780    -----------------
2781
2782    function Update_Path (Path : String_Ptr) return String_Ptr is
2783
2784       function C_Update_Path (Path, Component : Address) return Address;
2785       pragma Import (C, C_Update_Path, "update_path");
2786
2787       function Strlen (Str : Address) return Integer;
2788       pragma Import (C, Strlen, "strlen");
2789
2790       procedure Strncpy (X : Address; Y : Address; Length : Integer);
2791       pragma Import (C, Strncpy, "strncpy");
2792
2793       In_Length      : constant Integer := Path'Length;
2794       In_String      : String (1 .. In_Length + 1);
2795       Component_Name : aliased String := "GCC" & ASCII.NUL;
2796       Result_Ptr     : Address;
2797       Result_Length  : Integer;
2798       Out_String     : String_Ptr;
2799
2800    begin
2801       In_String (1 .. In_Length) := Path.all;
2802       In_String (In_Length + 1) := ASCII.NUL;
2803       Result_Ptr := C_Update_Path (In_String'Address, Component_Name'Address);
2804       Result_Length := Strlen (Result_Ptr);
2805
2806       Out_String := new String (1 .. Result_Length);
2807       Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
2808       return Out_String;
2809    end Update_Path;
2810
2811    ----------------
2812    -- Write_Info --
2813    ----------------
2814
2815    procedure Write_Info (Info : String) is
2816    begin
2817       Write_With_Check (Info'Address, Info'Length);
2818       Write_With_Check (EOL'Address, 1);
2819    end Write_Info;
2820
2821    ------------------------
2822    -- Write_Program_Name --
2823    ------------------------
2824
2825    procedure Write_Program_Name is
2826       Save_Buffer : constant String (1 .. Name_Len) :=
2827                       Name_Buffer (1 .. Name_Len);
2828
2829    begin
2830       Find_Program_Name;
2831
2832       --  Convert the name to lower case so error messages are the same on
2833       --  all systems.
2834
2835       for J in 1 .. Name_Len loop
2836          if Name_Buffer (J) in 'A' .. 'Z' then
2837             Name_Buffer (J) :=
2838               Character'Val (Character'Pos (Name_Buffer (J)) + 32);
2839          end if;
2840       end loop;
2841
2842       Write_Str (Name_Buffer (1 .. Name_Len));
2843
2844       --  Restore Name_Buffer which was clobbered by the call to
2845       --  Find_Program_Name
2846
2847       Name_Len := Save_Buffer'Last;
2848       Name_Buffer (1 .. Name_Len) := Save_Buffer;
2849    end Write_Program_Name;
2850
2851    ----------------------
2852    -- Write_With_Check --
2853    ----------------------
2854
2855    procedure Write_With_Check (A  : Address; N  : Integer) is
2856       Ignore : Boolean;
2857       pragma Warnings (Off, Ignore);
2858
2859    begin
2860       if N = Write (Output_FD, A, N) then
2861          return;
2862
2863       else
2864          Write_Str ("error: disk full writing ");
2865          Write_Name_Decoded (Output_File_Name);
2866          Write_Eol;
2867          Name_Len := Name_Len + 1;
2868          Name_Buffer (Name_Len) := ASCII.NUL;
2869          Delete_File (Name_Buffer'Address, Ignore);
2870          Exit_Program (E_Fatal);
2871       end if;
2872    end Write_With_Check;
2873
2874 ----------------------------
2875 -- Package Initialization --
2876 ----------------------------
2877
2878 begin
2879    Initialization : declare
2880
2881       function Get_Default_Identifier_Character_Set return Character;
2882       pragma Import (C, Get_Default_Identifier_Character_Set,
2883                        "__gnat_get_default_identifier_character_set");
2884       --  Function to determine the default identifier character set,
2885       --  which is system dependent. See Opt package spec for a list of
2886       --  the possible character codes and their interpretations.
2887
2888       function Get_Maximum_File_Name_Length return Int;
2889       pragma Import (C, Get_Maximum_File_Name_Length,
2890                     "__gnat_get_maximum_file_name_length");
2891       --  Function to get maximum file name length for system
2892
2893    begin
2894       Identifier_Character_Set := Get_Default_Identifier_Character_Set;
2895       Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
2896
2897       --  Following should be removed by having above function return
2898       --  Integer'Last as indication of no maximum instead of -1 ???
2899
2900       if Maximum_File_Name_Length = -1 then
2901          Maximum_File_Name_Length := Int'Last;
2902       end if;
2903
2904       Src_Search_Directories.Set_Last (Primary_Directory);
2905       Src_Search_Directories.Table (Primary_Directory) := new String'("");
2906
2907       Lib_Search_Directories.Set_Last (Primary_Directory);
2908       Lib_Search_Directories.Table (Primary_Directory) := new String'("");
2909
2910       Osint.Initialize;
2911    end Initialization;
2912
2913 end Osint;