OSDN Git Service

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