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