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