gcc/ada/osint.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                O S I N T                                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision$
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 with Hostparm;
  30 with Namet;    use Namet;
  31 with Opt;      use Opt;
  32 with Output;   use Output;
  33 with Sdefault; use Sdefault;
  34 with Table;
  35 with Tree_IO;  use Tree_IO;
  36
  37 with Unchecked_Conversion;
  38
  39 with GNAT.OS_Lib; use GNAT.OS_Lib;
  40 with GNAT.HTable;
  41
  42 package body Osint is
  43
  44    -------------------------------------
  45    -- Use of Name_Find and Name_Enter --
  46    -------------------------------------
  47
  48    --  This package creates a number of source, ALI and object file names
  49    --  that are used to locate the actual file and for the purpose of
  50    --  message construction. These names need not be accessible by Name_Find,
  51    --  and can be therefore created by using routine Name_Enter. The files in
  52    --  question are file names with a prefix directory (ie the files not
  53    --  in the current directory). File names without a prefix directory are
  54    --  entered with Name_Find because special values might be attached to
  55    --  the various Info fields of the corresponding name table entry.
  56
  57    -----------------------
  58    -- Local Subprograms --
  59    -----------------------
  60
  61    function Append_Suffix_To_File_Name
  62      (Name   : Name_Id;
  63       Suffix : String)
  64       return   Name_Id;
  65    --  Appends Suffix to Name and returns the new name.
  66
  67    function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type;
  68    --  Convert OS format time to GNAT format time stamp
  69
  70    procedure Create_File_And_Check
  71      (Fdesc : out File_Descriptor;
  72       Fmode : Mode);
  73    --  Create file whose name (NUL terminated) is in Name_Buffer (with the
  74    --  length in Name_Len), and place the resulting descriptor in Fdesc.
  75    --  Issue message and exit with fatal error if file cannot be created.
  76    --  The Fmode parameter is set to either Text or Binary (see description
  77    --  of GNAT.OS_Lib.Create_File).
  78
  79    procedure Set_Library_Info_Name;
  80    --  Sets a default ali file name from the main compiler source name.
  81    --  This is used by Create_Output_Library_Info, and by the version of
  82    --  Read_Library_Info that takes a default file name.
  83
  84    procedure Write_Info (Info : String);
  85    --  Implementation of Write_Binder_Info, Write_Debug_Info and
  86    --  Write_Library_Info (identical)
  87
  88    procedure Write_With_Check (A  : Address; N  : Integer);
  89    --  Writes N bytes from buffer starting at address A to file whose FD is
  90    --  stored in Output_FD, and whose file name is stored as a File_Name_Type
  91    --  in Output_File_Name. A check is made for disk full, and if this is
  92    --  detected, the file being written is deleted, and a fatal error is
  93    --  signalled.
  94
  95    function More_Files return Boolean;
  96    --  Implements More_Source_Files and More_Lib_Files.
  97
  98    function Next_Main_File return File_Name_Type;
  99    --  Implements Next_Main_Source and Next_Main_Lib_File.
 100
 101    function Locate_File
 102      (N    : File_Name_Type;
 103       T    : File_Type;
 104       Dir  : Natural;
 105       Name : String)
 106       return File_Name_Type;
 107    --  See if the file N whose name is Name exists in directory Dir. Dir is
 108    --  an index into the Lib_Search_Directories table if T = Library.
 109    --  Otherwise if T = Source, Dir is an index into the
 110    --  Src_Search_Directories table. Returns the File_Name_Type of the
 111    --  full file name if file found, or No_File if not found.
 112
 113    function C_String_Length (S : Address) return Integer;
 114    --  Returns length of a C string. Returns zero for a null address.
 115
 116    function To_Path_String_Access
 117      (Path_Addr : Address;
 118       Path_Len  : Integer)
 119       return      String_Access;
 120    --  Converts a C String to an Ada String. Are we doing this to avoid
 121    --  withing Interfaces.C.Strings ???
 122
 123    ------------------------------
 124    -- Other Local Declarations --
 125    ------------------------------
 126
 127    ALI_Suffix : constant String_Ptr := new String'("ali");
 128    --  The suffix used for the library files (also known as ALI files).
 129
 130    Object_Suffix : constant String := Get_Object_Suffix.all;
 131    --  The suffix used for the object files.
 132
 133    EOL : constant Character := ASCII.LF;
 134    --  End of line character
 135
 136    Argument_Count : constant Integer := Arg_Count - 1;
 137    --  Number of arguments (excluding program name)
 138
 139    type File_Name_Array is array (Int range <>) of String_Ptr;
 140    type File_Name_Array_Ptr is access File_Name_Array;
 141    File_Names : File_Name_Array_Ptr :=
 142      new File_Name_Array (1 .. Int (Argument_Count) + 2);
 143    --  As arguments are scanned in Initialize, file names are stored
 144    --  in this array. The string does not contain a terminating NUL.
 145    --  The array is "extensible" because when using project files,
 146    --  there may be more file names than argument on the command line.
 147
 148    Number_File_Names : Int := 0;
 149    --  The total number of file names found on command line and placed in
 150    --  File_Names.
 151
 152    Current_File_Name_Index : Int := 0;
 153    --  The index in File_Names of the last file opened by Next_Main_Source
 154    --  or Next_Main_Lib_File. The value 0 indicates that no files have been
 155    --  opened yet.
 156
 157    Current_Main : File_Name_Type := No_File;
 158    --  Used to save a simple file name between calls to Next_Main_Source and
 159    --  Read_Source_File. If the file name argument to Read_Source_File is
 160    --  No_File, that indicates that the file whose name was returned by the
 161    --  last call to Next_Main_Source (and stored here) is to be read.
 162
 163    Look_In_Primary_Directory_For_Current_Main : Boolean := False;
 164    --  When this variable is True, Find_File will only look in
 165    --  the Primary_Directory for the Current_Main file.
 166    --  This variable is always True for the compiler.
 167    --  It is also True for gnatmake, when the soucr name given
 168    --  on the command line has directory information.
 169
 170    Current_Full_Source_Name  : File_Name_Type  := No_File;
 171    Current_Full_Source_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
 172    Current_Full_Lib_Name     : File_Name_Type  := No_File;
 173    Current_Full_Lib_Stamp    : Time_Stamp_Type := Empty_Time_Stamp;
 174    Current_Full_Obj_Name     : File_Name_Type  := No_File;
 175    Current_Full_Obj_Stamp    : Time_Stamp_Type := Empty_Time_Stamp;
 176    --  Respectively full name (with directory info) and time stamp of
 177    --  the latest source, library and object files opened by Read_Source_File
 178    --  and Read_Library_Info.
 179
 180    Old_Binder_Output_Time_Stamp  : Time_Stamp_Type;
 181    New_Binder_Output_Time_Stamp  : Time_Stamp_Type;
 182    Recording_Time_From_Last_Bind : Boolean := False;
 183    Binder_Output_Time_Stamps_Set : Boolean := False;
 184
 185    In_Binder   : Boolean := False;
 186    In_Compiler : Boolean := False;
 187    In_Make     : Boolean := False;
 188    --  Exactly one of these flags is set True to indicate which program
 189    --  is bound and executing with Osint, which is used by all these programs.
 190
 191    Output_FD : File_Descriptor;
 192    --  The file descriptor for the current library info, tree or binder output
 193
 194    Output_File_Name : File_Name_Type;
 195    --  File_Name_Type for name of open file whose FD is in Output_FD, the name
 196    --  stored does not include the trailing NUL character.
 197
 198    Output_Object_File_Name : String_Ptr;
 199    --  Argument of -o compiler option, if given. This is needed to
 200    --  verify consistency with the ALI file name.
 201
 202    ------------------
 203    -- Search Paths --
 204    ------------------
 205
 206    Primary_Directory : constant := 0;
 207    --  This is index in the tables created below for the first directory to
 208    --  search in for source or library information files. This is the
 209    --  directory containing the latest main input file (a source file for
 210    --  the compiler or a library file for the binder).
 211
 212    package Src_Search_Directories is new Table.Table (
 213      Table_Component_Type => String_Ptr,
 214      Table_Index_Type     => Natural,
 215      Table_Low_Bound      => Primary_Directory,
 216      Table_Initial        => 10,
 217      Table_Increment      => 100,
 218      Table_Name           => "Osint.Src_Search_Directories");
 219    --  Table of names of directories in which to search for source (Compiler)
 220    --  files. This table is filled in the order in which the directories are
 221    --  to be searched, and then used in that order.
 222
 223    package Lib_Search_Directories is new Table.Table (
 224      Table_Component_Type => String_Ptr,
 225      Table_Index_Type     => Natural,
 226      Table_Low_Bound      => Primary_Directory,
 227      Table_Initial        => 10,
 228      Table_Increment      => 100,
 229      Table_Name           => "Osint.Lib_Search_Directories");
 230    --  Table of names of directories in which to search for library (Binder)
 231    --  files. This table is filled in the order in which the directories are
 232    --  to be searched and then used in that order. The reason for having two
 233    --  distinct tables is that we need them both in gnatmake.
 234
 235    ---------------------
 236    -- File Hash Table --
 237    ---------------------
 238
 239    --  The file hash table is provided to free the programmer from any
 240    --  efficiency concern when retrieving full file names or time stamps of
 241    --  source files. If the programmer calls Source_File_Data (Cache => True)
 242    --  he is guaranteed that the price to retrieve the full name (ie with
 243    --  directory info) or time stamp of the file will be payed only once,
 244    --  the first time the full name is actually searched (or the first time
 245    --  the time stamp is actually retrieved). This is achieved by employing
 246    --  a hash table that stores as a key the File_Name_Type of the file and
 247    --  associates to that File_Name_Type the full file name of the file and its
 248    --  time stamp.
 249
 250    File_Cache_Enabled : Boolean := False;
 251    --  Set to true if you want the enable the file data caching mechanism.
 252
 253    type File_Hash_Num is range 0 .. 1020;
 254
 255    function File_Hash (F : File_Name_Type) return File_Hash_Num;
 256    --  Compute hash index for use by Simple_HTable
 257
 258    package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable (
 259      Header_Num => File_Hash_Num,
 260      Element    => File_Name_Type,
 261      No_Element => No_File,
 262      Key        => File_Name_Type,
 263      Hash       => File_Hash,
 264      Equal      => "=");
 265
 266    package File_Stamp_Hash_Table is new GNAT.HTable.Simple_HTable (
 267      Header_Num => File_Hash_Num,
 268      Element    => Time_Stamp_Type,
 269      No_Element => Empty_Time_Stamp,
 270      Key        => File_Name_Type,
 271      Hash       => File_Hash,
 272      Equal      => "=");
 273
 274    function Smart_Find_File
 275      (N    : File_Name_Type;
 276       T    : File_Type)
 277       return File_Name_Type;
 278    --  Exactly like Find_File except that if File_Cache_Enabled is True this
 279    --  routine looks first in the hash table to see if the full name of the
 280    --  file is already available.
 281
 282    function Smart_File_Stamp
 283      (N    : File_Name_Type;
 284       T    : File_Type)
 285       return Time_Stamp_Type;
 286    --  Takes the same parameter as the routine above (N is a file name
 287    --  without any prefix directory information) and behaves like File_Stamp
 288    --  except that if File_Cache_Enabled is True this routine looks first in
 289    --  the hash table to see if the file stamp of the file is already
 290    --  available.
 291
 292    -----------------------------
 293    -- Add_Default_Search_Dirs --
 294    -----------------------------
 295
 296    procedure Add_Default_Search_Dirs is
 297       Search_Dir  : String_Access;
 298       Search_Path : String_Access;
 299
 300       procedure Add_Search_Dir
 301         (Search_Dir            : String_Access;
 302          Additional_Source_Dir : Boolean);
 303       --  Needs documentation ???
 304
 305       function Get_Libraries_From_Registry return String_Ptr;
 306       --  On Windows systems, get the list of installed standard libraries
 307       --  from the registry key:
 308       --  HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
 309       --                             GNAT\Standard Libraries
 310       --  Return an empty string on other systems
 311
 312       function Update_Path (Path : String_Ptr) return String_Ptr;
 313       --  Update the specified path to replace the prefix with
 314       --  the location where GNAT is installed. See the file prefix.c
 315       --  in GCC for more details.
 316
 317       --------------------
 318       -- Add_Search_Dir --
 319       --------------------
 320
 321       procedure Add_Search_Dir
 322         (Search_Dir            : String_Access;
 323          Additional_Source_Dir : Boolean)
 324       is
 325       begin
 326          if Additional_Source_Dir then
 327             Add_Src_Search_Dir (Search_Dir.all);
 328          else
 329             Add_Lib_Search_Dir (Search_Dir.all);
 330          end if;
 331       end Add_Search_Dir;
 332
 333       ---------------------------------
 334       -- Get_Libraries_From_Registry --
 335       ---------------------------------
 336
 337       function Get_Libraries_From_Registry return String_Ptr is
 338          function C_Get_Libraries_From_Registry return Address;
 339          pragma Import (C, C_Get_Libraries_From_Registry,
 340                         "__gnat_get_libraries_from_registry");
 341          function Strlen (Str : Address) return Integer;
 342          pragma Import (C, Strlen, "strlen");
 343          procedure Strncpy (X : Address; Y : Address; Length : Integer);
 344          pragma Import (C, Strncpy, "strncpy");
 345          Result_Ptr : Address;
 346          Result_Length : Integer;
 347          Out_String : String_Ptr;
 348
 349       begin
 350          Result_Ptr := C_Get_Libraries_From_Registry;
 351          Result_Length := Strlen (Result_Ptr);
 352
 353          Out_String := new String (1 .. Result_Length);
 354          Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
 355          return Out_String;
 356       end Get_Libraries_From_Registry;
 357
 358       -----------------
 359       -- Update_Path --
 360       -----------------
 361
 362       function Update_Path (Path : String_Ptr) return String_Ptr is
 363
 364          function C_Update_Path (Path, Component : Address) return Address;
 365          pragma Import (C, C_Update_Path, "update_path");
 366
 367          function Strlen (Str : Address) return Integer;
 368          pragma Import (C, Strlen, "strlen");
 369
 370          procedure Strncpy (X : Address; Y : Address; Length : Integer);
 371          pragma Import (C, Strncpy, "strncpy");
 372
 373          In_Length      : constant Integer := Path'Length;
 374          In_String      : String (1 .. In_Length + 1);
 375          Component_Name : aliased String := "GNAT" & ASCII.NUL;
 376          Result_Ptr     : Address;
 377          Result_Length  : Integer;
 378          Out_String     : String_Ptr;
 379
 380       begin
 381          In_String (1 .. In_Length) := Path.all;
 382          In_String (In_Length + 1) := ASCII.NUL;
 383          Result_Ptr := C_Update_Path (In_String'Address,
 384                                       Component_Name'Address);
 385          Result_Length := Strlen (Result_Ptr);
 386
 387          Out_String := new String (1 .. Result_Length);
 388          Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
 389          return Out_String;
 390       end Update_Path;
 391
 392    --  Start of processing for Add_Default_Search_Dirs
 393
 394    begin
 395       --  After the locations specified on the command line, the next places
 396       --  to look for files are the directories specified by the appropriate
 397       --  environment variable. Get this value, extract the directory names
 398       --  and store in the tables.
 399
 400       --  On VMS, don't expand the logical name (e.g. environment variable),
 401       --  just put it into Unix (e.g. canonical) format. System services
 402       --  will handle the expansion as part of the file processing.
 403
 404       for Additional_Source_Dir in False .. True loop
 405
 406          if Additional_Source_Dir then
 407             Search_Path := Getenv ("ADA_INCLUDE_PATH");
 408             if Search_Path'Length > 0 then
 409                if Hostparm.OpenVMS then
 410                   Search_Path := To_Canonical_Path_Spec ("ADA_INCLUDE_PATH:");
 411                else
 412                   Search_Path := To_Canonical_Path_Spec (Search_Path.all);
 413                end if;
 414             end if;
 415          else
 416             Search_Path := Getenv ("ADA_OBJECTS_PATH");
 417             if Search_Path'Length > 0 then
 418                if Hostparm.OpenVMS then
 419                   Search_Path := To_Canonical_Path_Spec ("ADA_OBJECTS_PATH:");
 420                else
 421                   Search_Path := To_Canonical_Path_Spec (Search_Path.all);
 422                end if;
 423             end if;
 424          end if;
 425
 426          Get_Next_Dir_In_Path_Init (Search_Path);
 427          loop
 428             Search_Dir := Get_Next_Dir_In_Path (Search_Path);
 429             exit when Search_Dir = null;
 430             Add_Search_Dir (Search_Dir, Additional_Source_Dir);
 431          end loop;
 432       end loop;
 433
 434       if not Opt.No_Stdinc then
 435          --  For WIN32 systems, look for any system libraries defined in
 436          --  the registry. These are added to both source and object
 437          --  directories.
 438
 439          Search_Path := String_Access (Get_Libraries_From_Registry);
 440          Get_Next_Dir_In_Path_Init (Search_Path);
 441          loop
 442             Search_Dir := Get_Next_Dir_In_Path (Search_Path);
 443             exit when Search_Dir = null;
 444             Add_Search_Dir (Search_Dir, False);
 445             Add_Search_Dir (Search_Dir, True);
 446          end loop;
 447
 448          --  The last place to look are the defaults
 449
 450          Search_Path := Read_Default_Search_Dirs
 451            (String_Access (Update_Path (Search_Dir_Prefix)),
 452             Include_Search_File,
 453             String_Access (Update_Path (Include_Dir_Default_Name)));
 454
 455          Get_Next_Dir_In_Path_Init (Search_Path);
 456          loop
 457             Search_Dir := Get_Next_Dir_In_Path (Search_Path);
 458             exit when Search_Dir = null;
 459             Add_Search_Dir (Search_Dir, True);
 460          end loop;
 461       end if;
 462
 463       if not Opt.No_Stdlib then
 464          Search_Path := Read_Default_Search_Dirs
 465            (String_Access (Update_Path (Search_Dir_Prefix)),
 466             Objects_Search_File,
 467             String_Access (Update_Path (Object_Dir_Default_Name)));
 468
 469          Get_Next_Dir_In_Path_Init (Search_Path);
 470          loop
 471             Search_Dir := Get_Next_Dir_In_Path (Search_Path);
 472             exit when Search_Dir = null;
 473             Add_Search_Dir (Search_Dir, False);
 474          end loop;
 475       end if;
 476
 477    end Add_Default_Search_Dirs;
 478
 479    --------------
 480    -- Add_File --
 481    --------------
 482
 483    procedure Add_File (File_Name : String) is
 484    begin
 485       Number_File_Names := Number_File_Names + 1;
 486
 487       --  As Add_File may be called for mains specified inside
 488       --  a project file, File_Names may be too short and needs
 489       --  to be extended.
 490
 491       if Number_File_Names > File_Names'Last then
 492          File_Names := new File_Name_Array'(File_Names.all & File_Names.all);
 493       end if;
 494
 495       File_Names (Number_File_Names) := new String'(File_Name);
 496    end Add_File;
 497
 498    ------------------------
 499    -- Add_Lib_Search_Dir --
 500    ------------------------
 501
 502    procedure Add_Lib_Search_Dir (Dir : String) is
 503    begin
 504       if Dir'Length = 0 then
 505          Fail ("missing library directory name");
 506       end if;
 507
 508       Lib_Search_Directories.Increment_Last;
 509       Lib_Search_Directories.Table (Lib_Search_Directories.Last) :=
 510         Normalize_Directory_Name (Dir);
 511    end Add_Lib_Search_Dir;
 512
 513    ------------------------
 514    -- Add_Src_Search_Dir --
 515    ------------------------
 516
 517    procedure Add_Src_Search_Dir (Dir : String) is
 518    begin
 519       if Dir'Length = 0 then
 520          Fail ("missing source directory name");
 521       end if;
 522
 523       Src_Search_Directories.Increment_Last;
 524       Src_Search_Directories.Table (Src_Search_Directories.Last) :=
 525         Normalize_Directory_Name (Dir);
 526    end Add_Src_Search_Dir;
 527
 528    --------------------------------
 529    -- Append_Suffix_To_File_Name --
 530    --------------------------------
 531
 532    function Append_Suffix_To_File_Name
 533      (Name   : Name_Id;
 534       Suffix : String)
 535       return   Name_Id
 536    is
 537    begin
 538       Get_Name_String (Name);
 539       Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 540       Name_Len := Name_Len + Suffix'Length;
 541       return Name_Find;
 542    end Append_Suffix_To_File_Name;
 543
 544    ---------------------
 545    -- C_String_Length --
 546    ---------------------
 547
 548    function C_String_Length (S : Address) return Integer is
 549       function Strlen (S : Address) return Integer;
 550       pragma Import (C, Strlen, "strlen");
 551
 552    begin
 553       if S = Null_Address then
 554          return 0;
 555       else
 556          return Strlen (S);
 557       end if;
 558    end C_String_Length;
 559
 560    ------------------------------
 561    -- Canonical_Case_File_Name --
 562    ------------------------------
 563
 564    --  For now, we only deal with the case of a-z. Eventually we should
 565    --  worry about other Latin-1 letters on systems that support this ???
 566
 567    procedure Canonical_Case_File_Name (S : in out String) is
 568    begin
 569       if not File_Names_Case_Sensitive then
 570          for J in S'Range loop
 571             if S (J) in 'A' .. 'Z' then
 572                S (J) := Character'Val (
 573                           Character'Pos (S (J)) +
 574                           Character'Pos ('a')   -
 575                           Character'Pos ('A'));
 576             end if;
 577          end loop;
 578       end if;
 579    end Canonical_Case_File_Name;
 580
 581    -------------------------
 582    -- Close_Binder_Output --
 583    -------------------------
 584
 585    procedure Close_Binder_Output is
 586    begin
 587       pragma Assert (In_Binder);
 588       Close (Output_FD);
 589
 590       if Recording_Time_From_Last_Bind then
 591          New_Binder_Output_Time_Stamp  := File_Stamp (Output_File_Name);
 592          Binder_Output_Time_Stamps_Set := True;
 593       end if;
 594    end Close_Binder_Output;
 595
 596    ----------------------
 597    -- Close_Debug_File --
 598    ----------------------
 599
 600    procedure Close_Debug_File is
 601    begin
 602       pragma Assert (In_Compiler);
 603       Close (Output_FD);
 604    end Close_Debug_File;
 605
 606    -------------------------------
 607    -- Close_Output_Library_Info --
 608    -------------------------------
 609
 610    procedure Close_Output_Library_Info is
 611    begin
 612       pragma Assert (In_Compiler);
 613       Close (Output_FD);
 614    end Close_Output_Library_Info;
 615
 616    --------------------------
 617    -- Create_Binder_Output --
 618    --------------------------
 619
 620    procedure Create_Binder_Output
 621      (Output_File_Name : String;
 622       Typ              : Character;
 623       Bfile            : out Name_Id)
 624    is
 625       File_Name : String_Ptr;
 626       Findex1   : Natural;
 627       Findex2   : Natural;
 628       Flength   : Natural;
 629
 630    begin
 631       pragma Assert (In_Binder);
 632
 633       if Output_File_Name /= "" then
 634          Name_Buffer (Output_File_Name'Range) := Output_File_Name;
 635          Name_Buffer (Output_File_Name'Last + 1) := ASCII.NUL;
 636
 637          if Typ = 's' then
 638             Name_Buffer (Output_File_Name'Last) := 's';
 639          end if;
 640
 641          Name_Len := Output_File_Name'Last;
 642
 643       else
 644          Name_Buffer (1) := 'b';
 645          File_Name := File_Names (Current_File_Name_Index);
 646
 647          Findex1 := File_Name'First;
 648
 649          --  The ali file might be specified by a full path name. However,
 650          --  the binder generated file should always be created in the
 651          --  current directory, so the path might need to be stripped away.
 652          --  In addition to the default directory_separator allow the '/' to
 653          --  act as separator since this is allowed in MS-DOS and OS2 ports.
 654
 655          for J in reverse File_Name'Range loop
 656             if File_Name (J) = Directory_Separator
 657               or else File_Name (J) = '/'
 658             then
 659                Findex1 := J + 1;
 660                exit;
 661             end if;
 662          end loop;
 663
 664          Findex2 := File_Name'Last;
 665          while File_Name (Findex2) /=  '.' loop
 666             Findex2 := Findex2 - 1;
 667          end loop;
 668
 669          Flength := Findex2 - Findex1;
 670
 671          if Maximum_File_Name_Length > 0 then
 672
 673             --  Make room for the extra two characters in "b?"
 674
 675             while Int (Flength) > Maximum_File_Name_Length - 2 loop
 676                Findex2 := Findex2 - 1;
 677                Flength := Findex2 - Findex1;
 678             end loop;
 679          end if;
 680
 681          Name_Buffer (3 .. Flength + 2) := File_Name (Findex1 .. Findex2 - 1);
 682          Name_Buffer (Flength + 3) := '.';
 683
 684          --  C bind file, name is b_xxx.c
 685
 686          if Typ = 'c' then
 687             Name_Buffer (2) := '_';
 688             Name_Buffer (Flength + 4) := 'c';
 689             Name_Buffer (Flength + 5) := ASCII.NUL;
 690             Name_Len := Flength + 4;
 691
 692          --  Ada bind file, name is b~xxx.adb or b~xxx.ads
 693          --  (with $ instead of ~ in VMS)
 694
 695          else
 696             if Hostparm.OpenVMS then
 697                Name_Buffer (2) := '$';
 698             else
 699                Name_Buffer (2) := '~';
 700             end if;
 701
 702             Name_Buffer (Flength + 4) := 'a';
 703             Name_Buffer (Flength + 5) := 'd';
 704             Name_Buffer (Flength + 6) := Typ;
 705             Name_Buffer (Flength + 7) := ASCII.NUL;
 706             Name_Len := Flength + 6;
 707          end if;
 708       end if;
 709
 710       Bfile := Name_Find;
 711
 712       if Recording_Time_From_Last_Bind then
 713          Old_Binder_Output_Time_Stamp := File_Stamp (Bfile);
 714       end if;
 715
 716       Create_File_And_Check (Output_FD, Text);
 717    end Create_Binder_Output;
 718
 719    -----------------------
 720    -- Create_Debug_File --
 721    -----------------------
 722
 723    function Create_Debug_File (Src : File_Name_Type) return File_Name_Type is
 724       Result : File_Name_Type;
 725
 726    begin
 727       Get_Name_String (Src);
 728       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       function Is_Relative (S : String; K : Positive) return Boolean;
1697       pragma Inline (Is_Relative);
1698       --  Returns True if a relative directory specification is found
1699       --  in S at position K, False otherwise.
1700
1701       -----------------
1702       -- Is_Relative --
1703       -----------------
1704
1705       function Is_Relative (S : String; K : Positive) return Boolean is
1706       begin
1707          return not Is_Absolute_Path (S (K .. S'Last));
1708       end Is_Relative;
1709
1710    --  Start of processing for Read_Default_Search_Dirs
1711
1712    begin
1713       --  Construct a C compatible character string buffer.
1714
1715       Buffer (1 .. Search_Dir_Prefix.all'Length)
1716         := Search_Dir_Prefix.all;
1717       Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1)
1718         := Search_File.all;
1719       Buffer (Buffer'Last) := ASCII.NUL;
1720
1721       File_FD := Open_Read (Buffer'Address, Binary);
1722       if File_FD = Invalid_FD then
1723          return Search_Dir_Default_Name;
1724       end if;
1725
1726       Len := Integer (File_Length (File_FD));
1727
1728       --  An extra character for a trailing Path_Separator is allocated
1729
1730       S := new String (1 .. Len + 1);
1731       S (Len + 1) := Path_Separator;
1732
1733       --  Read the file. Note that the loop is not necessary since the
1734       --  whole file is read at once except on VMS.
1735
1736       Curr := 1;
1737       Actual_Len := Len;
1738       while Actual_Len /= 0 loop
1739          Actual_Len := Read (File_FD, S (Curr)'Address, Len);
1740          Curr := Curr + Actual_Len;
1741       end loop;
1742
1743       --  Process the file, translating line and file ending
1744       --  control characters to a path separator character.
1745
1746       Prev_Was_Separator := True;
1747       Nb_Relative_Dir := 0;
1748       for J in 1 .. Len loop
1749          if S (J) in ASCII.NUL .. ASCII.US
1750            or else S (J) = ' '
1751          then
1752             S (J) := Path_Separator;
1753          end if;
1754
1755          if S (J) = Path_Separator then
1756             Prev_Was_Separator := True;
1757          else
1758             if Prev_Was_Separator and then Is_Relative (S.all, J) then
1759                Nb_Relative_Dir := Nb_Relative_Dir + 1;
1760             end if;
1761
1762             Prev_Was_Separator := False;
1763          end if;
1764       end loop;
1765
1766       if Nb_Relative_Dir = 0 then
1767          return S;
1768       end if;
1769
1770       --  Add the Search_Dir_Prefix to all relative paths
1771
1772       S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len);
1773       J1 := 1;
1774       Prev_Was_Separator := True;
1775       for J in 1 .. Len + 1 loop
1776          if S (J) = Path_Separator then
1777             Prev_Was_Separator := True;
1778
1779          else
1780             if Prev_Was_Separator and then Is_Relative (S.all, J) then
1781                S1 (J1 .. J1 + Prefix_Len) := Search_Dir_Prefix.all;
1782                J1 := J1 + Prefix_Len;
1783             end if;
1784
1785             Prev_Was_Separator := False;
1786          end if;
1787          S1 (J1) := S (J);
1788          J1 := J1 + 1;
1789       end loop;
1790
1791       Free (S);
1792       return S1;
1793    end Read_Default_Search_Dirs;
1794
1795    -----------------------
1796    -- Read_Library_Info --
1797    -----------------------
1798
1799    function Read_Library_Info
1800      (Lib_File  : File_Name_Type;
1801       Fatal_Err : Boolean := False)
1802       return      Text_Buffer_Ptr
1803    is
1804       Lib_FD : File_Descriptor;
1805       --  The file descriptor for the current library file. A negative value
1806       --  indicates failure to open the specified source file.
1807
1808       Text : Text_Buffer_Ptr;
1809       --  Allocated text buffer.
1810
1811    begin
1812       Current_Full_Lib_Name := Find_File (Lib_File, Library);
1813       Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name);
1814
1815       if Current_Full_Lib_Name = No_File then
1816          if Fatal_Err then
1817             Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
1818          else
1819             Current_Full_Obj_Stamp := Empty_Time_Stamp;
1820             return null;
1821          end if;
1822       end if;
1823
1824       Get_Name_String (Current_Full_Lib_Name);
1825       Name_Buffer (Name_Len + 1) := ASCII.NUL;
1826
1827       --  Open the library FD, note that we open in binary mode, because as
1828       --  documented in the spec, the caller is expected to handle either
1829       --  DOS or Unix mode files, and there is no point in wasting time on
1830       --  text translation when it is not required.
1831
1832       Lib_FD := Open_Read (Name_Buffer'Address, Binary);
1833
1834       if Lib_FD = Invalid_FD then
1835          if Fatal_Err then
1836             Fail ("Cannot open: ",  Name_Buffer (1 .. Name_Len));
1837          else
1838             Current_Full_Obj_Stamp := Empty_Time_Stamp;
1839             return null;
1840          end if;
1841       end if;
1842
1843       --  Check for object file consistency if requested
1844
1845       if Opt.Check_Object_Consistency then
1846          Current_Full_Lib_Stamp := File_Stamp (Current_Full_Lib_Name);
1847          Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name);
1848
1849          if Current_Full_Obj_Stamp (1) = ' ' then
1850
1851             --  When the library is readonly, always assume that
1852             --  the object is consistent.
1853
1854             if Is_Readonly_Library (Current_Full_Lib_Name) then
1855                Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
1856
1857             elsif Fatal_Err then
1858                Get_Name_String (Current_Full_Obj_Name);
1859                Close (Lib_FD);
1860                Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
1861
1862             else
1863                Current_Full_Obj_Stamp := Empty_Time_Stamp;
1864                Close (Lib_FD);
1865                return null;
1866             end if;
1867          end if;
1868
1869          --  Object file exists, compare object and ALI time stamps
1870
1871          if Current_Full_Lib_Stamp > Current_Full_Obj_Stamp then
1872             if Fatal_Err then
1873                Get_Name_String (Current_Full_Obj_Name);
1874                Close (Lib_FD);
1875                Fail ("Bad time stamp: ", Name_Buffer (1 .. Name_Len));
1876             else
1877                Current_Full_Obj_Stamp := Empty_Time_Stamp;
1878                Close (Lib_FD);
1879                return null;
1880             end if;
1881          end if;
1882       end if;
1883
1884       --  Read data from the file
1885
1886       declare
1887          Len : Integer := Integer (File_Length (Lib_FD));
1888          --  Length of source file text. If it doesn't fit in an integer
1889          --  we're probably stuck anyway (>2 gigs of source seems a lot!)
1890
1891          Actual_Len : Integer := 0;
1892
1893          Lo : Text_Ptr := 0;
1894          --  Low bound for allocated text buffer
1895
1896          Hi : Text_Ptr := Text_Ptr (Len);
1897          --  High bound for allocated text buffer. Note length is Len + 1
1898          --  which allows for extra EOF character at the end of the buffer.
1899
1900       begin
1901          --  Allocate text buffer. Note extra character at end for EOF
1902
1903          Text := new Text_Buffer (Lo .. Hi);
1904
1905          --  Some systems (e.g. VMS) have file types that require one
1906          --  read per line, so read until we get the Len bytes or until
1907          --  there are no more characters.
1908
1909          Hi := Lo;
1910          loop
1911             Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len);
1912             Hi := Hi + Text_Ptr (Actual_Len);
1913             exit when Actual_Len = Len or Actual_Len <= 0;
1914          end loop;
1915
1916          Text (Hi) := EOF;
1917       end;
1918
1919       --  Read is complete, close file and we are done
1920
1921       Close (Lib_FD);
1922       return Text;
1923
1924    end Read_Library_Info;
1925
1926    --  Version with default file name
1927
1928    procedure Read_Library_Info
1929      (Name : out File_Name_Type;
1930       Text : out Text_Buffer_Ptr)
1931    is
1932    begin
1933       Set_Library_Info_Name;
1934       Name := Name_Find;
1935       Text := Read_Library_Info (Name, Fatal_Err => False);
1936    end Read_Library_Info;
1937
1938    ----------------------
1939    -- Read_Source_File --
1940    ----------------------
1941
1942    procedure Read_Source_File
1943      (N   : File_Name_Type;
1944       Lo  : Source_Ptr;
1945       Hi  : out Source_Ptr;
1946       Src : out Source_Buffer_Ptr;
1947       T   : File_Type := Source)
1948    is
1949       Source_File_FD : File_Descriptor;
1950       --  The file descriptor for the current source file. A negative value
1951       --  indicates failure to open the specified source file.
1952
1953       Len : Integer;
1954       --  Length of file. Assume no more than 2 gigabytes of source!
1955
1956       Actual_Len : Integer;
1957
1958    begin
1959       Current_Full_Source_Name  := Find_File (N, T);
1960       Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
1961
1962       if Current_Full_Source_Name = No_File then
1963
1964          --  If we were trying to access the main file and we could not
1965          --  find it we have an error.
1966
1967          if N = Current_Main then
1968             Get_Name_String (N);
1969             Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
1970          end if;
1971
1972          Src := null;
1973          Hi  := No_Location;
1974          return;
1975       end if;
1976
1977       Get_Name_String (Current_Full_Source_Name);
1978       Name_Buffer (Name_Len + 1) := ASCII.NUL;
1979
1980       --  Open the source FD, note that we open in binary mode, because as
1981       --  documented in the spec, the caller is expected to handle either
1982       --  DOS or Unix mode files, and there is no point in wasting time on
1983       --  text translation when it is not required.
1984
1985       Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
1986
1987       if Source_File_FD = Invalid_FD then
1988          Src := null;
1989          Hi  := No_Location;
1990          return;
1991       end if;
1992
1993       --  Prepare to read data from the file
1994
1995       Len := Integer (File_Length (Source_File_FD));
1996
1997       --  Set Hi so that length is one more than the physical length,
1998       --  allowing for the extra EOF character at the end of the buffer
1999
2000       Hi := Lo + Source_Ptr (Len);
2001
2002       --  Do the actual read operation
2003
2004       declare
2005          subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
2006          --  Physical buffer allocated
2007
2008          type Actual_Source_Ptr is access Actual_Source_Buffer;
2009          --  This is the pointer type for the physical buffer allocated
2010
2011          Actual_Ptr : Actual_Source_Ptr := new Actual_Source_Buffer;
2012          --  And this is the actual physical buffer
2013
2014       begin
2015          --  Allocate source buffer, allowing extra character at end for EOF
2016
2017          --  Some systems (e.g. VMS) have file types that require one
2018          --  read per line, so read until we get the Len bytes or until
2019          --  there are no more characters.
2020
2021          Hi := Lo;
2022          loop
2023             Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
2024             Hi := Hi + Source_Ptr (Actual_Len);
2025             exit when Actual_Len = Len or Actual_Len <= 0;
2026          end loop;
2027
2028          Actual_Ptr (Hi) := EOF;
2029
2030          --  Now we need to work out the proper virtual origin pointer to
2031          --  return. This is exactly Actual_Ptr (0)'Address, but we have
2032          --  to be careful to suppress checks to compute this address.
2033
2034          declare
2035             pragma Suppress (All_Checks);
2036
2037             function To_Source_Buffer_Ptr is new
2038               Unchecked_Conversion (Address, Source_Buffer_Ptr);
2039
2040          begin
2041             Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
2042          end;
2043       end;
2044
2045       --  Read is complete, get time stamp and close file and we are done
2046
2047       Close (Source_File_FD);
2048
2049    end Read_Source_File;
2050
2051    --------------------------------
2052    -- Record_Time_From_Last_Bind --
2053    --------------------------------
2054
2055    procedure Record_Time_From_Last_Bind is
2056    begin
2057       Recording_Time_From_Last_Bind := True;
2058    end Record_Time_From_Last_Bind;
2059
2060    ---------------------------
2061    -- Set_Library_Info_Name --
2062    ---------------------------
2063
2064    procedure Set_Library_Info_Name is
2065       Dot_Index : Natural;
2066
2067    begin
2068       pragma Assert (In_Compiler);
2069       Get_Name_String (Current_Main);
2070
2071       --  Find last dot since we replace the existing extension by .ali. The
2072       --  initialization to Name_Len + 1 provides for simply adding the .ali
2073       --  extension if the source file name has no extension.
2074
2075       Dot_Index := Name_Len + 1;
2076       for J in reverse 1 .. Name_Len loop
2077          if Name_Buffer (J) = '.' then
2078             Dot_Index := J;
2079             exit;
2080          end if;
2081       end loop;
2082
2083       --  Make sure that the output file name matches the source file name.
2084       --  To compare them, remove file name directories and extensions.
2085
2086       if Output_Object_File_Name /= null then
2087          declare
2088             Name : constant String  := Name_Buffer (1 .. Dot_Index);
2089             Len  : constant Natural := Dot_Index;
2090
2091          begin
2092             Name_Buffer (1 .. Output_Object_File_Name'Length)
2093                := Output_Object_File_Name.all;
2094             Dot_Index := 0;
2095
2096             for J in reverse Output_Object_File_Name'Range loop
2097                if Name_Buffer (J) = '.' then
2098                   Dot_Index := J;
2099                   exit;
2100                end if;
2101             end loop;
2102
2103             pragma Assert (Dot_Index /= 0);
2104             --  We check for the extension elsewhere
2105
2106             if Name /= Name_Buffer (Dot_Index - Len + 1 .. Dot_Index) then
2107                Fail ("incorrect object file name");
2108             end if;
2109          end;
2110       end if;
2111
2112       Name_Buffer (Dot_Index) := '.';
2113       Name_Buffer (Dot_Index + 1 .. Dot_Index + 3) := ALI_Suffix.all;
2114       Name_Buffer (Dot_Index + 4) := ASCII.NUL;
2115       Name_Len := Dot_Index + 3;
2116    end Set_Library_Info_Name;
2117
2118    ---------------------------------
2119    -- Set_Output_Object_File_Name --
2120    ---------------------------------
2121
2122    procedure Set_Output_Object_File_Name (Name : String) is
2123       Ext : constant String := Object_Suffix;
2124       NL  : constant Natural := Name'Length;
2125       EL  : constant Natural := Ext'Length;
2126
2127    begin
2128       --  Make sure that the object file has the expected extension.
2129
2130       if NL <= EL
2131          or else Name (NL - EL + Name'First .. Name'Last) /= Ext
2132       then
2133          Fail ("incorrect object file extension");
2134       end if;
2135
2136       Output_Object_File_Name := new String'(Name);
2137    end Set_Output_Object_File_Name;
2138
2139    ------------------------
2140    -- Set_Main_File_Name --
2141    ------------------------
2142
2143    procedure Set_Main_File_Name (Name : String) is
2144    begin
2145       Number_File_Names := Number_File_Names + 1;
2146       File_Names (Number_File_Names) := new String'(Name);
2147    end Set_Main_File_Name;
2148
2149    ----------------------
2150    -- Smart_File_Stamp --
2151    ----------------------
2152
2153    function Smart_File_Stamp
2154      (N    : File_Name_Type;
2155       T    : File_Type)
2156       return Time_Stamp_Type
2157    is
2158       Time_Stamp : Time_Stamp_Type;
2159
2160    begin
2161       if not File_Cache_Enabled then
2162          return File_Stamp (Find_File (N, T));
2163       end if;
2164
2165       Time_Stamp := File_Stamp_Hash_Table.Get (N);
2166
2167       if Time_Stamp (1) = ' ' then
2168          Time_Stamp := File_Stamp (Smart_Find_File (N, T));
2169          File_Stamp_Hash_Table.Set (N, Time_Stamp);
2170       end if;
2171
2172       return Time_Stamp;
2173    end Smart_File_Stamp;
2174
2175    ---------------------
2176    -- Smart_Find_File --
2177    ---------------------
2178
2179    function Smart_Find_File
2180      (N : File_Name_Type;
2181       T : File_Type)
2182       return File_Name_Type
2183    is
2184       Full_File_Name : File_Name_Type;
2185
2186    begin
2187       if not File_Cache_Enabled then
2188          return Find_File (N, T);
2189       end if;
2190
2191       Full_File_Name := File_Name_Hash_Table.Get (N);
2192
2193       if Full_File_Name = No_File then
2194          Full_File_Name := Find_File (N, T);
2195          File_Name_Hash_Table.Set (N, Full_File_Name);
2196       end if;
2197
2198       return Full_File_Name;
2199    end Smart_Find_File;
2200
2201    ----------------------
2202    -- Source_File_Data --
2203    ----------------------
2204
2205    procedure Source_File_Data (Cache : Boolean) is
2206    begin
2207       File_Cache_Enabled := Cache;
2208    end Source_File_Data;
2209
2210    -----------------------
2211    -- Source_File_Stamp --
2212    -----------------------
2213
2214    function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
2215    begin
2216       return Smart_File_Stamp (N, Source);
2217    end Source_File_Stamp;
2218
2219    ---------------------
2220    -- Strip_Directory --
2221    ---------------------
2222
2223    function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
2224    begin
2225       Get_Name_String (Name);
2226
2227       declare
2228          S : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
2229          Fptr : Natural := S'First;
2230
2231       begin
2232          for J in reverse S'Range loop
2233             if Is_Directory_Separator (S (J)) then
2234                Fptr := J + 1;
2235                exit;
2236             end if;
2237          end loop;
2238
2239          if Fptr = S'First then
2240             return Name;
2241          end if;
2242
2243          Name_Buffer (1 .. S'Last - Fptr + 1) := S (Fptr .. S'Last);
2244          Name_Len :=  S'Last - Fptr + 1;
2245          return Name_Find;
2246       end;
2247    end Strip_Directory;
2248
2249    ------------------
2250    -- Strip_Suffix --
2251    ------------------
2252
2253    function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
2254    begin
2255       Get_Name_String (Name);
2256
2257       for J in reverse 1 .. Name_Len loop
2258          if Name_Buffer (J) = '.' then
2259             Name_Len := J - 1;
2260             return Name_Enter;
2261          end if;
2262       end loop;
2263
2264       return Name;
2265    end Strip_Suffix;
2266
2267    -------------------------
2268    -- Time_From_Last_Bind --
2269    -------------------------
2270
2271    function Time_From_Last_Bind return Nat is
2272       Old_Y  : Nat;
2273       Old_M  : Nat;
2274       Old_D  : Nat;
2275       Old_H  : Nat;
2276       Old_Mi : Nat;
2277       Old_S  : Nat;
2278       New_Y  : Nat;
2279       New_M  : Nat;
2280       New_D  : Nat;
2281       New_H  : Nat;
2282       New_Mi : Nat;
2283       New_S  : Nat;
2284
2285       type Month_Data is array (Int range 1 .. 12) of Int;
2286       Cumul : constant Month_Data := (0, 0, 3, 3, 4, 4, 5, 5, 5, 6, 6, 7);
2287       --  Represents the difference in days from a period compared to the
2288       --  same period if all months had 31 days, i.e:
2289       --
2290       --    Cumul (m) = 31x(m-1) - (number of days from 01/01 to m/01)
2291
2292       Res : Int;
2293
2294    begin
2295       if not Recording_Time_From_Last_Bind
2296         or else not Binder_Output_Time_Stamps_Set
2297         or else Old_Binder_Output_Time_Stamp = Empty_Time_Stamp
2298       then
2299          return Nat'Last;
2300       end if;
2301
2302       Split_Time_Stamp
2303        (Old_Binder_Output_Time_Stamp,
2304         Old_Y, Old_M, Old_D, Old_H, Old_Mi, Old_S);
2305
2306       Split_Time_Stamp
2307        (New_Binder_Output_Time_Stamp,
2308         New_Y, New_M, New_D, New_H, New_Mi, New_S);
2309
2310       Res := New_Mi - Old_Mi;
2311
2312       --  60 minutes in an hour
2313
2314       Res := Res + 60 * (New_H  - Old_H);
2315
2316       --  24 hours in a day
2317
2318       Res := Res + 60 * 24 * (New_D  - Old_D);
2319
2320       --  Almost 31 days in a month
2321
2322       Res := Res + 60 * 24 *
2323         (31 * (New_M - Old_M) - Cumul (New_M) + Cumul (Old_M));
2324
2325       --  365 days in a year
2326
2327       Res := Res + 60 * 24 * 365 * (New_Y - Old_Y);
2328
2329       return Res;
2330    end Time_From_Last_Bind;
2331
2332    ---------------------------
2333    -- To_Canonical_Dir_Spec --
2334    ---------------------------
2335
2336    function To_Canonical_Dir_Spec
2337      (Host_Dir     : String;
2338       Prefix_Style : Boolean)
2339       return         String_Access
2340    is
2341       function To_Canonical_Dir_Spec
2342         (Host_Dir    : Address;
2343          Prefix_Flag : Integer)
2344          return        Address;
2345       pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
2346
2347       C_Host_Dir      : String (1 .. Host_Dir'Length + 1);
2348       Canonical_Dir_Addr : Address;
2349       Canonical_Dir_Len  : Integer;
2350
2351    begin
2352       C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir;
2353       C_Host_Dir (C_Host_Dir'Last)      := ASCII.NUL;
2354
2355       if Prefix_Style then
2356          Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1);
2357       else
2358          Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
2359       end if;
2360       Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);
2361
2362       if Canonical_Dir_Len = 0 then
2363          return null;
2364       else
2365          return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len);
2366       end if;
2367
2368    exception
2369       when others =>
2370          Fail ("erroneous directory spec: ", Host_Dir);
2371          return null;
2372    end To_Canonical_Dir_Spec;
2373
2374    ---------------------------
2375    -- To_Canonical_File_List --
2376    ---------------------------
2377
2378    function To_Canonical_File_List
2379      (Wildcard_Host_File : String;
2380       Only_Dirs          : Boolean)
2381       return               String_Access_List_Access
2382    is
2383       function To_Canonical_File_List_Init
2384         (Host_File : Address;
2385          Only_Dirs : Integer)
2386       return Integer;
2387       pragma Import (C, To_Canonical_File_List_Init,
2388                      "__gnat_to_canonical_file_list_init");
2389
2390       function To_Canonical_File_List_Next return Address;
2391       pragma Import (C, To_Canonical_File_List_Next,
2392                      "__gnat_to_canonical_file_list_next");
2393
2394       procedure To_Canonical_File_List_Free;
2395       pragma Import (C, To_Canonical_File_List_Free,
2396                      "__gnat_to_canonical_file_list_free");
2397
2398       Num_Files            : Integer;
2399       C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
2400
2401    begin
2402       C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
2403         Wildcard_Host_File;
2404       C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
2405
2406       --  Do the expansion and say how many there are
2407
2408       Num_Files := To_Canonical_File_List_Init
2409          (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
2410
2411       declare
2412          Canonical_File_List : String_Access_List (1 .. Num_Files);
2413          Canonical_File_Addr : Address;
2414          Canonical_File_Len  : Integer;
2415
2416       begin
2417          --  Retrieve the expanded directoy names and build the list
2418
2419          for J in 1 .. Num_Files loop
2420             Canonical_File_Addr := To_Canonical_File_List_Next;
2421             Canonical_File_Len  := C_String_Length (Canonical_File_Addr);
2422             Canonical_File_List (J) := To_Path_String_Access
2423                   (Canonical_File_Addr, Canonical_File_Len);
2424          end loop;
2425
2426          --  Free up the storage
2427
2428          To_Canonical_File_List_Free;
2429
2430          return new String_Access_List'(Canonical_File_List);
2431       end;
2432    end To_Canonical_File_List;
2433
2434    ----------------------------
2435    -- To_Canonical_File_Spec --
2436    ----------------------------
2437
2438    function To_Canonical_File_Spec
2439      (Host_File : String)
2440       return      String_Access
2441    is
2442       function To_Canonical_File_Spec (Host_File : Address) return Address;
2443       pragma Import
2444         (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
2445
2446       C_Host_File      : String (1 .. Host_File'Length + 1);
2447       Canonical_File_Addr : Address;
2448       Canonical_File_Len  : Integer;
2449
2450    begin
2451       C_Host_File (1 .. Host_File'Length) := Host_File;
2452       C_Host_File (C_Host_File'Last)      := ASCII.NUL;
2453
2454       Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address);
2455       Canonical_File_Len  := C_String_Length (Canonical_File_Addr);
2456
2457       if Canonical_File_Len = 0 then
2458          return null;
2459       else
2460          return To_Path_String_Access
2461                   (Canonical_File_Addr, Canonical_File_Len);
2462       end if;
2463
2464    exception
2465       when others =>
2466          Fail ("erroneous file spec: ", Host_File);
2467          return null;
2468    end To_Canonical_File_Spec;
2469
2470    ----------------------------
2471    -- To_Canonical_Path_Spec --
2472    ----------------------------
2473
2474    function To_Canonical_Path_Spec
2475      (Host_Path : String)
2476       return      String_Access
2477    is
2478       function To_Canonical_Path_Spec (Host_Path : Address) return Address;
2479       pragma Import
2480         (C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec");
2481
2482       C_Host_Path         : String (1 .. Host_Path'Length + 1);
2483       Canonical_Path_Addr : Address;
2484       Canonical_Path_Len  : Integer;
2485
2486    begin
2487       C_Host_Path (1 .. Host_Path'Length) := Host_Path;
2488       C_Host_Path (C_Host_Path'Last)      := ASCII.NUL;
2489
2490       Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address);
2491       Canonical_Path_Len  := C_String_Length (Canonical_Path_Addr);
2492
2493       --  Return a null string (vice a null) for zero length paths, for
2494       --  compatibility with getenv().
2495
2496       return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len);
2497
2498    exception
2499       when others =>
2500          Fail ("erroneous path spec: ", Host_Path);
2501          return null;
2502    end To_Canonical_Path_Spec;
2503
2504    ---------------------------
2505    -- To_Host_Dir_Spec --
2506    ---------------------------
2507
2508    function To_Host_Dir_Spec
2509      (Canonical_Dir : String;
2510       Prefix_Style  : Boolean)
2511       return          String_Access
2512    is
2513       function To_Host_Dir_Spec
2514         (Canonical_Dir : Address;
2515          Prefix_Flag   : Integer)
2516          return          Address;
2517       pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
2518
2519       C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
2520       Host_Dir_Addr   : Address;
2521       Host_Dir_Len    : Integer;
2522
2523    begin
2524       C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir;
2525       C_Canonical_Dir (C_Canonical_Dir'Last)      := ASCII.NUL;
2526
2527       if Prefix_Style then
2528          Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1);
2529       else
2530          Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0);
2531       end if;
2532       Host_Dir_Len := C_String_Length (Host_Dir_Addr);
2533
2534       if Host_Dir_Len = 0 then
2535          return null;
2536       else
2537          return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len);
2538       end if;
2539    end To_Host_Dir_Spec;
2540
2541    ----------------------------
2542    -- To_Host_File_Spec --
2543    ----------------------------
2544
2545    function To_Host_File_Spec
2546      (Canonical_File : String)
2547       return           String_Access
2548    is
2549       function To_Host_File_Spec (Canonical_File : Address) return Address;
2550       pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
2551
2552       C_Canonical_File      : String (1 .. Canonical_File'Length + 1);
2553       Host_File_Addr : Address;
2554       Host_File_Len  : Integer;
2555
2556    begin
2557       C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File;
2558       C_Canonical_File (C_Canonical_File'Last)      := ASCII.NUL;
2559
2560       Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address);
2561       Host_File_Len  := C_String_Length (Host_File_Addr);
2562
2563       if Host_File_Len = 0 then
2564          return null;
2565       else
2566          return To_Path_String_Access
2567                   (Host_File_Addr, Host_File_Len);
2568       end if;
2569    end To_Host_File_Spec;
2570
2571    ---------------------------
2572    -- To_Path_String_Access --
2573    ---------------------------
2574
2575    function To_Path_String_Access
2576      (Path_Addr : Address;
2577       Path_Len  : Integer)
2578       return      String_Access
2579    is
2580       subtype Path_String is String (1 .. Path_Len);
2581       type    Path_String_Access is access Path_String;
2582
2583       function Address_To_Access is new
2584         Unchecked_Conversion (Source => Address,
2585                               Target => Path_String_Access);
2586
2587       Path_Access : Path_String_Access := Address_To_Access (Path_Addr);
2588
2589       Return_Val  : String_Access;
2590
2591    begin
2592       Return_Val := new String (1 .. Path_Len);
2593
2594       for J in 1 .. Path_Len loop
2595          Return_Val (J) := Path_Access (J);
2596       end loop;
2597
2598       return Return_Val;
2599    end To_Path_String_Access;
2600
2601    ----------------
2602    -- Tree_Close --
2603    ----------------
2604
2605    procedure Tree_Close is
2606    begin
2607       pragma Assert (In_Compiler);
2608       Tree_Write_Terminate;
2609       Close (Output_FD);
2610    end Tree_Close;
2611
2612    -----------------
2613    -- Tree_Create --
2614    -----------------
2615
2616    procedure Tree_Create is
2617       Dot_Index : Natural;
2618
2619    begin
2620       pragma Assert (In_Compiler);
2621       Get_Name_String (Current_Main);
2622
2623       --  If an object file has been specified, then the ALI file
2624       --  will be in the same directory as the object file;
2625       --  so, we put the tree file in this same directory,
2626       --  even though no object file needs to be generated.
2627
2628       if Output_Object_File_Name /= null then
2629          Name_Len := Output_Object_File_Name'Length;
2630          Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
2631       end if;
2632
2633       Dot_Index := 0;
2634       for J in reverse 1 .. Name_Len loop
2635          if Name_Buffer (J) = '.' then
2636             Dot_Index := J;
2637             exit;
2638          end if;
2639       end loop;
2640
2641       --  Should be impossible to not have an extension
2642
2643       pragma Assert (Dot_Index /= 0);
2644
2645       --  Change exctension to adt
2646
2647       Name_Buffer (Dot_Index + 1) := 'a';
2648       Name_Buffer (Dot_Index + 2) := 'd';
2649       Name_Buffer (Dot_Index + 3) := 't';
2650       Name_Buffer (Dot_Index + 4) := ASCII.NUL;
2651       Name_Len := Dot_Index + 3;
2652       Create_File_And_Check (Output_FD, Binary);
2653
2654       Tree_Write_Initialize (Output_FD);
2655    end Tree_Create;
2656
2657    ----------------
2658    -- Write_Info --
2659    ----------------
2660
2661    procedure Write_Info (Info : String) is
2662    begin
2663       pragma Assert (In_Binder or In_Compiler);
2664       Write_With_Check (Info'Address, Info'Length);
2665       Write_With_Check (EOL'Address, 1);
2666    end Write_Info;
2667
2668    -----------------------
2669    -- Write_Binder_Info --
2670    -----------------------
2671
2672    procedure Write_Binder_Info (Info : String) renames Write_Info;
2673
2674    -----------------------
2675    -- Write_Debug_Info --
2676    -----------------------
2677
2678    procedure Write_Debug_Info (Info : String) renames Write_Info;
2679
2680    ------------------------
2681    -- Write_Library_Info --
2682    ------------------------
2683
2684    procedure Write_Library_Info (Info : String) renames Write_Info;
2685
2686    ------------------------
2687    -- Write_Program_Name --
2688    ------------------------
2689
2690    procedure Write_Program_Name is
2691       Save_Buffer : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
2692
2693    begin
2694
2695       Find_Program_Name;
2696
2697       --  Convert the name to lower case so error messages are the same on
2698       --  all systems.
2699
2700       for J in 1 .. Name_Len loop
2701          if Name_Buffer (J) in 'A' .. 'Z' then
2702             Name_Buffer (J) :=
2703               Character'Val (Character'Pos (Name_Buffer (J)) + 32);
2704          end if;
2705       end loop;
2706
2707       Write_Str (Name_Buffer (1 .. Name_Len));
2708
2709       --  Restore Name_Buffer which was clobbered by the call to
2710       --  Find_Program_Name
2711
2712       Name_Len := Save_Buffer'Last;
2713       Name_Buffer (1 .. Name_Len) := Save_Buffer;
2714    end Write_Program_Name;
2715
2716    ----------------------
2717    -- Write_With_Check --
2718    ----------------------
2719
2720    procedure Write_With_Check (A  : Address; N  : Integer) is
2721       Ignore : Boolean;
2722
2723    begin
2724       if N = Write (Output_FD, A, N) then
2725          return;
2726
2727       else
2728          Write_Str ("error: disk full writing ");
2729          Write_Name_Decoded (Output_File_Name);
2730          Write_Eol;
2731          Name_Len := Name_Len + 1;
2732          Name_Buffer (Name_Len) := ASCII.NUL;
2733          Delete_File (Name_Buffer'Address, Ignore);
2734          Exit_Program (E_Fatal);
2735       end if;
2736    end Write_With_Check;
2737
2738 end Osint;