gcc/ada/osint.adb

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