1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                                 F M A P                                  --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 2001-2021, 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 3,  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 COPYING3.  If not, go to --
19-- http://www.gnu.org/licenses for a complete copy of the license.          --
20--                                                                          --
21-- GNAT was originally developed  by the GNAT team at  New York University. --
22-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23--                                                                          --
24------------------------------------------------------------------------------
25
26with Opt;    use Opt;
27with Osint;  use Osint;
28with Output; use Output;
29with Table;
30with Types;  use Types;
31
32pragma Warnings (Off);
33--  This package is used also by gnatcoll
34with System.OS_Lib; use System.OS_Lib;
35pragma Warnings (On);
36
37with Unchecked_Conversion;
38
39with GNAT.HTable;
40
41package body Fmap is
42
43   No_Mapping_File : Boolean := False;
44   --  Set to True when the specified mapping file cannot be read in
45   --  procedure Initialize, so that no attempt is made to open the mapping
46   --  file in procedure Update_Mapping_File.
47
48   Max_Buffer : constant := 1_500;
49   Buffer : String (1 .. Max_Buffer);
50   --  Used to buffer output when writing to a new mapping file
51
52   Buffer_Last : Natural := 0;
53   --  Index of last valid character in Buffer
54
55   type Mapping is record
56      Uname : Unit_Name_Type;
57      Fname : File_Name_Type;
58   end record;
59
60   package File_Mapping is new Table.Table (
61     Table_Component_Type => Mapping,
62     Table_Index_Type     => Int,
63     Table_Low_Bound      => 0,
64     Table_Initial        => 1_000,
65     Table_Increment      => 1_000,
66     Table_Name           => "Fmap.File_Mapping");
67   --  Mapping table to map unit names to file names
68
69   package Path_Mapping is new Table.Table (
70     Table_Component_Type => Mapping,
71     Table_Index_Type     => Int,
72     Table_Low_Bound      => 0,
73     Table_Initial        => 1_000,
74     Table_Increment      => 1_000,
75     Table_Name           => "Fmap.Path_Mapping");
76   --  Mapping table to map file names to path names
77
78   type Header_Num is range 0 .. 1_000;
79
80   function Hash (F : Unit_Name_Type) return Header_Num;
81   --  Function used to compute hash of unit name
82
83   No_Entry : constant Int := -1;
84   --  Signals no entry in following table
85
86   package Unit_Hash_Table is new GNAT.HTable.Simple_HTable (
87     Header_Num => Header_Num,
88     Element    => Int,
89     No_Element => No_Entry,
90     Key        => Unit_Name_Type,
91     Hash       => Hash,
92     Equal      => "=");
93   --  Hash table to map unit names to file names. Used in conjunction with
94   --  table File_Mapping above.
95
96   function Hash (F : File_Name_Type) return Header_Num;
97   --  Function used to compute hash of file name
98
99   package File_Hash_Table is new GNAT.HTable.Simple_HTable (
100     Header_Num => Header_Num,
101     Element    => Int,
102     No_Element => No_Entry,
103     Key        => File_Name_Type,
104     Hash       => Hash,
105     Equal      => "=");
106   --  Hash table to map file names to path names. Used in conjunction with
107   --  table Path_Mapping above.
108
109   Last_In_Table : Int := 0;
110
111   package Forbidden_Names is new GNAT.HTable.Simple_HTable (
112     Header_Num => Header_Num,
113     Element    => Boolean,
114     No_Element => False,
115     Key        => File_Name_Type,
116     Hash       => Hash,
117     Equal      => "=");
118
119   -----------------------------
120   -- Add_Forbidden_File_Name --
121   -----------------------------
122
123   procedure Add_Forbidden_File_Name (Name : File_Name_Type) is
124   begin
125      Forbidden_Names.Set (Name, True);
126   end Add_Forbidden_File_Name;
127
128   ---------------------
129   -- Add_To_File_Map --
130   ---------------------
131
132   procedure Add_To_File_Map
133     (Unit_Name : Unit_Name_Type;
134      File_Name : File_Name_Type;
135      Path_Name : File_Name_Type)
136   is
137      Unit_Entry : constant Int := Unit_Hash_Table.Get (Unit_Name);
138      File_Entry : constant Int := File_Hash_Table.Get (File_Name);
139   begin
140      if Unit_Entry = No_Entry or else
141        File_Mapping.Table (Unit_Entry).Fname /= File_Name
142      then
143         File_Mapping.Increment_Last;
144         Unit_Hash_Table.Set (Unit_Name, File_Mapping.Last);
145         File_Mapping.Table (File_Mapping.Last) :=
146           (Uname => Unit_Name, Fname => File_Name);
147      end if;
148
149      if File_Entry = No_Entry or else
150        Path_Mapping.Table (File_Entry).Fname /= Path_Name
151      then
152         Path_Mapping.Increment_Last;
153         File_Hash_Table.Set (File_Name, Path_Mapping.Last);
154         Path_Mapping.Table (Path_Mapping.Last) :=
155           (Uname => Unit_Name, Fname => Path_Name);
156      end if;
157   end Add_To_File_Map;
158
159   ----------
160   -- Hash --
161   ----------
162
163   function Hash (F : File_Name_Type) return Header_Num is
164   begin
165      return Header_Num (Int (F) mod Header_Num'Range_Length);
166   end Hash;
167
168   function Hash (F : Unit_Name_Type) return Header_Num is
169   begin
170      return Header_Num (Int (F) mod Header_Num'Range_Length);
171   end Hash;
172
173   ----------------
174   -- Initialize --
175   ----------------
176
177   procedure Initialize (File_Name : String) is
178      FD  : File_Descriptor;
179      Src : Source_Buffer_Ptr;
180      Hi  : Source_Ptr;
181
182      First : Source_Ptr := 1;
183      Last  : Source_Ptr := 0;
184
185      Uname : Unit_Name_Type;
186      Fname : File_Name_Type;
187      Pname : File_Name_Type;
188
189      procedure Empty_Tables;
190      --  Remove all entries in case of incorrect mapping file
191
192      function Find_File_Name return File_Name_Type;
193      --  Return Error_File_Name if the name buffer contains "/", otherwise
194      --  call Name_Find. "/" is the path name in the mapping file to indicate
195      --  that a source has been suppressed, and thus should not be found by
196      --  the compiler.
197
198      function Find_Unit_Name return Unit_Name_Type;
199      --  Return the unit name in the name buffer. Return Error_Unit_Name if
200      --  the name buffer contains "/".
201
202      procedure Get_Line;
203      --  Get a line from the mapping file, where a line is Src (First .. Last)
204
205      procedure Report_Truncated;
206      --  Report a warning when the mapping file is truncated
207      --  (number of lines is not a multiple of 3).
208
209      ------------------
210      -- Empty_Tables --
211      ------------------
212
213      procedure Empty_Tables is
214      begin
215         Unit_Hash_Table.Reset;
216         File_Hash_Table.Reset;
217         Path_Mapping.Set_Last (0);
218         File_Mapping.Set_Last (0);
219         Last_In_Table := 0;
220      end Empty_Tables;
221
222      --------------------
223      -- Find_File_Name --
224      --------------------
225
226      function Find_File_Name return File_Name_Type is
227      begin
228         if Name_Buffer (1 .. Name_Len) = "/" then
229
230            --  A path name of "/" is the indication that the source has been
231            --  "suppressed". Return Error_File_Name so that the compiler does
232            --  not find the source, even if it is in the include path.
233
234            return Error_File_Name;
235
236         else
237            return Name_Find;
238         end if;
239      end Find_File_Name;
240
241      --------------------
242      -- Find_Unit_Name --
243      --------------------
244
245      function Find_Unit_Name return Unit_Name_Type is
246      begin
247         return Unit_Name_Type (Find_File_Name);
248      end Find_Unit_Name;
249
250      --------------
251      -- Get_Line --
252      --------------
253
254      procedure Get_Line is
255         use ASCII;
256
257      begin
258         First := Last + 1;
259
260         --  If not at the end of file, skip the end of line
261
262         while First < Src'Last
263           and then (Src (First) = CR
264                      or else Src (First) = LF
265                      or else Src (First) = EOF)
266         loop
267            First := First + 1;
268         end loop;
269
270         --  If not at the end of file, find the end of this new line
271
272         if First < Src'Last and then Src (First) /= EOF then
273            Last := First;
274
275            while Last < Src'Last
276              and then Src (Last + 1) /= CR
277              and then Src (Last + 1) /= LF
278              and then Src (Last + 1) /= EOF
279            loop
280               Last := Last + 1;
281            end loop;
282
283         end if;
284      end Get_Line;
285
286      ----------------------
287      -- Report_Truncated --
288      ----------------------
289
290      procedure Report_Truncated is
291      begin
292         Write_Str ("warning: mapping file """);
293         Write_Str (File_Name);
294         Write_Line (""" is truncated");
295      end Report_Truncated;
296
297   --  Start of processing for Initialize
298
299   begin
300      Empty_Tables;
301      Read_Source_File (Name_Enter (File_Name), 1, Hi, Src, FD, Config);
302
303      if Null_Source_Buffer_Ptr (Src) then
304         if FD = Null_FD then
305            Write_Str ("warning: could not locate mapping file """);
306         else
307            Write_Str ("warning: no read access for mapping file """);
308         end if;
309
310         Write_Str (File_Name);
311         Write_Line ("""");
312         No_Mapping_File := True;
313
314      else
315         loop
316            --  Get the unit name
317
318            Get_Line;
319
320            --  Exit if end of file has been reached
321
322            exit when First > Last;
323
324            if (Last < First + 2) or else (Src (Last - 1) /= '%')
325              or else (Src (Last) /= 's' and then Src (Last) /= 'b')
326            then
327               Write_Line
328                 ("warning: mapping file """ & File_Name &
329                  """ is incorrectly formatted");
330               Write_Line ("Line = """ & String (Src (First .. Last)) & '"');
331               Empty_Tables;
332               return;
333            end if;
334
335            Name_Len := Integer (Last - First + 1);
336            Name_Buffer (1 .. Name_Len) := String (Src (First .. Last));
337            Uname := Find_Unit_Name;
338
339            --  Get the file name
340
341            Get_Line;
342
343            --  If end of line has been reached, file is truncated
344
345            if First > Last then
346               Report_Truncated;
347               Empty_Tables;
348               return;
349            end if;
350
351            Name_Len := Integer (Last - First + 1);
352            Name_Buffer (1 .. Name_Len) := String (Src (First .. Last));
353            Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
354            Fname := Find_File_Name;
355
356            --  Get the path name
357
358            Get_Line;
359
360            --  If end of line has been reached, file is truncated
361
362            if First > Last then
363               Report_Truncated;
364               Empty_Tables;
365               return;
366            end if;
367
368            Name_Len := Integer (Last - First + 1);
369            Name_Buffer (1 .. Name_Len) := String (Src (First .. Last));
370            Pname := Find_File_Name;
371
372            --  Add the mappings for this unit name
373
374            Add_To_File_Map (Uname, Fname, Pname);
375         end loop;
376      end if;
377
378      --  Record the length of the two mapping tables
379
380      Last_In_Table := File_Mapping.Last;
381   end Initialize;
382
383   ----------------------
384   -- Mapped_File_Name --
385   ----------------------
386
387   function Mapped_File_Name (Unit : Unit_Name_Type) return File_Name_Type is
388      The_Index : constant Int := Unit_Hash_Table.Get (Unit);
389
390   begin
391      if The_Index = No_Entry then
392         return No_File;
393      else
394         return File_Mapping.Table (The_Index).Fname;
395      end if;
396   end Mapped_File_Name;
397
398   ----------------------
399   -- Mapped_Path_Name --
400   ----------------------
401
402   function Mapped_Path_Name (File : File_Name_Type) return File_Name_Type is
403      Index : Int := No_Entry;
404
405   begin
406      if Forbidden_Names.Get (File) then
407         return Error_File_Name;
408      end if;
409
410      Index := File_Hash_Table.Get (File);
411
412      if Index = No_Entry then
413         return No_File;
414      else
415         return Path_Mapping.Table (Index).Fname;
416      end if;
417   end Mapped_Path_Name;
418
419   ------------------
420   -- Reset_Tables --
421   ------------------
422
423   procedure Reset_Tables is
424   begin
425      File_Mapping.Init;
426      Path_Mapping.Init;
427      Unit_Hash_Table.Reset;
428      File_Hash_Table.Reset;
429      Forbidden_Names.Reset;
430      Last_In_Table := 0;
431   end Reset_Tables;
432
433   -------------------------
434   -- Update_Mapping_File --
435   -------------------------
436
437   procedure Update_Mapping_File (File_Name : String) is
438      File    : File_Descriptor;
439      N_Bytes : Integer;
440
441      File_Entry : Int;
442
443      Status : Boolean;
444      --  For the call to Close
445
446      procedure Put_Line (Name : Name_Id);
447      --  Put Name as a line in the Mapping File
448
449      --------------
450      -- Put_Line --
451      --------------
452
453      procedure Put_Line (Name : Name_Id) is
454      begin
455         Get_Name_String (Name);
456
457         --  If the Buffer is full, write it to the file
458
459         if Buffer_Last + Name_Len + 1 > Buffer'Last then
460            N_Bytes := Write (File, Buffer (1)'Address, Buffer_Last);
461
462            if N_Bytes < Buffer_Last then
463               Fail ("disk full");
464            end if;
465
466            Buffer_Last := 0;
467         end if;
468
469         --  Add the line to the Buffer
470
471         Buffer (Buffer_Last + 1 .. Buffer_Last + Name_Len) :=
472           Name_Buffer (1 .. Name_Len);
473         Buffer_Last := Buffer_Last + Name_Len + 1;
474         Buffer (Buffer_Last) := ASCII.LF;
475      end Put_Line;
476
477   --  Start of processing for Update_Mapping_File
478
479   begin
480      --  If the mapping file could not be read, then it will not be possible
481      --  to update it.
482
483      if No_Mapping_File then
484         return;
485      end if;
486      --  Only Update if there are new entries in the mappings
487
488      if Last_In_Table < File_Mapping.Last then
489
490         File := Open_Read_Write (Name => File_Name, Fmode => Binary);
491
492         if File /= Invalid_FD then
493            if Last_In_Table > 0 then
494               Lseek (File, 0, Seek_End);
495            end if;
496
497            for Unit in Last_In_Table + 1 .. File_Mapping.Last loop
498               Put_Line (Name_Id (File_Mapping.Table (Unit).Uname));
499               Put_Line (Name_Id (File_Mapping.Table (Unit).Fname));
500               File_Entry :=
501                 File_Hash_Table.Get (File_Mapping.Table (Unit).Fname);
502               Put_Line (Name_Id (Path_Mapping.Table (File_Entry).Fname));
503            end loop;
504
505            --  Before closing the file, write the buffer to the file. It is
506            --  guaranteed that the Buffer is not empty, because Put_Line has
507            --  been called at least 3 times, and after a call to Put_Line, the
508            --  Buffer is not empty.
509
510            N_Bytes := Write (File, Buffer (1)'Address, Buffer_Last);
511
512            if N_Bytes < Buffer_Last then
513               Fail ("disk full");
514            end if;
515
516            Close (File, Status);
517
518            if not Status then
519               Fail ("disk full");
520            end if;
521
522         elsif not Quiet_Output then
523            Write_Str ("warning: could not open mapping file """);
524            Write_Str (File_Name);
525            Write_Line (""" for update");
526         end if;
527
528      end if;
529   end Update_Mapping_File;
530
531end Fmap;
532