Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/fmap.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- F M A P --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2017, 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 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;