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