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