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