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; Prog : String) return String_Access is
1878       End_Of_Prefix   : Natural := 0;
1879       Start_Of_Prefix : Positive := 1;
1880       Start_Of_Suffix : Positive;
1881
1882    begin
1883       --  GNAAMP tool names require special treatment
1884
1885       if AAMP_On_Target then
1886
1887          --  The name "gcc" is mapped to "gnaamp" (the compiler driver)
1888
1889          if Nam = "gcc" then
1890             return new String'("gnaamp");
1891
1892          --  Tool names starting with "gnat" are mapped by substituting the
1893          --  string "gnaamp" for "gnat" (for example, "gnatpp" => "gnaamppp").
1894
1895          elsif Nam'Length >= 4
1896            and then Nam (Nam'First .. Nam'First + 3) = "gnat"
1897          then
1898             return new String'("gnaamp" & Nam (Nam'First + 4 .. Nam'Last));
1899
1900          --  No other mapping rules, so we continue and handle any other forms
1901          --  of tool names the same as on other targets.
1902
1903          else
1904             null;
1905          end if;
1906       end if;
1907
1908       --  Get the name of the current program being executed
1909
1910       Find_Program_Name;
1911
1912       Start_Of_Suffix := Name_Len + 1;
1913
1914       --  Find the target prefix if any, for the cross compilation case.
1915       --  For instance in "powerpc-elf-gcc" the target prefix is
1916       --  "powerpc-elf-"
1917       --  Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1"
1918
1919       for J in reverse 1 .. Name_Len loop
1920          if Name_Buffer (J) = '/'
1921            or else Name_Buffer (J) = Directory_Separator
1922            or else Name_Buffer (J) = ':'
1923          then
1924             Start_Of_Prefix := J + 1;
1925             exit;
1926          end if;
1927       end loop;
1928
1929       --  Find End_Of_Prefix
1930
1931       for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop
1932          if Name_Buffer (J .. J + Prog'Length - 1) = Prog then
1933             End_Of_Prefix := J - 1;
1934             exit;
1935          end if;
1936       end loop;
1937
1938       if End_Of_Prefix > 1 then
1939          Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1;
1940       end if;
1941
1942       --  Create the new program name
1943
1944       return new String'
1945         (Name_Buffer (Start_Of_Prefix .. End_Of_Prefix)
1946          & Nam
1947          & Name_Buffer (Start_Of_Suffix .. Name_Len));
1948    end Program_Name;
1949
1950    ------------------------------
1951    -- Read_Default_Search_Dirs --
1952    ------------------------------
1953
1954    function Read_Default_Search_Dirs
1955      (Search_Dir_Prefix       : String_Access;
1956       Search_File             : String_Access;
1957       Search_Dir_Default_Name : String_Access) return String_Access
1958    is
1959       Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
1960       Buffer     : String (1 .. Prefix_Len + Search_File.all'Length + 1);
1961       File_FD    : File_Descriptor;
1962       S, S1      : String_Access;
1963       Len        : Integer;
1964       Curr       : Integer;
1965       Actual_Len : Integer;
1966       J1         : Integer;
1967
1968       Prev_Was_Separator : Boolean;
1969       Nb_Relative_Dir    : Integer;
1970
1971       function Is_Relative (S : String; K : Positive) return Boolean;
1972       pragma Inline (Is_Relative);
1973       --  Returns True if a relative directory specification is found
1974       --  in S at position K, False otherwise.
1975
1976       -----------------
1977       -- Is_Relative --
1978       -----------------
1979
1980       function Is_Relative (S : String; K : Positive) return Boolean is
1981       begin
1982          return not Is_Absolute_Path (S (K .. S'Last));
1983       end Is_Relative;
1984
1985    --  Start of processing for Read_Default_Search_Dirs
1986
1987    begin
1988       --  Construct a C compatible character string buffer
1989
1990       Buffer (1 .. Search_Dir_Prefix.all'Length)
1991         := Search_Dir_Prefix.all;
1992       Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1)
1993         := Search_File.all;
1994       Buffer (Buffer'Last) := ASCII.NUL;
1995
1996       File_FD := Open_Read (Buffer'Address, Binary);
1997       if File_FD = Invalid_FD then
1998          return Search_Dir_Default_Name;
1999       end if;
2000
2001       Len := Integer (File_Length (File_FD));
2002
2003       --  An extra character for a trailing Path_Separator is allocated
2004
2005       S := new String (1 .. Len + 1);
2006       S (Len + 1) := Path_Separator;
2007
2008       --  Read the file. Note that the loop is not necessary since the
2009       --  whole file is read at once except on VMS.
2010
2011       Curr := 1;
2012       Actual_Len := Len;
2013       while Actual_Len /= 0 loop
2014          Actual_Len := Read (File_FD, S (Curr)'Address, Len);
2015          Curr := Curr + Actual_Len;
2016       end loop;
2017
2018       --  Process the file, dealing with path separators
2019
2020       Prev_Was_Separator := True;
2021       Nb_Relative_Dir := 0;
2022       for J in 1 .. Len loop
2023
2024          --  Treat any control character as a path separator. Note that we do
2025          --  not treat space as a path separator (we used to treat space as a
2026          --  path separator in an earlier version). That way space can appear
2027          --  as a legitimate character in a path name.
2028
2029          --  Why do we treat all control characters as path separators???
2030
2031          if S (J) in ASCII.NUL .. ASCII.US then
2032             S (J) := Path_Separator;
2033          end if;
2034
2035          --  Test for explicit path separator (or control char as above)
2036
2037          if S (J) = Path_Separator then
2038             Prev_Was_Separator := True;
2039
2040          --  If not path separator, register use of relative directory
2041
2042          else
2043             if Prev_Was_Separator and then Is_Relative (S.all, J) then
2044                Nb_Relative_Dir := Nb_Relative_Dir + 1;
2045             end if;
2046
2047             Prev_Was_Separator := False;
2048          end if;
2049       end loop;
2050
2051       if Nb_Relative_Dir = 0 then
2052          return S;
2053       end if;
2054
2055       --  Add the Search_Dir_Prefix to all relative paths
2056
2057       S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len);
2058       J1 := 1;
2059       Prev_Was_Separator := True;
2060       for J in 1 .. Len + 1 loop
2061          if S (J) = Path_Separator then
2062             Prev_Was_Separator := True;
2063
2064          else
2065             if Prev_Was_Separator and then Is_Relative (S.all, J) then
2066                S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all;
2067                J1 := J1 + Prefix_Len;
2068             end if;
2069
2070             Prev_Was_Separator := False;
2071          end if;
2072          S1 (J1) := S (J);
2073          J1 := J1 + 1;
2074       end loop;
2075
2076       Free (S);
2077       return S1;
2078    end Read_Default_Search_Dirs;
2079
2080    -----------------------
2081    -- Read_Library_Info --
2082    -----------------------
2083
2084    function Read_Library_Info
2085      (Lib_File  : File_Name_Type;
2086       Fatal_Err : Boolean := False) return Text_Buffer_Ptr
2087    is
2088       Lib_FD : File_Descriptor;
2089       --  The file descriptor for the current library file. A negative value
2090       --  indicates failure to open the specified source file.
2091
2092       Text : Text_Buffer_Ptr;
2093       --  Allocated text buffer
2094
2095       Status : Boolean;
2096       pragma Warnings (Off, Status);
2097       --  For the calls to Close
2098
2099    begin
2100       Current_Full_Lib_Name := Find_File (Lib_File, Library);
2101       Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name);
2102
2103       if Current_Full_Lib_Name = No_File then
2104          if Fatal_Err then
2105             Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
2106          else
2107             Current_Full_Obj_Stamp := Empty_Time_Stamp;
2108             return null;
2109          end if;
2110       end if;
2111
2112       Get_Name_String (Current_Full_Lib_Name);
2113       Name_Buffer (Name_Len + 1) := ASCII.NUL;
2114
2115       --  Open the library FD, note that we open in binary mode, because as
2116       --  documented in the spec, the caller is expected to handle either
2117       --  DOS or Unix mode files, and there is no point in wasting time on
2118       --  text translation when it is not required.
2119
2120       Lib_FD := Open_Read (Name_Buffer'Address, Binary);
2121
2122       if Lib_FD = Invalid_FD then
2123          if Fatal_Err then
2124             Fail ("Cannot open: ",  Name_Buffer (1 .. Name_Len));
2125          else
2126             Current_Full_Obj_Stamp := Empty_Time_Stamp;
2127             return null;
2128          end if;
2129       end if;
2130
2131       --  Check for object file consistency if requested
2132
2133       if Opt.Check_Object_Consistency then
2134          Current_Full_Lib_Stamp := File_Stamp (Current_Full_Lib_Name);
2135          Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name);
2136
2137          if Current_Full_Obj_Stamp (1) = ' ' then
2138
2139             --  When the library is readonly always assume object is consistent
2140
2141             if Is_Readonly_Library (Current_Full_Lib_Name) then
2142                Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
2143
2144             elsif Fatal_Err then
2145                Get_Name_String (Current_Full_Obj_Name);
2146                Close (Lib_FD, Status);
2147
2148                --  No need to check the status, we fail anyway
2149
2150                Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
2151
2152             else
2153                Current_Full_Obj_Stamp := Empty_Time_Stamp;
2154                Close (Lib_FD, Status);
2155
2156                --  No need to check the status, we return null anyway
2157
2158                return null;
2159             end if;
2160          end if;
2161       end if;
2162
2163       --  Read data from the file
2164
2165       declare
2166          Len : constant Integer := Integer (File_Length (Lib_FD));
2167          --  Length of source file text. If it doesn't fit in an integer
2168          --  we're probably stuck anyway (>2 gigs of source seems a lot!)
2169
2170          Actual_Len : Integer := 0;
2171
2172          Lo : constant Text_Ptr := 0;
2173          --  Low bound for allocated text buffer
2174
2175          Hi : Text_Ptr := Text_Ptr (Len);
2176          --  High bound for allocated text buffer. Note length is Len + 1
2177          --  which allows for extra EOF character at the end of the buffer.
2178
2179       begin
2180          --  Allocate text buffer. Note extra character at end for EOF
2181
2182          Text := new Text_Buffer (Lo .. Hi);
2183
2184          --  Some systems (e.g. VMS) have file types that require one
2185          --  read per line, so read until we get the Len bytes or until
2186          --  there are no more characters.
2187
2188          Hi := Lo;
2189          loop
2190             Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len);
2191             Hi := Hi + Text_Ptr (Actual_Len);
2192             exit when Actual_Len = Len or Actual_Len <= 0;
2193          end loop;
2194
2195          Text (Hi) := EOF;
2196       end;
2197
2198       --  Read is complete, close file and we are done
2199
2200       Close (Lib_FD, Status);
2201       --  The status should never be False. But, if it is, what can we do?
2202       --  So, we don't test it.
2203
2204       return Text;
2205
2206    end Read_Library_Info;
2207
2208    ----------------------
2209    -- Read_Source_File --
2210    ----------------------
2211
2212    procedure Read_Source_File
2213      (N   : File_Name_Type;
2214       Lo  : Source_Ptr;
2215       Hi  : out Source_Ptr;
2216       Src : out Source_Buffer_Ptr;
2217       T   : File_Type := Source)
2218    is
2219       Source_File_FD : File_Descriptor;
2220       --  The file descriptor for the current source file. A negative value
2221       --  indicates failure to open the specified source file.
2222
2223       Len : Integer;
2224       --  Length of file. Assume no more than 2 gigabytes of source!
2225
2226       Actual_Len : Integer;
2227
2228       Status : Boolean;
2229       pragma Warnings (Off, Status);
2230       --  For the call to Close
2231
2232    begin
2233       Current_Full_Source_Name  := Find_File (N, T);
2234       Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
2235
2236       if Current_Full_Source_Name = No_File then
2237
2238          --  If we were trying to access the main file and we could not find
2239          --  it, we have an error.
2240
2241          if N = Current_Main then
2242             Get_Name_String (N);
2243             Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
2244          end if;
2245
2246          Src := null;
2247          Hi  := No_Location;
2248          return;
2249       end if;
2250
2251       Get_Name_String (Current_Full_Source_Name);
2252       Name_Buffer (Name_Len + 1) := ASCII.NUL;
2253
2254       --  Open the source FD, note that we open in binary mode, because as
2255       --  documented in the spec, the caller is expected to handle either
2256       --  DOS or Unix mode files, and there is no point in wasting time on
2257       --  text translation when it is not required.
2258
2259       Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
2260
2261       if Source_File_FD = Invalid_FD then
2262          Src := null;
2263          Hi  := No_Location;
2264          return;
2265       end if;
2266
2267       --  Prepare to read data from the file
2268
2269       Len := Integer (File_Length (Source_File_FD));
2270
2271       --  Set Hi so that length is one more than the physical length,
2272       --  allowing for the extra EOF character at the end of the buffer
2273
2274       Hi := Lo + Source_Ptr (Len);
2275
2276       --  Do the actual read operation
2277
2278       declare
2279          subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
2280          --  Physical buffer allocated
2281
2282          type Actual_Source_Ptr is access Actual_Source_Buffer;
2283          --  This is the pointer type for the physical buffer allocated
2284
2285          Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
2286          --  And this is the actual physical buffer
2287
2288       begin
2289          --  Allocate source buffer, allowing extra character at end for EOF
2290
2291          --  Some systems (e.g. VMS) have file types that require one
2292          --  read per line, so read until we get the Len bytes or until
2293          --  there are no more characters.
2294
2295          Hi := Lo;
2296          loop
2297             Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
2298             Hi := Hi + Source_Ptr (Actual_Len);
2299             exit when Actual_Len = Len or Actual_Len <= 0;
2300          end loop;
2301
2302          Actual_Ptr (Hi) := EOF;
2303
2304          --  Now we need to work out the proper virtual origin pointer to
2305          --  return. This is exactly Actual_Ptr (0)'Address, but we have
2306          --  to be careful to suppress checks to compute this address.
2307
2308          declare
2309             pragma Suppress (All_Checks);
2310
2311             pragma Warnings (Off);
2312             --  This use of unchecked conversion is aliasing safe
2313
2314             function To_Source_Buffer_Ptr is new
2315               Unchecked_Conversion (Address, Source_Buffer_Ptr);
2316
2317             pragma Warnings (On);
2318
2319          begin
2320             Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
2321          end;
2322       end;
2323
2324       --  Read is complete, get time stamp and close file and we are done
2325
2326       Close (Source_File_FD, Status);
2327
2328       --  The status should never be False. But, if it is, what can we do?
2329       --  So, we don't test it.
2330
2331    end Read_Source_File;
2332
2333    -------------------
2334    -- Relocate_Path --
2335    -------------------
2336
2337    function Relocate_Path
2338      (Prefix : String;
2339       Path   : String) return String_Ptr
2340    is
2341       S : String_Ptr;
2342
2343       procedure set_std_prefix (S : String; Len : Integer);
2344       pragma Import (C, set_std_prefix);
2345
2346    begin
2347       if Std_Prefix = null then
2348          Std_Prefix := Executable_Prefix;
2349
2350          if Std_Prefix.all /= "" then
2351
2352             --  Remove trailing directory separator when calling set_std_prefix
2353
2354             set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1);
2355          end if;
2356       end if;
2357
2358       if Path (Prefix'Range) = Prefix then
2359          if Std_Prefix.all /= "" then
2360             S := new String
2361               (1 .. Std_Prefix'Length + Path'Last - Prefix'Last);
2362             S (1 .. Std_Prefix'Length) := Std_Prefix.all;
2363             S (Std_Prefix'Length + 1 .. S'Last) :=
2364               Path (Prefix'Last + 1 .. Path'Last);
2365             return S;
2366          end if;
2367       end if;
2368
2369       return new String'(Path);
2370    end Relocate_Path;
2371
2372    -----------------
2373    -- Set_Program --
2374    -----------------
2375
2376    procedure Set_Program (P : Program_Type) is
2377    begin
2378       if Program_Set then
2379          Fail ("Set_Program called twice");
2380       end if;
2381
2382       Program_Set := True;
2383       Running_Program := P;
2384    end Set_Program;
2385
2386    ----------------
2387    -- Shared_Lib --
2388    ----------------
2389
2390    function Shared_Lib (Name : String) return String is
2391       Library : String (1 .. Name'Length + Library_Version'Length + 3);
2392       --  3 = 2 for "-l" + 1 for "-" before lib version
2393
2394    begin
2395       Library (1 .. 2)                          := "-l";
2396       Library (3 .. 2 + Name'Length)            := Name;
2397       Library (3 + Name'Length)                 := '-';
2398       Library (4 + Name'Length .. Library'Last) := Library_Version;
2399
2400       if OpenVMS_On_Target then
2401          for K in Library'First + 2 .. Library'Last loop
2402             if Library (K) = '.' or else Library (K) = '-' then
2403                Library (K) := '_';
2404             end if;
2405          end loop;
2406       end if;
2407
2408       return Library;
2409    end Shared_Lib;
2410
2411    ----------------------
2412    -- Smart_File_Stamp --
2413    ----------------------
2414
2415    function Smart_File_Stamp
2416      (N : File_Name_Type;
2417       T : File_Type) return Time_Stamp_Type
2418    is
2419       Time_Stamp : Time_Stamp_Type;
2420
2421    begin
2422       if not File_Cache_Enabled then
2423          return File_Stamp (Find_File (N, T));
2424       end if;
2425
2426       Time_Stamp := File_Stamp_Hash_Table.Get (N);
2427
2428       if Time_Stamp (1) = ' ' then
2429          Time_Stamp := File_Stamp (Smart_Find_File (N, T));
2430          File_Stamp_Hash_Table.Set (N, Time_Stamp);
2431       end if;
2432
2433       return Time_Stamp;
2434    end Smart_File_Stamp;
2435
2436    ---------------------
2437    -- Smart_Find_File --
2438    ---------------------
2439
2440    function Smart_Find_File
2441      (N : File_Name_Type;
2442       T : File_Type) return File_Name_Type
2443    is
2444       Full_File_Name : File_Name_Type;
2445
2446    begin
2447       if not File_Cache_Enabled then
2448          return Find_File (N, T);
2449       end if;
2450
2451       Full_File_Name := File_Name_Hash_Table.Get (N);
2452
2453       if Full_File_Name = No_File then
2454          Full_File_Name := Find_File (N, T);
2455          File_Name_Hash_Table.Set (N, Full_File_Name);
2456       end if;
2457
2458       return Full_File_Name;
2459    end Smart_Find_File;
2460
2461    ----------------------
2462    -- Source_File_Data --
2463    ----------------------
2464
2465    procedure Source_File_Data (Cache : Boolean) is
2466    begin
2467       File_Cache_Enabled := Cache;
2468    end Source_File_Data;
2469
2470    -----------------------
2471    -- Source_File_Stamp --
2472    -----------------------
2473
2474    function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
2475    begin
2476       return Smart_File_Stamp (N, Source);
2477    end Source_File_Stamp;
2478
2479    ---------------------
2480    -- Strip_Directory --
2481    ---------------------
2482
2483    function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
2484    begin
2485       Get_Name_String (Name);
2486
2487       for J in reverse 1 .. Name_Len - 1 loop
2488
2489          --  If we find the last directory separator
2490
2491          if Is_Directory_Separator (Name_Buffer (J)) then
2492
2493             --  Return the part of Name that follows this last directory
2494             --  separator.
2495
2496             Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
2497             Name_Len := Name_Len - J;
2498             return Name_Find;
2499          end if;
2500       end loop;
2501
2502       --  There were no directory separator, just return Name
2503
2504       return Name;
2505    end Strip_Directory;
2506
2507    ------------------
2508    -- Strip_Suffix --
2509    ------------------
2510
2511    function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
2512    begin
2513       Get_Name_String (Name);
2514
2515       for J in reverse 2 .. Name_Len loop
2516
2517          --  If we found the last '.', return part of Name that precedes it
2518
2519          if Name_Buffer (J) = '.' then
2520             Name_Len := J - 1;
2521             return Name_Enter;
2522          end if;
2523       end loop;
2524
2525       return Name;
2526    end Strip_Suffix;
2527
2528    ---------------------------
2529    -- To_Canonical_Dir_Spec --
2530    ---------------------------
2531
2532    function To_Canonical_Dir_Spec
2533      (Host_Dir     : String;
2534       Prefix_Style : Boolean) return String_Access
2535    is
2536       function To_Canonical_Dir_Spec
2537         (Host_Dir    : Address;
2538          Prefix_Flag : Integer) return Address;
2539       pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
2540
2541       C_Host_Dir      : String (1 .. Host_Dir'Length + 1);
2542       Canonical_Dir_Addr : Address;
2543       Canonical_Dir_Len  : Integer;
2544
2545    begin
2546       C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir;
2547       C_Host_Dir (C_Host_Dir'Last)      := ASCII.NUL;
2548
2549       if Prefix_Style then
2550          Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1);
2551       else
2552          Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
2553       end if;
2554       Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);
2555
2556       if Canonical_Dir_Len = 0 then
2557          return null;
2558       else
2559          return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len);
2560       end if;
2561
2562    exception
2563       when others =>
2564          Fail ("erroneous directory spec: ", Host_Dir);
2565          return null;
2566    end To_Canonical_Dir_Spec;
2567
2568    ---------------------------
2569    -- To_Canonical_File_List --
2570    ---------------------------
2571
2572    function To_Canonical_File_List
2573      (Wildcard_Host_File : String;
2574       Only_Dirs          : Boolean) return String_Access_List_Access
2575    is
2576       function To_Canonical_File_List_Init
2577         (Host_File : Address;
2578          Only_Dirs : Integer) return Integer;
2579       pragma Import (C, To_Canonical_File_List_Init,
2580                      "__gnat_to_canonical_file_list_init");
2581
2582       function To_Canonical_File_List_Next return Address;
2583       pragma Import (C, To_Canonical_File_List_Next,
2584                      "__gnat_to_canonical_file_list_next");
2585
2586       procedure To_Canonical_File_List_Free;
2587       pragma Import (C, To_Canonical_File_List_Free,
2588                      "__gnat_to_canonical_file_list_free");
2589
2590       Num_Files            : Integer;
2591       C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
2592
2593    begin
2594       C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
2595         Wildcard_Host_File;
2596       C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
2597
2598       --  Do the expansion and say how many there are
2599
2600       Num_Files := To_Canonical_File_List_Init
2601          (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
2602
2603       declare
2604          Canonical_File_List : String_Access_List (1 .. Num_Files);
2605          Canonical_File_Addr : Address;
2606          Canonical_File_Len  : Integer;
2607
2608       begin
2609          --  Retrieve the expanded directory names and build the list
2610
2611          for J in 1 .. Num_Files loop
2612             Canonical_File_Addr := To_Canonical_File_List_Next;
2613             Canonical_File_Len  := C_String_Length (Canonical_File_Addr);
2614             Canonical_File_List (J) := To_Path_String_Access
2615                   (Canonical_File_Addr, Canonical_File_Len);
2616          end loop;
2617
2618          --  Free up the storage
2619
2620          To_Canonical_File_List_Free;
2621
2622          return new String_Access_List'(Canonical_File_List);
2623       end;
2624    end To_Canonical_File_List;
2625
2626    ----------------------------
2627    -- To_Canonical_File_Spec --
2628    ----------------------------
2629
2630    function To_Canonical_File_Spec
2631      (Host_File : String) return String_Access
2632    is
2633       function To_Canonical_File_Spec (Host_File : Address) return Address;
2634       pragma Import
2635         (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
2636
2637       C_Host_File         : String (1 .. Host_File'Length + 1);
2638       Canonical_File_Addr : Address;
2639       Canonical_File_Len  : Integer;
2640
2641    begin
2642       C_Host_File (1 .. Host_File'Length) := Host_File;
2643       C_Host_File (C_Host_File'Last)      := ASCII.NUL;
2644
2645       Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address);
2646       Canonical_File_Len  := C_String_Length (Canonical_File_Addr);
2647
2648       if Canonical_File_Len = 0 then
2649          return null;
2650       else
2651          return To_Path_String_Access
2652                   (Canonical_File_Addr, Canonical_File_Len);
2653       end if;
2654
2655    exception
2656       when others =>
2657          Fail ("erroneous file spec: ", Host_File);
2658          return null;
2659    end To_Canonical_File_Spec;
2660
2661    ----------------------------
2662    -- To_Canonical_Path_Spec --
2663    ----------------------------
2664
2665    function To_Canonical_Path_Spec
2666      (Host_Path : String) return String_Access
2667    is
2668       function To_Canonical_Path_Spec (Host_Path : Address) return Address;
2669       pragma Import
2670         (C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec");
2671
2672       C_Host_Path         : String (1 .. Host_Path'Length + 1);
2673       Canonical_Path_Addr : Address;
2674       Canonical_Path_Len  : Integer;
2675
2676    begin
2677       C_Host_Path (1 .. Host_Path'Length) := Host_Path;
2678       C_Host_Path (C_Host_Path'Last)      := ASCII.NUL;
2679
2680       Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address);
2681       Canonical_Path_Len  := C_String_Length (Canonical_Path_Addr);
2682
2683       --  Return a null string (vice a null) for zero length paths, for
2684       --  compatibility with getenv().
2685
2686       return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len);
2687
2688    exception
2689       when others =>
2690          Fail ("erroneous path spec: ", Host_Path);
2691          return null;
2692    end To_Canonical_Path_Spec;
2693
2694    ---------------------------
2695    -- To_Host_Dir_Spec --
2696    ---------------------------
2697
2698    function To_Host_Dir_Spec
2699      (Canonical_Dir : String;
2700       Prefix_Style  : Boolean) return String_Access
2701    is
2702       function To_Host_Dir_Spec
2703         (Canonical_Dir : Address;
2704          Prefix_Flag   : Integer) return Address;
2705       pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
2706
2707       C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
2708       Host_Dir_Addr   : Address;
2709       Host_Dir_Len    : Integer;
2710
2711    begin
2712       C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir;
2713       C_Canonical_Dir (C_Canonical_Dir'Last)      := ASCII.NUL;
2714
2715       if Prefix_Style then
2716          Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1);
2717       else
2718          Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0);
2719       end if;
2720       Host_Dir_Len := C_String_Length (Host_Dir_Addr);
2721
2722       if Host_Dir_Len = 0 then
2723          return null;
2724       else
2725          return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len);
2726       end if;
2727    end To_Host_Dir_Spec;
2728
2729    ----------------------------
2730    -- To_Host_File_Spec --
2731    ----------------------------
2732
2733    function To_Host_File_Spec
2734      (Canonical_File : String) return String_Access
2735    is
2736       function To_Host_File_Spec (Canonical_File : Address) return Address;
2737       pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
2738
2739       C_Canonical_File      : String (1 .. Canonical_File'Length + 1);
2740       Host_File_Addr : Address;
2741       Host_File_Len  : Integer;
2742
2743    begin
2744       C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File;
2745       C_Canonical_File (C_Canonical_File'Last)      := ASCII.NUL;
2746
2747       Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address);
2748       Host_File_Len  := C_String_Length (Host_File_Addr);
2749
2750       if Host_File_Len = 0 then
2751          return null;
2752       else
2753          return To_Path_String_Access
2754                   (Host_File_Addr, Host_File_Len);
2755       end if;
2756    end To_Host_File_Spec;
2757
2758    ---------------------------
2759    -- To_Path_String_Access --
2760    ---------------------------
2761
2762    function To_Path_String_Access
2763      (Path_Addr : Address;
2764       Path_Len  : Integer) return String_Access
2765    is
2766       subtype Path_String is String (1 .. Path_Len);
2767       type Path_String_Access is access Path_String;
2768
2769       function Address_To_Access is new
2770         Unchecked_Conversion (Source => Address,
2771                               Target => Path_String_Access);
2772
2773       Path_Access : constant Path_String_Access :=
2774                       Address_To_Access (Path_Addr);
2775
2776       Return_Val : String_Access;
2777
2778    begin
2779       Return_Val := new String (1 .. Path_Len);
2780
2781       for J in 1 .. Path_Len loop
2782          Return_Val (J) := Path_Access (J);
2783       end loop;
2784
2785       return Return_Val;
2786    end To_Path_String_Access;
2787
2788    -----------------
2789    -- Update_Path --
2790    -----------------
2791
2792    function Update_Path (Path : String_Ptr) return String_Ptr is
2793
2794       function C_Update_Path (Path, Component : Address) return Address;
2795       pragma Import (C, C_Update_Path, "update_path");
2796
2797       function Strlen (Str : Address) return Integer;
2798       pragma Import (C, Strlen, "strlen");
2799
2800       procedure Strncpy (X : Address; Y : Address; Length : Integer);
2801       pragma Import (C, Strncpy, "strncpy");
2802
2803       In_Length      : constant Integer := Path'Length;
2804       In_String      : String (1 .. In_Length + 1);
2805       Component_Name : aliased String := "GCC" & ASCII.NUL;
2806       Result_Ptr     : Address;
2807       Result_Length  : Integer;
2808       Out_String     : String_Ptr;
2809
2810    begin
2811       In_String (1 .. In_Length) := Path.all;
2812       In_String (In_Length + 1) := ASCII.NUL;
2813       Result_Ptr := C_Update_Path (In_String'Address, Component_Name'Address);
2814       Result_Length := Strlen (Result_Ptr);
2815
2816       Out_String := new String (1 .. Result_Length);
2817       Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
2818       return Out_String;
2819    end Update_Path;
2820
2821    ----------------
2822    -- Write_Info --
2823    ----------------
2824
2825    procedure Write_Info (Info : String) is
2826    begin
2827       Write_With_Check (Info'Address, Info'Length);
2828       Write_With_Check (EOL'Address, 1);
2829    end Write_Info;
2830
2831    ------------------------
2832    -- Write_Program_Name --
2833    ------------------------
2834
2835    procedure Write_Program_Name is
2836       Save_Buffer : constant String (1 .. Name_Len) :=
2837                       Name_Buffer (1 .. Name_Len);
2838
2839    begin
2840       Find_Program_Name;
2841
2842       --  Convert the name to lower case so error messages are the same on
2843       --  all systems.
2844
2845       for J in 1 .. Name_Len loop
2846          if Name_Buffer (J) in 'A' .. 'Z' then
2847             Name_Buffer (J) :=
2848               Character'Val (Character'Pos (Name_Buffer (J)) + 32);
2849          end if;
2850       end loop;
2851
2852       Write_Str (Name_Buffer (1 .. Name_Len));
2853
2854       --  Restore Name_Buffer which was clobbered by the call to
2855       --  Find_Program_Name
2856
2857       Name_Len := Save_Buffer'Last;
2858       Name_Buffer (1 .. Name_Len) := Save_Buffer;
2859    end Write_Program_Name;
2860
2861    ----------------------
2862    -- Write_With_Check --
2863    ----------------------
2864
2865    procedure Write_With_Check (A  : Address; N  : Integer) is
2866       Ignore : Boolean;
2867       pragma Warnings (Off, Ignore);
2868
2869    begin
2870       if N = Write (Output_FD, A, N) then
2871          return;
2872
2873       else
2874          Write_Str ("error: disk full writing ");
2875          Write_Name_Decoded (Output_File_Name);
2876          Write_Eol;
2877          Name_Len := Name_Len + 1;
2878          Name_Buffer (Name_Len) := ASCII.NUL;
2879          Delete_File (Name_Buffer'Address, Ignore);
2880          Exit_Program (E_Fatal);
2881       end if;
2882    end Write_With_Check;
2883
2884 ----------------------------
2885 -- Package Initialization --
2886 ----------------------------
2887
2888 begin
2889    Initialization : declare
2890
2891       function Get_Default_Identifier_Character_Set return Character;
2892       pragma Import (C, Get_Default_Identifier_Character_Set,
2893                        "__gnat_get_default_identifier_character_set");
2894       --  Function to determine the default identifier character set,
2895       --  which is system dependent. See Opt package spec for a list of
2896       --  the possible character codes and their interpretations.
2897
2898       function Get_Maximum_File_Name_Length return Int;
2899       pragma Import (C, Get_Maximum_File_Name_Length,
2900                     "__gnat_get_maximum_file_name_length");
2901       --  Function to get maximum file name length for system
2902
2903    begin
2904       Identifier_Character_Set := Get_Default_Identifier_Character_Set;
2905       Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
2906
2907       --  Following should be removed by having above function return
2908       --  Integer'Last as indication of no maximum instead of -1 ???
2909
2910       if Maximum_File_Name_Length = -1 then
2911          Maximum_File_Name_Length := Int'Last;
2912       end if;
2913
2914       Src_Search_Directories.Set_Last (Primary_Directory);
2915       Src_Search_Directories.Table (Primary_Directory) := new String'("");
2916
2917       Lib_Search_Directories.Set_Last (Primary_Directory);
2918       Lib_Search_Directories.Table (Primary_Directory) := new String'("");
2919
2920       Osint.Initialize;
2921    end Initialization;
2922
2923 end Osint;