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