|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- F M A P --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 2001-2018, Free Software Foundation, Inc. --
|
|
111
|
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 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) rem 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) rem 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
|
|
|
531 end Fmap;
|
