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: 1.258 $
  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       if Hostparm.OpenVMS then
 729          Name_Buffer (Name_Len + 1 .. Name_Len + 3) := "_dg";
 730       else
 731          Name_Buffer (Name_Len + 1 .. Name_Len + 3) := ".dg";
 732       end if;
 733       Name_Len := Name_Len + 3;
 734       Result := Name_Find;
 735       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 736       Create_File_And_Check (Output_FD, Text);
 737       return Result;
 738    end Create_Debug_File;
 739
 740    ---------------------------
 741    -- Create_File_And_Check --
 742    ---------------------------
 743
 744    procedure Create_File_And_Check
 745      (Fdesc : out File_Descriptor;
 746       Fmode : Mode)
 747    is
 748    begin
 749       Output_File_Name := Name_Enter;
 750       Fdesc := Create_File (Name_Buffer'Address, Fmode);
 751
 752       if Fdesc = Invalid_FD then
 753          Fail ("Cannot create: ", Name_Buffer (1 .. Name_Len));
 754       end if;
 755    end Create_File_And_Check;
 756
 757    --------------------------------
 758    -- Create_Output_Library_Info --
 759    --------------------------------
 760
 761    procedure Create_Output_Library_Info is
 762    begin
 763       Set_Library_Info_Name;
 764       Create_File_And_Check (Output_FD, Text);
 765    end Create_Output_Library_Info;
 766
 767    --------------------------------
 768    -- Current_Library_File_Stamp --
 769    --------------------------------
 770
 771    function Current_Library_File_Stamp return Time_Stamp_Type is
 772    begin
 773       return Current_Full_Lib_Stamp;
 774    end Current_Library_File_Stamp;
 775
 776    -------------------------------
 777    -- Current_Object_File_Stamp --
 778    -------------------------------
 779
 780    function Current_Object_File_Stamp return Time_Stamp_Type is
 781    begin
 782       return Current_Full_Obj_Stamp;
 783    end Current_Object_File_Stamp;
 784
 785    -------------------------------
 786    -- Current_Source_File_Stamp --
 787    -------------------------------
 788
 789    function Current_Source_File_Stamp return Time_Stamp_Type is
 790    begin
 791       return Current_Full_Source_Stamp;
 792    end Current_Source_File_Stamp;
 793
 794    ---------------------------
 795    -- Debug_File_Eol_Length --
 796    ---------------------------
 797
 798    function Debug_File_Eol_Length return Nat is
 799    begin
 800       --  There has to be a cleaner way to do this! ???
 801
 802       if Directory_Separator = '/' then
 803          return 1;
 804       else
 805          return 2;
 806       end if;
 807    end Debug_File_Eol_Length;
 808
 809    ----------------------------
 810    -- Dir_In_Obj_Search_Path --
 811    ----------------------------
 812
 813    function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is
 814    begin
 815       if Opt.Look_In_Primary_Dir then
 816          return
 817            Lib_Search_Directories.Table (Primary_Directory + Position - 1);
 818       else
 819          return Lib_Search_Directories.Table (Primary_Directory + Position);
 820       end if;
 821    end Dir_In_Obj_Search_Path;
 822
 823    ----------------------------
 824    -- Dir_In_Src_Search_Path --
 825    ----------------------------
 826
 827    function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is
 828    begin
 829       if Opt.Look_In_Primary_Dir then
 830          return
 831            Src_Search_Directories.Table (Primary_Directory + Position - 1);
 832       else
 833          return Src_Search_Directories.Table (Primary_Directory + Position);
 834       end if;
 835    end Dir_In_Src_Search_Path;
 836
 837    ---------------------
 838    -- Executable_Name --
 839    ---------------------
 840
 841    function Executable_Name (Name : File_Name_Type) return File_Name_Type is
 842       Exec_Suffix : String_Access;
 843
 844    begin
 845       if Name = No_File then
 846          return No_File;
 847       end if;
 848
 849       Get_Name_String (Name);
 850       Exec_Suffix := Get_Executable_Suffix;
 851
 852       for J in Exec_Suffix.all'Range loop
 853          Name_Len := Name_Len + 1;
 854          Name_Buffer (Name_Len) := Exec_Suffix.all (J);
 855       end loop;
 856
 857       return Name_Enter;
 858    end Executable_Name;
 859
 860    ------------------
 861    -- Exit_Program --
 862    ------------------
 863
 864    procedure Exit_Program (Exit_Code : Exit_Code_Type) is
 865    begin
 866       --  The program will exit with the following status:
 867       --    0 if the object file has been generated (with or without warnings)
 868       --    1 if recompilation was not needed (smart recompilation)
 869       --    2 if gnat1 has been killed by a signal (detected by GCC)
 870       --    3 if no code has been generated (spec)
 871       --    4 for a fatal error
 872       --    5 if there were errors
 873
 874       case Exit_Code is
 875          when E_Success    => OS_Exit (0);
 876          when E_Warnings   => OS_Exit (0);
 877          when E_No_Compile => OS_Exit (1);
 878          when E_No_Code    => OS_Exit (3);
 879          when E_Fatal      => OS_Exit (4);
 880          when E_Errors     => OS_Exit (5);
 881          when E_Abort      => OS_Abort;
 882       end case;
 883    end Exit_Program;
 884
 885    ----------
 886    -- Fail --
 887    ----------
 888
 889    procedure Fail (S1 : String; S2 : String := ""; S3 : String := "") is
 890    begin
 891       Set_Standard_Error;
 892       Osint.Write_Program_Name;
 893       Write_Str (": ");
 894       Write_Str (S1);
 895       Write_Str (S2);
 896       Write_Str (S3);
 897       Write_Eol;
 898
 899       --  ??? Using Output is ugly, should do direct writes
 900       --  ??? shouldn't this go to standard error instead of stdout?
 901
 902       Exit_Program (E_Fatal);
 903    end Fail;
 904
 905    ---------------
 906    -- File_Hash --
 907    ---------------
 908
 909    function File_Hash (F : File_Name_Type) return File_Hash_Num is
 910    begin
 911       return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
 912    end File_Hash;
 913
 914    ----------------
 915    -- File_Stamp --
 916    ----------------
 917
 918    function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
 919    begin
 920       if Name = No_File then
 921          return Empty_Time_Stamp;
 922       end if;
 923
 924       Get_Name_String (Name);
 925
 926       if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
 927          return Empty_Time_Stamp;
 928       else
 929          Name_Buffer (Name_Len + 1) := ASCII.NUL;
 930          return OS_Time_To_GNAT_Time (File_Time_Stamp (Name_Buffer));
 931       end if;
 932    end File_Stamp;
 933
 934    ---------------
 935    -- Find_File --
 936    ---------------
 937
 938    function Find_File
 939      (N :    File_Name_Type;
 940       T :    File_Type)
 941       return File_Name_Type
 942    is
 943    begin
 944       Get_Name_String (N);
 945
 946       declare
 947          File_Name : String renames Name_Buffer (1 .. Name_Len);
 948          File      : File_Name_Type := No_File;
 949          Last_Dir  : Natural;
 950
 951       begin
 952          --  If we are looking for a config file, look only in the current
 953          --  directory, i.e. return input argument unchanged. Also look
 954          --  only in the current directory if we are looking for a .dg
 955          --  file (happens in -gnatD mode)
 956
 957          if T = Config
 958            or else (Debug_Generated_Code
 959                       and then Name_Len > 3
 960                       and then
 961                       (Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg"
 962                        or else
 963                        (Hostparm.OpenVMS and then
 964                         Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg")))
 965          then
 966             return N;
 967
 968          --  If we are trying to find the current main file just look in the
 969          --  directory where the user said it was.
 970
 971          elsif Look_In_Primary_Directory_For_Current_Main
 972            and then Current_Main = N then
 973             return Locate_File (N, T, Primary_Directory, File_Name);
 974
 975          --  Otherwise do standard search for source file
 976
 977          else
 978             --  First place to look is in the primary directory (i.e. the same
 979             --  directory as the source) unless this has been disabled with -I-
 980
 981             if Opt.Look_In_Primary_Dir then
 982                File := Locate_File (N, T, Primary_Directory, File_Name);
 983
 984                if File /= No_File then
 985                   return File;
 986                end if;
 987             end if;
 988
 989             --  Finally look in directories specified with switches -I/-aI/-aO
 990
 991             if T = Library then
 992                Last_Dir := Lib_Search_Directories.Last;
 993             else
 994                Last_Dir := Src_Search_Directories.Last;
 995             end if;
 996
 997             for D in Primary_Directory + 1 .. Last_Dir loop
 998                File := Locate_File (N, T, D, File_Name);
 999
1000                if File /= No_File then
1001                   return File;
1002                end if;
1003             end loop;
1004
1005             return No_File;
1006          end if;
1007       end;
1008    end Find_File;
1009
1010    -----------------------
1011    -- Find_Program_Name --
1012    -----------------------
1013
1014    procedure Find_Program_Name is
1015       Command_Name : String (1 .. Len_Arg (0));
1016       Cindex1 : Integer := Command_Name'First;
1017       Cindex2 : Integer := Command_Name'Last;
1018
1019    begin
1020       Fill_Arg (Command_Name'Address, 0);
1021
1022       --  The program name might be specified by a full path name. However,
1023       --  we don't want to print that all out in an error message, so the
1024       --  path might need to be stripped away.
1025
1026       for J in reverse Cindex1 .. Cindex2 loop
1027          if Is_Directory_Separator (Command_Name (J)) then
1028             Cindex1 := J + 1;
1029             exit;
1030          end if;
1031       end loop;
1032
1033       for J in reverse Cindex1 .. Cindex2 loop
1034          if Command_Name (J) = '.' then
1035             Cindex2 := J - 1;
1036             exit;
1037          end if;
1038       end loop;
1039
1040       Name_Len := Cindex2 - Cindex1 + 1;
1041       Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
1042    end Find_Program_Name;
1043
1044    ------------------------
1045    -- Full_Lib_File_Name --
1046    ------------------------
1047
1048    function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
1049    begin
1050       return Find_File (N, Library);
1051    end Full_Lib_File_Name;
1052
1053    ----------------------------
1054    -- Full_Library_Info_Name --
1055    ----------------------------
1056
1057    function Full_Library_Info_Name return File_Name_Type is
1058    begin
1059       return Current_Full_Lib_Name;
1060    end Full_Library_Info_Name;
1061
1062    ---------------------------
1063    -- Full_Object_File_Name --
1064    ---------------------------
1065
1066    function Full_Object_File_Name return File_Name_Type is
1067    begin
1068       return Current_Full_Obj_Name;
1069    end Full_Object_File_Name;
1070
1071    ----------------------
1072    -- Full_Source_Name --
1073    ----------------------
1074
1075    function Full_Source_Name return File_Name_Type is
1076    begin
1077       return Current_Full_Source_Name;
1078    end Full_Source_Name;
1079
1080    ----------------------
1081    -- Full_Source_Name --
1082    ----------------------
1083
1084    function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
1085    begin
1086       return Smart_Find_File (N, Source);
1087    end Full_Source_Name;
1088
1089    -------------------
1090    -- Get_Directory --
1091    -------------------
1092
1093    function Get_Directory (Name : File_Name_Type) return File_Name_Type is
1094    begin
1095       Get_Name_String (Name);
1096
1097       for J in reverse 1 .. Name_Len loop
1098          if Is_Directory_Separator (Name_Buffer (J)) then
1099             Name_Len := J;
1100             return Name_Find;
1101          end if;
1102       end loop;
1103
1104       Name_Len := Hostparm.Normalized_CWD'Length;
1105       Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
1106       return Name_Find;
1107    end Get_Directory;
1108
1109    --------------------------
1110    -- Get_Next_Dir_In_Path --
1111    --------------------------
1112
1113    Search_Path_Pos : Integer;
1114    --  Keeps track of current position in search path. Initialized by the
1115    --  call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
1116
1117    function Get_Next_Dir_In_Path
1118      (Search_Path : String_Access)
1119       return        String_Access
1120    is
1121       Lower_Bound : Positive := Search_Path_Pos;
1122       Upper_Bound : Positive;
1123
1124    begin
1125       loop
1126          while Lower_Bound <= Search_Path'Last
1127            and then Search_Path.all (Lower_Bound) = Path_Separator
1128          loop
1129             Lower_Bound := Lower_Bound + 1;
1130          end loop;
1131
1132          exit when Lower_Bound > Search_Path'Last;
1133
1134          Upper_Bound := Lower_Bound;
1135          while Upper_Bound <= Search_Path'Last
1136            and then Search_Path.all (Upper_Bound) /= Path_Separator
1137          loop
1138             Upper_Bound := Upper_Bound + 1;
1139          end loop;
1140
1141          Search_Path_Pos := Upper_Bound;
1142          return new String'(Search_Path.all (Lower_Bound .. Upper_Bound - 1));
1143       end loop;
1144
1145       return null;
1146    end Get_Next_Dir_In_Path;
1147
1148    -------------------------------
1149    -- Get_Next_Dir_In_Path_Init --
1150    -------------------------------
1151
1152    procedure Get_Next_Dir_In_Path_Init (Search_Path : String_Access) is
1153    begin
1154       Search_Path_Pos := Search_Path'First;
1155    end Get_Next_Dir_In_Path_Init;
1156
1157    --------------------------------------
1158    -- Get_Primary_Src_Search_Directory --
1159    --------------------------------------
1160
1161    function Get_Primary_Src_Search_Directory return String_Ptr is
1162    begin
1163       return Src_Search_Directories.Table (Primary_Directory);
1164    end Get_Primary_Src_Search_Directory;
1165
1166    ----------------
1167    -- Initialize --
1168    ----------------
1169
1170    procedure Initialize (P : Program_Type) is
1171       function Get_Default_Identifier_Character_Set return Character;
1172       pragma Import (C, Get_Default_Identifier_Character_Set,
1173                        "__gnat_get_default_identifier_character_set");
1174       --  Function to determine the default identifier character set,
1175       --  which is system dependent. See Opt package spec for a list of
1176       --  the possible character codes and their interpretations.
1177
1178       function Get_Maximum_File_Name_Length return Int;
1179       pragma Import (C, Get_Maximum_File_Name_Length,
1180                     "__gnat_get_maximum_file_name_length");
1181       --  Function to get maximum file name length for system
1182
1183       procedure Adjust_OS_Resource_Limits;
1184       pragma Import (C, Adjust_OS_Resource_Limits,
1185                         "__gnat_adjust_os_resource_limits");
1186       --  Procedure to make system specific adjustments to make GNAT
1187       --  run better.
1188
1189    --  Start of processing for Initialize
1190
1191    begin
1192       Program := P;
1193
1194       case Program is
1195          when Binder   => In_Binder   := True;
1196          when Compiler => In_Compiler := True;
1197          when Make     => In_Make     := True;
1198       end case;
1199
1200       if In_Compiler then
1201          Adjust_OS_Resource_Limits;
1202       end if;
1203
1204       Src_Search_Directories.Init;
1205       Lib_Search_Directories.Init;
1206
1207       Identifier_Character_Set := Get_Default_Identifier_Character_Set;
1208       Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
1209
1210       --  Following should be removed by having above function return
1211       --  Integer'Last as indication of no maximum instead of -1 ???
1212
1213       if Maximum_File_Name_Length = -1 then
1214          Maximum_File_Name_Length := Int'Last;
1215       end if;
1216
1217       --  Start off by setting all suppress options to False, these will
1218       --  be reset later (turning some on if -gnato is not specified, and
1219       --  turning all of them on if -gnatp is specified).
1220
1221       Suppress_Options := (others => False);
1222
1223       --  Set software overflow check flag. For now all targets require the
1224       --  use of software overflow checks. Later on, this will have to be
1225       --  specialized to the backend target. Also, if software overflow
1226       --  checking mode is set, then the default for suppressing overflow
1227       --  checks is True, since the software approach is expensive.
1228
1229       Software_Overflow_Checking := True;
1230       Suppress_Options.Overflow_Checks := True;
1231
1232       --  Reserve the first slot in the search paths table. This is the
1233       --  directory of the main source file or main library file and is
1234       --  filled in by each call to Next_Main_Source/Next_Main_Lib_File with
1235       --  the directory specified for this main source or library file. This
1236       --  is the directory which is searched first by default. This default
1237       --  search is inhibited by the option -I- for both source and library
1238       --  files.
1239
1240       Src_Search_Directories.Set_Last (Primary_Directory);
1241       Src_Search_Directories.Table (Primary_Directory) := new String'("");
1242
1243       Lib_Search_Directories.Set_Last (Primary_Directory);
1244       Lib_Search_Directories.Table (Primary_Directory) := new String'("");
1245
1246    end Initialize;
1247
1248    ----------------------------
1249    -- Is_Directory_Separator --
1250    ----------------------------
1251
1252    function Is_Directory_Separator (C : Character) return Boolean is
1253    begin
1254       --  In addition to the default directory_separator allow the '/' to
1255       --  act as separator since this is allowed in MS-DOS, Windows 95/NT,
1256       --  and OS2 ports. On VMS, the situation is more complicated because
1257       --  there are two characters to check for.
1258
1259       return
1260         C = Directory_Separator
1261           or else C = '/'
1262           or else (Hostparm.OpenVMS
1263                     and then (C = ']' or else C = ':'));
1264    end Is_Directory_Separator;
1265
1266    -------------------------
1267    -- Is_Readonly_Library --
1268    -------------------------
1269
1270    function Is_Readonly_Library (File : in File_Name_Type) return Boolean is
1271    begin
1272       Get_Name_String (File);
1273
1274       pragma Assert (Name_Buffer (Name_Len - 3 .. Name_Len) = ".ali");
1275
1276       return not Is_Writable_File (Name_Buffer (1 .. Name_Len));
1277    end Is_Readonly_Library;
1278
1279    -------------------
1280    -- Lib_File_Name --
1281    -------------------
1282
1283    function Lib_File_Name
1284      (Source_File : File_Name_Type)
1285       return        File_Name_Type
1286    is
1287       Fptr : Natural;
1288       --  Pointer to location to set extension in place
1289
1290    begin
1291       Get_Name_String (Source_File);
1292       Fptr := Name_Len + 1;
1293
1294       for J in reverse 1 .. Name_Len loop
1295          if Name_Buffer (J) = '.' then
1296             Fptr := J;
1297             exit;
1298          end if;
1299       end loop;
1300
1301       Name_Buffer (Fptr) := '.';
1302       Name_Buffer (Fptr + 1 .. Fptr + ALI_Suffix'Length) := ALI_Suffix.all;
1303       Name_Buffer (Fptr + ALI_Suffix'Length + 1) := ASCII.NUL;
1304       Name_Len := Fptr + ALI_Suffix'Length;
1305       return Name_Find;
1306    end Lib_File_Name;
1307
1308    ------------------------
1309    -- Library_File_Stamp --
1310    ------------------------
1311
1312    function Library_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
1313    begin
1314       return File_Stamp (Find_File (N, Library));
1315    end Library_File_Stamp;
1316
1317    -----------------
1318    -- Locate_File --
1319    -----------------
1320
1321    function Locate_File
1322      (N    : File_Name_Type;
1323       T    : File_Type;
1324       Dir  : Natural;
1325       Name : String)
1326       return File_Name_Type
1327    is
1328       Dir_Name : String_Ptr;
1329
1330    begin
1331       if T = Library then
1332          Dir_Name := Lib_Search_Directories.Table (Dir);
1333
1334       else pragma Assert (T = Source);
1335          Dir_Name := Src_Search_Directories.Table (Dir);
1336       end if;
1337
1338       declare
1339          Full_Name : String (1 .. Dir_Name'Length + Name'Length);
1340
1341       begin
1342          Full_Name (1 .. Dir_Name'Length) := Dir_Name.all;
1343          Full_Name (Dir_Name'Length + 1 .. Full_Name'Length) := Name;
1344
1345          if not Is_Regular_File (Full_Name) then
1346             return No_File;
1347
1348          else
1349             --  If the file is in the current directory then return N itself
1350
1351             if Dir_Name'Length = 0 then
1352                return N;
1353             else
1354                Name_Len := Full_Name'Length;
1355                Name_Buffer (1 .. Name_Len) := Full_Name;
1356                return Name_Enter;
1357             end if;
1358          end if;
1359       end;
1360    end Locate_File;
1361
1362    -------------------------------
1363    -- Matching_Full_Source_Name --
1364    -------------------------------
1365
1366    function Matching_Full_Source_Name
1367      (N    : File_Name_Type;
1368       T    : Time_Stamp_Type)
1369       return File_Name_Type
1370    is
1371    begin
1372       Get_Name_String (N);
1373
1374       declare
1375          File_Name : constant String := Name_Buffer (1 .. Name_Len);
1376          File      : File_Name_Type := No_File;
1377          Last_Dir  : Natural;
1378
1379       begin
1380          if Opt.Look_In_Primary_Dir then
1381             File := Locate_File (N, Source, Primary_Directory, File_Name);
1382
1383             if File /= No_File and then T = File_Stamp (N) then
1384                return File;
1385             end if;
1386          end if;
1387
1388          Last_Dir := Src_Search_Directories.Last;
1389
1390          for D in Primary_Directory + 1 .. Last_Dir loop
1391             File := Locate_File (N, Source, D, File_Name);
1392
1393             if File /= No_File and then T = File_Stamp (File) then
1394                return File;
1395             end if;
1396          end loop;
1397
1398          return No_File;
1399       end;
1400    end Matching_Full_Source_Name;
1401
1402    ----------------
1403    -- More_Files --
1404    ----------------
1405
1406    function More_Files return Boolean is
1407    begin
1408       return (Current_File_Name_Index < Number_File_Names);
1409    end More_Files;
1410
1411    --------------------
1412    -- More_Lib_Files --
1413    --------------------
1414
1415    function More_Lib_Files return Boolean is
1416    begin
1417       pragma Assert (In_Binder);
1418       return More_Files;
1419    end More_Lib_Files;
1420
1421    -----------------------
1422    -- More_Source_Files --
1423    -----------------------
1424
1425    function More_Source_Files return Boolean is
1426    begin
1427       pragma Assert (In_Compiler or else In_Make);
1428       return More_Files;
1429    end More_Source_Files;
1430
1431    -------------------------------
1432    -- Nb_Dir_In_Obj_Search_Path --
1433    -------------------------------
1434
1435    function Nb_Dir_In_Obj_Search_Path return Natural is
1436    begin
1437       if Opt.Look_In_Primary_Dir then
1438          return Lib_Search_Directories.Last -  Primary_Directory + 1;
1439       else
1440          return Lib_Search_Directories.Last -  Primary_Directory;
1441       end if;
1442    end Nb_Dir_In_Obj_Search_Path;
1443
1444    -------------------------------
1445    -- Nb_Dir_In_Src_Search_Path --
1446    -------------------------------
1447
1448    function Nb_Dir_In_Src_Search_Path return Natural is
1449    begin
1450       if Opt.Look_In_Primary_Dir then
1451          return Src_Search_Directories.Last -  Primary_Directory + 1;
1452       else
1453          return Src_Search_Directories.Last -  Primary_Directory;
1454       end if;
1455    end Nb_Dir_In_Src_Search_Path;
1456
1457    --------------------
1458    -- Next_Main_File --
1459    --------------------
1460
1461    function Next_Main_File return File_Name_Type is
1462       File_Name : String_Ptr;
1463       Dir_Name  : String_Ptr;
1464       Fptr      : Natural;
1465
1466    begin
1467       pragma Assert (More_Files);
1468
1469       Current_File_Name_Index := Current_File_Name_Index + 1;
1470
1471       --  Get the file and directory name
1472
1473       File_Name := File_Names (Current_File_Name_Index);
1474       Fptr := File_Name'First;
1475
1476       for J in reverse File_Name'Range loop
1477          if File_Name (J) = Directory_Separator
1478            or else File_Name (J) = '/'
1479          then
1480             if J = File_Name'Last then
1481                Fail ("File name missing");
1482             end if;
1483
1484             Fptr := J + 1;
1485             exit;
1486          end if;
1487       end loop;
1488
1489       --  Save name of directory in which main unit resides for use in
1490       --  locating other units
1491
1492       Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1));
1493
1494       if In_Compiler then
1495          Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1496          Look_In_Primary_Directory_For_Current_Main := True;
1497
1498       elsif In_Make then
1499          Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1500          if Fptr > File_Name'First then
1501             Look_In_Primary_Directory_For_Current_Main := True;
1502          end if;
1503
1504       else pragma Assert (In_Binder);
1505          Dir_Name := Normalize_Directory_Name (Dir_Name.all);
1506          Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
1507       end if;
1508
1509       Name_Len := File_Name'Last - Fptr + 1;
1510       Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
1511       Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1512       Current_Main := File_Name_Type (Name_Find);
1513
1514       --  In the gnatmake case, the main file may have not have the
1515       --  extension. Try ".adb" first then ".ads"
1516
1517       if In_Make then
1518          declare
1519             Orig_Main : File_Name_Type := Current_Main;
1520
1521          begin
1522             if Strip_Suffix (Orig_Main) = Orig_Main then
1523                Current_Main := Append_Suffix_To_File_Name (Orig_Main, ".adb");
1524
1525                if Full_Source_Name (Current_Main) = No_File then
1526                   Current_Main :=
1527                     Append_Suffix_To_File_Name (Orig_Main, ".ads");
1528
1529                   if Full_Source_Name (Current_Main) = No_File then
1530                      Current_Main := Orig_Main;
1531                   end if;
1532                end if;
1533             end if;
1534          end;
1535       end if;
1536
1537       return Current_Main;
1538    end Next_Main_File;
1539
1540    ------------------------
1541    -- Next_Main_Lib_File --
1542    ------------------------
1543
1544    function Next_Main_Lib_File return File_Name_Type is
1545    begin
1546       pragma Assert (In_Binder);
1547       return Next_Main_File;
1548    end Next_Main_Lib_File;
1549
1550    ----------------------
1551    -- Next_Main_Source --
1552    ----------------------
1553
1554    function Next_Main_Source return File_Name_Type is
1555       Main_File : File_Name_Type := Next_Main_File;
1556
1557    begin
1558       pragma Assert (In_Compiler or else In_Make);
1559       return Main_File;
1560    end Next_Main_Source;
1561
1562    ------------------------------
1563    -- Normalize_Directory_Name --
1564    ------------------------------
1565
1566    function Normalize_Directory_Name (Directory : String) return String_Ptr is
1567       Result : String_Ptr;
1568
1569    begin
1570       if Directory'Length = 0 then
1571          Result := new String'(Hostparm.Normalized_CWD);
1572
1573       elsif Is_Directory_Separator (Directory (Directory'Last)) then
1574          Result := new String'(Directory);
1575       else
1576          Result := new String (1 .. Directory'Length + 1);
1577          Result (1 .. Directory'Length) := Directory;
1578          Result (Directory'Length + 1) := Directory_Separator;
1579       end if;
1580
1581       return Result;
1582    end Normalize_Directory_Name;
1583
1584    ---------------------
1585    -- Number_Of_Files --
1586    ---------------------
1587
1588    function Number_Of_Files return Int is
1589    begin
1590       return Number_File_Names;
1591    end Number_Of_Files;
1592
1593    ----------------------
1594    -- Object_File_Name --
1595    ----------------------
1596
1597    function Object_File_Name (N : File_Name_Type) return File_Name_Type is
1598    begin
1599       if N = No_File then
1600          return No_File;
1601       end if;
1602
1603       Get_Name_String (N);
1604       Name_Len := Name_Len - ALI_Suffix'Length - 1;
1605
1606       for J in Object_Suffix'Range loop
1607          Name_Len := Name_Len + 1;
1608          Name_Buffer (Name_Len) := Object_Suffix (J);
1609       end loop;
1610
1611       return Name_Enter;
1612    end Object_File_Name;
1613
1614    --------------------------
1615    -- OS_Time_To_GNAT_Time --
1616    --------------------------
1617
1618    function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
1619       GNAT_Time : Time_Stamp_Type;
1620
1621       Y  : Year_Type;
1622       Mo : Month_Type;
1623       D  : Day_Type;
1624       H  : Hour_Type;
1625       Mn : Minute_Type;
1626       S  : Second_Type;
1627
1628    begin
1629       GM_Split (T, Y, Mo, D, H, Mn, S);
1630       Make_Time_Stamp
1631         (Year    => Nat (Y),
1632          Month   => Nat (Mo),
1633          Day     => Nat (D),
1634          Hour    => Nat (H),
1635          Minutes => Nat (Mn),
1636          Seconds => Nat (S),
1637          TS      => GNAT_Time);
1638
1639       return GNAT_Time;
1640    end OS_Time_To_GNAT_Time;
1641
1642    ------------------
1643    -- Program_Name --
1644    ------------------
1645
1646    function Program_Name (Nam : String) return String_Access is
1647       Res : String_Access;
1648
1649    begin
1650       --  Get the name of the current program being executed
1651
1652       Find_Program_Name;
1653
1654       --  Find the target prefix if any, for the cross compilation case
1655       --  for instance in "alpha-dec-vxworks-gcc" the target prefix is
1656       --  "alpha-dec-vxworks-"
1657
1658       while Name_Len > 0  loop
1659          if Name_Buffer (Name_Len) = '-' then
1660             exit;
1661          end if;
1662
1663          Name_Len := Name_Len - 1;
1664       end loop;
1665
1666       --  Create the new program name
1667
1668       Res := new String (1 .. Name_Len + Nam'Length);
1669       Res.all (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1670       Res.all (Name_Len + 1 .. Name_Len + Nam'Length) := Nam;
1671       return Res;
1672    end Program_Name;
1673
1674    ------------------------------
1675    -- Read_Default_Search_Dirs --
1676    ------------------------------
1677
1678    function Read_Default_Search_Dirs
1679      (Search_Dir_Prefix : String_Access;
1680       Search_File : String_Access;
1681       Search_Dir_Default_Name : String_Access)
1682      return String_Access
1683    is
1684       Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
1685       Buffer     : String (1 .. Prefix_Len + Search_File.all'Length + 1);
1686       File_FD    : File_Descriptor;
1687       S, S1      : String_Access;
1688       Len        : Integer;
1689       Curr       : Integer;
1690       Actual_Len : Integer;
1691       J1         : Integer;
1692
1693       Prev_Was_Separator : Boolean;
1694       Nb_Relative_Dir    : Integer;
1695
1696    begin
1697
1698       --  Construct a C compatible character string buffer.
1699
1700       Buffer (1 .. Search_Dir_Prefix.all'Length)
1701         := Search_Dir_Prefix.all;
1702       Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1)
1703         := Search_File.all;
1704       Buffer (Buffer'Last) := ASCII.NUL;
1705
1706       File_FD := Open_Read (Buffer'Address, Binary);
1707       if File_FD = Invalid_FD then
1708          return Search_Dir_Default_Name;
1709       end if;
1710
1711       Len := Integer (File_Length (File_FD));
1712
1713       --  An extra character for a trailing Path_Separator is allocated
1714
1715       S := new String (1 .. Len + 1);
1716       S (Len + 1) := Path_Separator;
1717
1718       --  Read the file. Note that the loop is not necessary since the
1719       --  whole file is read at once except on VMS.
1720
1721       Curr := 1;
1722       Actual_Len := Len;
1723       while Actual_Len /= 0 loop
1724          Actual_Len := Read (File_FD, S (Curr)'Address, Len);
1725          Curr := Curr + Actual_Len;
1726       end loop;
1727
1728       --  Process the file, translating line and file ending
1729       --  control characters to a path separator character.
1730
1731       Prev_Was_Separator := True;
1732       Nb_Relative_Dir := 0;
1733       for J in 1 .. Len loop
1734          if S (J) in ASCII.NUL .. ASCII.US
1735            or else S (J) = ' '
1736          then
1737             S (J) := Path_Separator;
1738          end if;
1739
1740          if  S (J) = Path_Separator then
1741             Prev_Was_Separator := True;
1742          else
1743             if Prev_Was_Separator and S (J) /= Directory_Separator then
1744                Nb_Relative_Dir := Nb_Relative_Dir + 1;
1745             end if;
1746             Prev_Was_Separator := False;
1747          end if;
1748       end loop;
1749
1750       if Nb_Relative_Dir = 0 then
1751          return S;
1752       end if;
1753
1754       --  Add the Search_Dir_Prefix to all relative paths
1755
1756       S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len);
1757       J1 := 1;
1758       Prev_Was_Separator := True;
1759       for J in 1 .. Len + 1 loop
1760          if  S (J) = Path_Separator then
1761             Prev_Was_Separator := True;
1762
1763          else
1764             if Prev_Was_Separator and S (J) /= Directory_Separator then
1765                S1 (J1 .. J1 + Prefix_Len) := Search_Dir_Prefix.all;
1766                J1 := J1 + Prefix_Len;
1767             end if;
1768
1769             Prev_Was_Separator := False;
1770          end if;
1771          S1 (J1) := S (J);
1772          J1 := J1 + 1;
1773       end loop;
1774
1775       Free (S);
1776       return S1;
1777    end Read_Default_Search_Dirs;
1778
1779    -----------------------
1780    -- Read_Library_Info --
1781    -----------------------
1782
1783    function Read_Library_Info
1784      (Lib_File  : File_Name_Type;
1785       Fatal_Err : Boolean := False)
1786       return      Text_Buffer_Ptr
1787    is
1788       Lib_FD : File_Descriptor;
1789       --  The file descriptor for the current library file. A negative value
1790       --  indicates failure to open the specified source file.
1791
1792       Text : Text_Buffer_Ptr;
1793       --  Allocated text buffer.
1794
1795    begin
1796       Current_Full_Lib_Name := Find_File (Lib_File, Library);
1797       Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name);
1798
1799       if Current_Full_Lib_Name = No_File then
1800          if Fatal_Err then
1801             Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
1802          else
1803             Current_Full_Obj_Stamp := Empty_Time_Stamp;
1804             return null;
1805          end if;
1806       end if;
1807
1808       Get_Name_String (Current_Full_Lib_Name);
1809       Name_Buffer (Name_Len + 1) := ASCII.NUL;
1810
1811       --  Open the library FD, note that we open in binary mode, because as
1812       --  documented in the spec, the caller is expected to handle either
1813       --  DOS or Unix mode files, and there is no point in wasting time on
1814       --  text translation when it is not required.
1815
1816       Lib_FD := Open_Read (Name_Buffer'Address, Binary);
1817
1818       if Lib_FD = Invalid_FD then
1819          if Fatal_Err then
1820             Fail ("Cannot open: ",  Name_Buffer (1 .. Name_Len));
1821          else
1822             Current_Full_Obj_Stamp := Empty_Time_Stamp;
1823             return null;
1824          end if;
1825       end if;
1826
1827       --  Check for object file consistency if requested
1828
1829       if Opt.Check_Object_Consistency then
1830          Current_Full_Lib_Stamp := File_Stamp (Current_Full_Lib_Name);
1831          Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name);
1832
1833          if Current_Full_Obj_Stamp (1) = ' ' then
1834
1835             --  When the library is readonly, always assume that
1836             --  the object is consistent.
1837
1838             if Is_Readonly_Library (Current_Full_Lib_Name) then
1839                Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
1840
1841             elsif Fatal_Err then
1842                Get_Name_String (Current_Full_Obj_Name);
1843                Close (Lib_FD);
1844                Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
1845
1846             else
1847                Current_Full_Obj_Stamp := Empty_Time_Stamp;
1848                Close (Lib_FD);
1849                return null;
1850             end if;
1851          end if;
1852
1853          --  Object file exists, compare object and ALI time stamps
1854
1855          if Current_Full_Lib_Stamp > Current_Full_Obj_Stamp then
1856             if Fatal_Err then
1857                Get_Name_String (Current_Full_Obj_Name);
1858                Close (Lib_FD);
1859                Fail ("Bad time stamp: ", Name_Buffer (1 .. Name_Len));
1860             else
1861                Current_Full_Obj_Stamp := Empty_Time_Stamp;
1862                Close (Lib_FD);
1863                return null;
1864             end if;
1865          end if;
1866       end if;
1867
1868       --  Read data from the file
1869
1870       declare
1871          Len : Integer := Integer (File_Length (Lib_FD));
1872          --  Length of source file text. If it doesn't fit in an integer
1873          --  we're probably stuck anyway (>2 gigs of source seems a lot!)
1874
1875          Actual_Len : Integer := 0;
1876
1877          Lo : Text_Ptr := 0;
1878          --  Low bound for allocated text buffer
1879
1880          Hi : Text_Ptr := Text_Ptr (Len);
1881          --  High bound for allocated text buffer. Note length is Len + 1
1882          --  which allows for extra EOF character at the end of the buffer.
1883
1884       begin
1885          --  Allocate text buffer. Note extra character at end for EOF
1886
1887          Text := new Text_Buffer (Lo .. Hi);
1888
1889          --  Some systems (e.g. VMS) have file types that require one
1890          --  read per line, so read until we get the Len bytes or until
1891          --  there are no more characters.
1892
1893          Hi := Lo;
1894          loop
1895             Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len);
1896             Hi := Hi + Text_Ptr (Actual_Len);
1897             exit when Actual_Len = Len or Actual_Len <= 0;
1898          end loop;
1899
1900          Text (Hi) := EOF;
1901       end;
1902
1903       --  Read is complete, close file and we are done
1904
1905       Close (Lib_FD);
1906       return Text;
1907
1908    end Read_Library_Info;
1909
1910    --  Version with default file name
1911
1912    procedure Read_Library_Info
1913      (Name : out File_Name_Type;
1914       Text : out Text_Buffer_Ptr)
1915    is
1916    begin
1917       Set_Library_Info_Name;
1918       Name := Name_Find;
1919       Text := Read_Library_Info (Name, Fatal_Err => False);
1920    end Read_Library_Info;
1921
1922    ----------------------
1923    -- Read_Source_File --
1924    ----------------------
1925
1926    procedure Read_Source_File
1927      (N   : File_Name_Type;
1928       Lo  : Source_Ptr;
1929       Hi  : out Source_Ptr;
1930       Src : out Source_Buffer_Ptr;
1931       T   : File_Type := Source)
1932    is
1933       Source_File_FD : File_Descriptor;
1934       --  The file descriptor for the current source file. A negative value
1935       --  indicates failure to open the specified source file.
1936
1937       Len : Integer;
1938       --  Length of file. Assume no more than 2 gigabytes of source!
1939
1940       Actual_Len : Integer;
1941
1942    begin
1943       Current_Full_Source_Name  := Find_File (N, T);
1944       Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
1945
1946       if Current_Full_Source_Name = No_File then
1947
1948          --  If we were trying to access the main file and we could not
1949          --  find it we have an error.
1950
1951          if N = Current_Main then
1952             Get_Name_String (N);
1953             Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
1954          end if;
1955
1956          Src := null;
1957          Hi  := No_Location;
1958          return;
1959       end if;
1960
1961       Get_Name_String (Current_Full_Source_Name);
1962       Name_Buffer (Name_Len + 1) := ASCII.NUL;
1963
1964       --  Open the source FD, note that we open in binary mode, because as
1965       --  documented in the spec, the caller is expected to handle either
1966       --  DOS or Unix mode files, and there is no point in wasting time on
1967       --  text translation when it is not required.
1968
1969       Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
1970
1971       if Source_File_FD = Invalid_FD then
1972          Src := null;
1973          Hi  := No_Location;
1974          return;
1975       end if;
1976
1977       --  Prepare to read data from the file
1978
1979       Len := Integer (File_Length (Source_File_FD));
1980
1981       --  Set Hi so that length is one more than the physical length,
1982       --  allowing for the extra EOF character at the end of the buffer
1983
1984       Hi := Lo + Source_Ptr (Len);
1985
1986       --  Do the actual read operation
1987
1988       declare
1989          subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
1990          --  Physical buffer allocated
1991
1992          type Actual_Source_Ptr is access Actual_Source_Buffer;
1993          --  This is the pointer type for the physical buffer allocated
1994
1995          Actual_Ptr : Actual_Source_Ptr := new Actual_Source_Buffer;
1996          --  And this is the actual physical buffer
1997
1998       begin
1999          --  Allocate source buffer, allowing extra character at end for EOF
2000
2001          --  Some systems (e.g. VMS) have file types that require one
2002          --  read per line, so read until we get the Len bytes or until
2003          --  there are no more characters.
2004
2005          Hi := Lo;
2006          loop
2007             Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
2008             Hi := Hi + Source_Ptr (Actual_Len);
2009             exit when Actual_Len = Len or Actual_Len <= 0;
2010          end loop;
2011
2012          Actual_Ptr (Hi) := EOF;
2013
2014          --  Now we need to work out the proper virtual origin pointer to
2015          --  return. This is exactly Actual_Ptr (0)'Address, but we have
2016          --  to be careful to suppress checks to compute this address.
2017
2018          declare
2019             pragma Suppress (All_Checks);
2020
2021             function To_Source_Buffer_Ptr is new
2022               Unchecked_Conversion (Address, Source_Buffer_Ptr);
2023
2024          begin
2025             Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
2026          end;
2027       end;
2028
2029       --  Read is complete, get time stamp and close file and we are done
2030
2031       Close (Source_File_FD);
2032
2033    end Read_Source_File;
2034
2035    --------------------------------
2036    -- Record_Time_From_Last_Bind --
2037    --------------------------------
2038
2039    procedure Record_Time_From_Last_Bind is
2040    begin
2041       Recording_Time_From_Last_Bind := True;
2042    end Record_Time_From_Last_Bind;
2043
2044    ---------------------------
2045    -- Set_Library_Info_Name --
2046    ---------------------------
2047
2048    procedure Set_Library_Info_Name is
2049       Dot_Index : Natural;
2050
2051    begin
2052       pragma Assert (In_Compiler);
2053       Get_Name_String (Current_Main);
2054
2055       --  Find last dot since we replace the existing extension by .ali. The
2056       --  initialization to Name_Len + 1 provides for simply adding the .ali
2057       --  extension if the source file name has no extension.
2058
2059       Dot_Index := Name_Len + 1;
2060       for J in reverse 1 .. Name_Len loop
2061          if Name_Buffer (J) = '.' then
2062             Dot_Index := J;
2063             exit;
2064          end if;
2065       end loop;
2066
2067       --  Make sure that the output file name matches the source file name.
2068       --  To compare them, remove file name directories and extensions.
2069
2070       if Output_Object_File_Name /= null then
2071          declare
2072             Name : constant String  := Name_Buffer (1 .. Dot_Index);
2073             Len  : constant Natural := Dot_Index;
2074
2075          begin
2076             Name_Buffer (1 .. Output_Object_File_Name'Length)
2077                := Output_Object_File_Name.all;
2078             Dot_Index := 0;
2079
2080             for J in reverse Output_Object_File_Name'Range loop
2081                if Name_Buffer (J) = '.' then
2082                   Dot_Index := J;
2083                   exit;
2084                end if;
2085             end loop;
2086
2087             pragma Assert (Dot_Index /= 0);
2088             --  We check for the extension elsewhere
2089
2090             if Name /= Name_Buffer (Dot_Index - Len + 1 .. Dot_Index) then
2091                Fail ("incorrect object file name");
2092             end if;
2093          end;
2094       end if;
2095
2096       Name_Buffer (Dot_Index) := '.';
2097       Name_Buffer (Dot_Index + 1 .. Dot_Index + 3) := ALI_Suffix.all;
2098       Name_Buffer (Dot_Index + 4) := ASCII.NUL;
2099       Name_Len := Dot_Index + 3;
2100    end Set_Library_Info_Name;
2101
2102    ---------------------------------
2103    -- Set_Output_Object_File_Name --
2104    ---------------------------------
2105
2106    procedure Set_Output_Object_File_Name (Name : String) is
2107       Ext : constant String := Object_Suffix;
2108       NL  : constant Natural := Name'Length;
2109       EL  : constant Natural := Ext'Length;
2110
2111    begin
2112       --  Make sure that the object file has the expected extension.
2113
2114       if NL <= EL
2115          or else Name (NL - EL + Name'First .. Name'Last) /= Ext
2116       then
2117          Fail ("incorrect object file extension");
2118       end if;
2119
2120       Output_Object_File_Name := new String'(Name);
2121    end Set_Output_Object_File_Name;
2122
2123    ------------------------
2124    -- Set_Main_File_Name --
2125    ------------------------
2126
2127    procedure Set_Main_File_Name (Name : String) is
2128    begin
2129       Number_File_Names := Number_File_Names + 1;
2130       File_Names (Number_File_Names) := new String'(Name);
2131    end Set_Main_File_Name;
2132
2133    ----------------------
2134    -- Smart_File_Stamp --
2135    ----------------------
2136
2137    function Smart_File_Stamp
2138      (N    : File_Name_Type;
2139       T    : File_Type)
2140       return Time_Stamp_Type
2141    is
2142       Time_Stamp : Time_Stamp_Type;
2143
2144    begin
2145       if not File_Cache_Enabled then
2146          return File_Stamp (Find_File (N, T));
2147       end if;
2148
2149       Time_Stamp := File_Stamp_Hash_Table.Get (N);
2150
2151       if Time_Stamp (1) = ' ' then
2152          Time_Stamp := File_Stamp (Smart_Find_File (N, T));
2153          File_Stamp_Hash_Table.Set (N, Time_Stamp);
2154       end if;
2155
2156       return Time_Stamp;
2157    end Smart_File_Stamp;
2158
2159    ---------------------
2160    -- Smart_Find_File --
2161    ---------------------
2162
2163    function Smart_Find_File
2164      (N : File_Name_Type;
2165       T : File_Type)
2166       return File_Name_Type
2167    is
2168       Full_File_Name : File_Name_Type;
2169
2170    begin
2171       if not File_Cache_Enabled then
2172          return Find_File (N, T);
2173       end if;
2174
2175       Full_File_Name := File_Name_Hash_Table.Get (N);
2176
2177       if Full_File_Name = No_File then
2178          Full_File_Name := Find_File (N, T);
2179          File_Name_Hash_Table.Set (N, Full_File_Name);
2180       end if;
2181
2182       return Full_File_Name;
2183    end Smart_Find_File;
2184
2185    ----------------------
2186    -- Source_File_Data --
2187    ----------------------
2188
2189    procedure Source_File_Data (Cache : Boolean) is
2190    begin
2191       File_Cache_Enabled := Cache;
2192    end Source_File_Data;
2193
2194    -----------------------
2195    -- Source_File_Stamp --
2196    -----------------------
2197
2198    function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
2199    begin
2200       return Smart_File_Stamp (N, Source);
2201    end Source_File_Stamp;
2202
2203    ---------------------
2204    -- Strip_Directory --
2205    ---------------------
2206
2207    function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
2208    begin
2209       Get_Name_String (Name);
2210
2211       declare
2212          S : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
2213          Fptr : Natural := S'First;
2214
2215       begin
2216          for J in reverse S'Range loop
2217             if Is_Directory_Separator (S (J)) then
2218                Fptr := J + 1;
2219                exit;
2220             end if;
2221          end loop;
2222
2223          if Fptr = S'First then
2224             return Name;
2225          end if;
2226
2227          Name_Buffer (1 .. S'Last - Fptr + 1) := S (Fptr .. S'Last);
2228          Name_Len :=  S'Last - Fptr + 1;
2229          return Name_Find;
2230       end;
2231    end Strip_Directory;
2232
2233    ------------------
2234    -- Strip_Suffix --
2235    ------------------
2236
2237    function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
2238    begin
2239       Get_Name_String (Name);
2240
2241       for J in reverse 1 .. Name_Len loop
2242          if Name_Buffer (J) = '.' then
2243             Name_Len := J - 1;
2244             return Name_Enter;
2245          end if;
2246       end loop;
2247
2248       return Name;
2249    end Strip_Suffix;
2250
2251    -------------------------
2252    -- Time_From_Last_Bind --
2253    -------------------------
2254
2255    function Time_From_Last_Bind return Nat is
2256       Old_Y  : Nat;
2257       Old_M  : Nat;
2258       Old_D  : Nat;
2259       Old_H  : Nat;
2260       Old_Mi : Nat;
2261       Old_S  : Nat;
2262       New_Y  : Nat;
2263       New_M  : Nat;
2264       New_D  : Nat;
2265       New_H  : Nat;
2266       New_Mi : Nat;
2267       New_S  : Nat;
2268
2269       type Month_Data is array (Int range 1 .. 12) of Int;
2270       Cumul : constant Month_Data := (0, 0, 3, 3, 4, 4, 5, 5, 5, 6, 6, 7);
2271       --  Represents the difference in days from a period compared to the
2272       --  same period if all months had 31 days, i.e:
2273       --
2274       --    Cumul (m) = 31x(m-1) - (number of days from 01/01 to m/01)
2275
2276       Res : Int;
2277
2278    begin
2279       if not Recording_Time_From_Last_Bind
2280         or else not Binder_Output_Time_Stamps_Set
2281         or else Old_Binder_Output_Time_Stamp = Empty_Time_Stamp
2282       then
2283          return Nat'Last;
2284       end if;
2285
2286       Split_Time_Stamp
2287        (Old_Binder_Output_Time_Stamp,
2288         Old_Y, Old_M, Old_D, Old_H, Old_Mi, Old_S);
2289
2290       Split_Time_Stamp
2291        (New_Binder_Output_Time_Stamp,
2292         New_Y, New_M, New_D, New_H, New_Mi, New_S);
2293
2294       Res := New_Mi - Old_Mi;
2295
2296       --  60 minutes in an hour
2297
2298       Res := Res + 60 * (New_H  - Old_H);
2299
2300       --  24 hours in a day
2301
2302       Res := Res + 60 * 24 * (New_D  - Old_D);
2303
2304       --  Almost 31 days in a month
2305
2306       Res := Res + 60 * 24 *
2307         (31 * (New_M - Old_M) - Cumul (New_M) + Cumul (Old_M));
2308
2309       --  365 days in a year
2310
2311       Res := Res + 60 * 24 * 365 * (New_Y - Old_Y);
2312
2313       return Res;
2314    end Time_From_Last_Bind;
2315
2316    ---------------------------
2317    -- To_Canonical_Dir_Spec --
2318    ---------------------------
2319
2320    function To_Canonical_Dir_Spec
2321      (Host_Dir     : String;
2322       Prefix_Style : Boolean)
2323       return         String_Access
2324    is
2325       function To_Canonical_Dir_Spec
2326         (Host_Dir    : Address;
2327          Prefix_Flag : Integer)
2328          return        Address;
2329       pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
2330
2331       C_Host_Dir      : String (1 .. Host_Dir'Length + 1);
2332       Canonical_Dir_Addr : Address;
2333       Canonical_Dir_Len  : Integer;
2334
2335    begin
2336       C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir;
2337       C_Host_Dir (C_Host_Dir'Last)      := ASCII.NUL;
2338
2339       if Prefix_Style then
2340          Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1);
2341       else
2342          Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
2343       end if;
2344       Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);
2345
2346       if Canonical_Dir_Len = 0 then
2347          return null;
2348       else
2349          return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len);
2350       end if;
2351
2352    exception
2353       when others =>
2354          Fail ("erroneous directory spec: ", Host_Dir);
2355          return null;
2356    end To_Canonical_Dir_Spec;
2357
2358    ---------------------------
2359    -- To_Canonical_File_List --
2360    ---------------------------
2361
2362    function To_Canonical_File_List
2363      (Wildcard_Host_File : String;
2364       Only_Dirs          : Boolean)
2365       return               String_Access_List_Access
2366    is
2367       function To_Canonical_File_List_Init
2368         (Host_File : Address;
2369          Only_Dirs : Integer)
2370       return Integer;
2371       pragma Import (C, To_Canonical_File_List_Init,
2372                      "__gnat_to_canonical_file_list_init");
2373
2374       function To_Canonical_File_List_Next return Address;
2375       pragma Import (C, To_Canonical_File_List_Next,
2376                      "__gnat_to_canonical_file_list_next");
2377
2378       procedure To_Canonical_File_List_Free;
2379       pragma Import (C, To_Canonical_File_List_Free,
2380                      "__gnat_to_canonical_file_list_free");
2381
2382       Num_Files            : Integer;
2383       C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
2384
2385    begin
2386       C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
2387         Wildcard_Host_File;
2388       C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
2389
2390       --  Do the expansion and say how many there are
2391
2392       Num_Files := To_Canonical_File_List_Init
2393          (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
2394
2395       declare
2396          Canonical_File_List : String_Access_List (1 .. Num_Files);
2397          Canonical_File_Addr : Address;
2398          Canonical_File_Len  : Integer;
2399
2400       begin
2401          --  Retrieve the expanded directoy names and build the list
2402
2403          for J in 1 .. Num_Files loop
2404             Canonical_File_Addr := To_Canonical_File_List_Next;
2405             Canonical_File_Len  := C_String_Length (Canonical_File_Addr);
2406             Canonical_File_List (J) := To_Path_String_Access
2407                   (Canonical_File_Addr, Canonical_File_Len);
2408          end loop;
2409
2410          --  Free up the storage
2411
2412          To_Canonical_File_List_Free;
2413
2414          return new String_Access_List'(Canonical_File_List);
2415       end;
2416    end To_Canonical_File_List;
2417
2418    ----------------------------
2419    -- To_Canonical_File_Spec --
2420    ----------------------------
2421
2422    function To_Canonical_File_Spec
2423      (Host_File : String)
2424       return      String_Access
2425    is
2426       function To_Canonical_File_Spec (Host_File : Address) return Address;
2427       pragma Import
2428         (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
2429
2430       C_Host_File      : String (1 .. Host_File'Length + 1);
2431       Canonical_File_Addr : Address;
2432       Canonical_File_Len  : Integer;
2433
2434    begin
2435       C_Host_File (1 .. Host_File'Length) := Host_File;
2436       C_Host_File (C_Host_File'Last)      := ASCII.NUL;
2437
2438       Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address);
2439       Canonical_File_Len  := C_String_Length (Canonical_File_Addr);
2440
2441       if Canonical_File_Len = 0 then
2442          return null;
2443       else
2444          return To_Path_String_Access
2445                   (Canonical_File_Addr, Canonical_File_Len);
2446       end if;
2447
2448    exception
2449       when others =>
2450          Fail ("erroneous file spec: ", Host_File);
2451          return null;
2452    end To_Canonical_File_Spec;
2453
2454    ----------------------------
2455    -- To_Canonical_Path_Spec --
2456    ----------------------------
2457
2458    function To_Canonical_Path_Spec
2459      (Host_Path : String)
2460       return      String_Access
2461    is
2462       function To_Canonical_Path_Spec (Host_Path : Address) return Address;
2463       pragma Import
2464         (C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec");
2465
2466       C_Host_Path         : String (1 .. Host_Path'Length + 1);
2467       Canonical_Path_Addr : Address;
2468       Canonical_Path_Len  : Integer;
2469
2470    begin
2471       C_Host_Path (1 .. Host_Path'Length) := Host_Path;
2472       C_Host_Path (C_Host_Path'Last)      := ASCII.NUL;
2473
2474       Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address);
2475       Canonical_Path_Len  := C_String_Length (Canonical_Path_Addr);
2476
2477       --  Return a null string (vice a null) for zero length paths, for
2478       --  compatibility with getenv().
2479
2480       return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len);
2481
2482    exception
2483       when others =>
2484          Fail ("erroneous path spec: ", Host_Path);
2485          return null;
2486    end To_Canonical_Path_Spec;
2487
2488    ---------------------------
2489    -- To_Host_Dir_Spec --
2490    ---------------------------
2491
2492    function To_Host_Dir_Spec
2493      (Canonical_Dir : String;
2494       Prefix_Style  : Boolean)
2495       return          String_Access
2496    is
2497       function To_Host_Dir_Spec
2498         (Canonical_Dir : Address;
2499          Prefix_Flag   : Integer)
2500          return          Address;
2501       pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
2502
2503       C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
2504       Host_Dir_Addr   : Address;
2505       Host_Dir_Len    : Integer;
2506
2507    begin
2508       C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir;
2509       C_Canonical_Dir (C_Canonical_Dir'Last)      := ASCII.NUL;
2510
2511       if Prefix_Style then
2512          Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1);
2513       else
2514          Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0);
2515       end if;
2516       Host_Dir_Len := C_String_Length (Host_Dir_Addr);
2517
2518       if Host_Dir_Len = 0 then
2519          return null;
2520       else
2521          return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len);
2522       end if;
2523    end To_Host_Dir_Spec;
2524
2525    ----------------------------
2526    -- To_Host_File_Spec --
2527    ----------------------------
2528
2529    function To_Host_File_Spec
2530      (Canonical_File : String)
2531       return           String_Access
2532    is
2533       function To_Host_File_Spec (Canonical_File : Address) return Address;
2534       pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
2535
2536       C_Canonical_File      : String (1 .. Canonical_File'Length + 1);
2537       Host_File_Addr : Address;
2538       Host_File_Len  : Integer;
2539
2540    begin
2541       C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File;
2542       C_Canonical_File (C_Canonical_File'Last)      := ASCII.NUL;
2543
2544       Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address);
2545       Host_File_Len  := C_String_Length (Host_File_Addr);
2546
2547       if Host_File_Len = 0 then
2548          return null;
2549       else
2550          return To_Path_String_Access
2551                   (Host_File_Addr, Host_File_Len);
2552       end if;
2553    end To_Host_File_Spec;
2554
2555    ---------------------------
2556    -- To_Path_String_Access --
2557    ---------------------------
2558
2559    function To_Path_String_Access
2560      (Path_Addr : Address;
2561       Path_Len  : Integer)
2562       return      String_Access
2563    is
2564       subtype Path_String is String (1 .. Path_Len);
2565       type    Path_String_Access is access Path_String;
2566
2567       function Address_To_Access is new
2568         Unchecked_Conversion (Source => Address,
2569                               Target => Path_String_Access);
2570
2571       Path_Access : Path_String_Access := Address_To_Access (Path_Addr);
2572
2573       Return_Val  : String_Access;
2574
2575    begin
2576       Return_Val := new String (1 .. Path_Len);
2577
2578       for J in 1 .. Path_Len loop
2579          Return_Val (J) := Path_Access (J);
2580       end loop;
2581
2582       return Return_Val;
2583    end To_Path_String_Access;
2584
2585    ----------------
2586    -- Tree_Close --
2587    ----------------
2588
2589    procedure Tree_Close is
2590    begin
2591       pragma Assert (In_Compiler);
2592       Tree_Write_Terminate;
2593       Close (Output_FD);
2594    end Tree_Close;
2595
2596    -----------------
2597    -- Tree_Create --
2598    -----------------
2599
2600    procedure Tree_Create is
2601       Dot_Index : Natural;
2602
2603    begin
2604       pragma Assert (In_Compiler);
2605       Get_Name_String (Current_Main);
2606
2607       --  If an object file has been specified, then the ALI file
2608       --  will be in the same directory as the object file;
2609       --  so, we put the tree file in this same directory,
2610       --  even though no object file needs to be generated.
2611
2612       if Output_Object_File_Name /= null then
2613          Name_Len := Output_Object_File_Name'Length;
2614          Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
2615       end if;
2616
2617       Dot_Index := 0;
2618       for J in reverse 1 .. Name_Len loop
2619          if Name_Buffer (J) = '.' then
2620             Dot_Index := J;
2621             exit;
2622          end if;
2623       end loop;
2624
2625       --  Should be impossible to not have an extension
2626
2627       pragma Assert (Dot_Index /= 0);
2628
2629       --  Change exctension to adt
2630
2631       Name_Buffer (Dot_Index + 1) := 'a';
2632       Name_Buffer (Dot_Index + 2) := 'd';
2633       Name_Buffer (Dot_Index + 3) := 't';
2634       Name_Buffer (Dot_Index + 4) := ASCII.NUL;
2635       Name_Len := Dot_Index + 3;
2636       Create_File_And_Check (Output_FD, Binary);
2637
2638       Tree_Write_Initialize (Output_FD);
2639    end Tree_Create;
2640
2641    ----------------
2642    -- Write_Info --
2643    ----------------
2644
2645    procedure Write_Info (Info : String) is
2646    begin
2647       pragma Assert (In_Binder or In_Compiler);
2648       Write_With_Check (Info'Address, Info'Length);
2649       Write_With_Check (EOL'Address, 1);
2650    end Write_Info;
2651
2652    -----------------------
2653    -- Write_Binder_Info --
2654    -----------------------
2655
2656    procedure Write_Binder_Info (Info : String) renames Write_Info;
2657
2658    -----------------------
2659    -- Write_Debug_Info --
2660    -----------------------
2661
2662    procedure Write_Debug_Info (Info : String) renames Write_Info;
2663
2664    ------------------------
2665    -- Write_Library_Info --
2666    ------------------------
2667
2668    procedure Write_Library_Info (Info : String) renames Write_Info;
2669
2670    ------------------------
2671    -- Write_Program_Name --
2672    ------------------------
2673
2674    procedure Write_Program_Name is
2675       Save_Buffer : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
2676
2677    begin
2678
2679       Find_Program_Name;
2680
2681       --  Convert the name to lower case so error messages are the same on
2682       --  all systems.
2683
2684       for J in 1 .. Name_Len loop
2685          if Name_Buffer (J) in 'A' .. 'Z' then
2686             Name_Buffer (J) :=
2687               Character'Val (Character'Pos (Name_Buffer (J)) + 32);
2688          end if;
2689       end loop;
2690
2691       Write_Str (Name_Buffer (1 .. Name_Len));
2692
2693       --  Restore Name_Buffer which was clobbered by the call to
2694       --  Find_Program_Name
2695
2696       Name_Len := Save_Buffer'Last;
2697       Name_Buffer (1 .. Name_Len) := Save_Buffer;
2698    end Write_Program_Name;
2699
2700    ----------------------
2701    -- Write_With_Check --
2702    ----------------------
2703
2704    procedure Write_With_Check (A  : Address; N  : Integer) is
2705       Ignore : Boolean;
2706
2707    begin
2708       if N = Write (Output_FD, A, N) then
2709          return;
2710
2711       else
2712          Write_Str ("error: disk full writing ");
2713          Write_Name_Decoded (Output_File_Name);
2714          Write_Eol;
2715          Name_Len := Name_Len + 1;
2716          Name_Buffer (Name_Len) := ASCII.NUL;
2717          Delete_File (Name_Buffer'Address, Ignore);
2718          Exit_Program (E_Fatal);
2719       end if;
2720    end Write_With_Check;
2721
2722 end Osint;