Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/fname-uf.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 N A M E . U F --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-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 Alloc;
27 with Debug; use Debug;
28 with Fmap; use Fmap;
29 with Krunch;
30 with Opt; use Opt;
31 with Osint; use Osint;
32 with Table;
33 with Uname; use Uname;
34 with Widechar; use Widechar;
35
36 with GNAT.HTable;
37
38 package body Fname.UF is
39
40 --------------------------------------------------------
41 -- Declarations for Handling Source_File_Name pragmas --
42 --------------------------------------------------------
43
44 type SFN_Entry is record
45 U : Unit_Name_Type; -- Unit name
46 F : File_Name_Type; -- Spec/Body file name
47 Index : Nat; -- Index from SFN pragma (0 if none)
48 end record;
49 -- Record single Unit_Name type call to Set_File_Name
50
51 package SFN_Table is new Table.Table (
52 Table_Component_Type => SFN_Entry,
53 Table_Index_Type => Int,
54 Table_Low_Bound => 0,
55 Table_Initial => Alloc.SFN_Table_Initial,
56 Table_Increment => Alloc.SFN_Table_Increment,
57 Table_Name => "SFN_Table");
58 -- Table recording all Unit_Name calls to Set_File_Name
59
60 type SFN_Header_Num is range 0 .. 100;
61
62 function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num;
63 -- Compute hash index for use by Simple_HTable
64
65 No_Entry : constant Int := -1;
66 -- Signals no entry in following table
67
68 package SFN_HTable is new GNAT.HTable.Simple_HTable (
69 Header_Num => SFN_Header_Num,
70 Element => Int,
71 No_Element => No_Entry,
72 Key => Unit_Name_Type,
73 Hash => SFN_Hash,
74 Equal => "=");
75 -- Hash table allowing rapid access to SFN_Table, the element value is an
76 -- index into this table.
77
78 type SFN_Pattern_Entry is record
79 Pat : String_Ptr; -- File name pattern (with asterisk in it)
80 Typ : Character; -- 'S'/'B'/'U' for spec/body/subunit
81 Dot : String_Ptr; -- Dot_Separator string
82 Cas : Casing_Type; -- Upper/Lower/Mixed
83 end record;
84 -- Records single call to Set_File_Name_Patterm
85
86 package SFN_Patterns is new Table.Table (
87 Table_Component_Type => SFN_Pattern_Entry,
88 Table_Index_Type => Int,
89 Table_Low_Bound => 1,
90 Table_Initial => 10,
91 Table_Increment => 100,
92 Table_Name => "SFN_Patterns");
93 -- Table recording calls to Set_File_Name_Pattern. Note that the first two
94 -- entries are set to represent the standard GNAT rules for file naming.
95
96 -----------------------
97 -- File_Name_Of_Body --
98 -----------------------
99
100 function File_Name_Of_Body (Name : Name_Id) return File_Name_Type is
101 begin
102 Get_Name_String (Name);
103 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%b";
104 Name_Len := Name_Len + 2;
105 return Get_File_Name (Name_Enter, Subunit => False);
106 end File_Name_Of_Body;
107
108 -----------------------
109 -- File_Name_Of_Spec --
110 -----------------------
111
112 function File_Name_Of_Spec (Name : Name_Id) return File_Name_Type is
113 begin
114 Get_Name_String (Name);
115 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%s";
116 Name_Len := Name_Len + 2;
117 return Get_File_Name (Name_Enter, Subunit => False);
118 end File_Name_Of_Spec;
119
120 ----------------------------
121 -- Get_Expected_Unit_Type --
122 ----------------------------
123
124 function Get_Expected_Unit_Type
125 (Fname : File_Name_Type) return Expected_Unit_Type
126 is
127 begin
128 -- In syntax checking only mode or in multiple unit per file mode, there
129 -- can be more than one unit in a file, so the file name is not a useful
130 -- guide to the nature of the unit.
131
132 if Operating_Mode = Check_Syntax
133 or else Multiple_Unit_Index /= 0
134 then
135 return Unknown;
136 end if;
137
138 -- Search the file mapping table, if we find an entry for this file we
139 -- know whether it is a spec or a body.
140
141 for J in SFN_Table.First .. SFN_Table.Last loop
142 if Fname = SFN_Table.Table (J).F then
143 if Is_Body_Name (SFN_Table.Table (J).U) then
144 return Expect_Body;
145 else
146 return Expect_Spec;
147 end if;
148 end if;
149 end loop;
150
151 -- If no entry in file naming table, assume .ads/.adb for spec/body and
152 -- return unknown if we have neither of these two cases.
153
154 Get_Name_String (Fname);
155
156 if Name_Len > 4 then
157 if Name_Buffer (Name_Len - 3 .. Name_Len) = ".ads" then
158 return Expect_Spec;
159 elsif Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" then
160 return Expect_Body;
161 end if;
162 end if;
163
164 return Unknown;
165 end Get_Expected_Unit_Type;
166
167 -------------------
168 -- Get_File_Name --
169 -------------------
170
171 function Get_File_Name
172 (Uname : Unit_Name_Type;
173 Subunit : Boolean;
174 May_Fail : Boolean := False) return File_Name_Type
175 is
176 Unit_Char : Character;
177 -- Set to 's' or 'b' for spec or body or to 'u' for a subunit
178
179 Unit_Char_Search : Character;
180 -- Same as Unit_Char, except that in the case of 'u' for a subunit, we
181 -- set Unit_Char_Search to 'b' if we do not find a subunit match.
182
183 N : Int;
184
185 Pname : File_Name_Type := No_File;
186 Fname : File_Name_Type := No_File;
187 -- Path name and File name for mapping
188
189 begin
190 -- Null or error name means that some previous error occurred. This is
191 -- an unrecoverable error, so signal it.
192
193 if Uname in Error_Unit_Name_Or_No_Unit_Name then
194 raise Unrecoverable_Error;
195 end if;
196
197 -- Look in the map from unit names to file names
198
199 Fname := Mapped_File_Name (Uname);
200
201 -- If the unit name is already mapped, return the corresponding file
202 -- name from the map.
203
204 if Fname /= No_File then
205 return Fname;
206 end if;
207
208 -- If there is a specific SFN pragma, return the corresponding file name
209
210 N := SFN_HTable.Get (Uname);
211
212 if N /= No_Entry then
213 return SFN_Table.Table (N).F;
214 end if;
215
216 -- Here for the case where the name was not found in the table
217
218 Get_Decoded_Name_String (Uname);
219
220 -- A special fudge, normally we don't have operator symbols present,
221 -- since it is always an error to do so. However, if we do, at this
222 -- stage it has a leading double quote.
223
224 -- What we do in this case is to go back to the undecoded name, which
225 -- is of the form, for example:
226
227 -- Oand%s
228
229 -- and build a file name that looks like:
230
231 -- _and_.ads
232
233 -- which is bit peculiar, but we keep it that way. This means that we
234 -- avoid bombs due to writing a bad file name, and we get expected error
235 -- processing downstream, e.g. a compilation following gnatchop.
236
237 if Name_Buffer (1) = '"' then
238 Get_Name_String (Uname);
239 Name_Len := Name_Len + 1;
240 Name_Buffer (Name_Len) := Name_Buffer (Name_Len - 1);
241 Name_Buffer (Name_Len - 1) := Name_Buffer (Name_Len - 2);
242 Name_Buffer (Name_Len - 2) := '_';
243 Name_Buffer (1) := '_';
244 end if;
245
246 -- Deal with spec or body suffix
247
248 Unit_Char := Name_Buffer (Name_Len);
249 pragma Assert (Unit_Char = 'b' or else Unit_Char = 's');
250 pragma Assert (Name_Len >= 3 and then Name_Buffer (Name_Len - 1) = '%');
251 Name_Len := Name_Len - 2;
252
253 if Subunit then
254 Unit_Char := 'u';
255 end if;
256
257 -- Now we need to find the proper translation of the name
258
259 declare
260 Uname : constant String (1 .. Name_Len) :=
261 Name_Buffer (1 .. Name_Len);
262
263 Pent : Nat;
264 Plen : Natural;
265 Fnam : File_Name_Type := No_File;
266 J : Natural;
267 Dot : String_Ptr;
268 Dotl : Natural;
269
270 Is_Predef : Boolean;
271 -- Set True for predefined file
272
273 function C (N : Natural) return Character;
274 -- Return N'th character of pattern
275
276 function C (N : Natural) return Character is
277 begin
278 return SFN_Patterns.Table (Pent).Pat (N);
279 end C;
280
281 -- Start of search through pattern table
282
283 begin
284 -- Search pattern table to find a matching entry. In the general case
285 -- we do two complete searches. The first time through we stop only
286 -- if a matching file is found, the second time through we accept the
287 -- first match regardless. Note that there will always be a match the
288 -- second time around, because of the default entries at the end of
289 -- the table.
290
291 for No_File_Check in False .. True loop
292 Unit_Char_Search := Unit_Char;
293
294 <<Repeat_Search>>
295 -- The search is repeated with Unit_Char_Search set to b, if an
296 -- initial search for the subunit case fails to find any match.
297
298 Pent := SFN_Patterns.First;
299 while Pent <= SFN_Patterns.Last loop
300 if SFN_Patterns.Table (Pent).Typ = Unit_Char_Search then
301 -- Determine if we have a predefined file name
302
303 Is_Predef :=
304 Is_Predefined_Unit_Name
305 (Uname, Renamings_Included => True);
306
307 -- Found a match, execute the pattern
308
309 Name_Len := Uname'Length;
310 Name_Buffer (1 .. Name_Len) := Uname;
311
312 -- Apply casing, except that we do not do this for the case
313 -- of a predefined library file. For the latter, we always
314 -- use the all lower case name, regardless of the setting.
315
316 if not Is_Predef then
317 Set_Casing (SFN_Patterns.Table (Pent).Cas);
318 end if;
319
320 -- If dot translation required do it
321
322 Dot := SFN_Patterns.Table (Pent).Dot;
323 Dotl := Dot.all'Length;
324
325 if Dot.all /= "." then
326 J := 1;
327
328 while J <= Name_Len loop
329 if Name_Buffer (J) = '.' then
330
331 if Dotl = 1 then
332 Name_Buffer (J) := Dot (Dot'First);
333
334 else
335 Name_Buffer (J + Dotl .. Name_Len + Dotl - 1) :=
336 Name_Buffer (J + 1 .. Name_Len);
337 Name_Buffer (J .. J + Dotl - 1) := Dot.all;
338 Name_Len := Name_Len + Dotl - 1;
339 end if;
340
341 J := J + Dotl;
342
343 -- Skip past wide char sequences to avoid messing with
344 -- dot characters that are part of a sequence.
345
346 elsif Name_Buffer (J) = ASCII.ESC
347 or else (Upper_Half_Encoding
348 and then
349 Name_Buffer (J) in Upper_Half_Character)
350 then
351 Skip_Wide (Name_Buffer, J);
352 else
353 J := J + 1;
354 end if;
355 end loop;
356 end if;
357
358 -- Here move result to right if preinsertion before *
359
360 Plen := SFN_Patterns.Table (Pent).Pat'Length;
361 for K in 1 .. Plen loop
362 if C (K) = '*' then
363 if K /= 1 then
364 Name_Buffer (1 + K - 1 .. Name_Len + K - 1) :=
365 Name_Buffer (1 .. Name_Len);
366
367 for L in 1 .. K - 1 loop
368 Name_Buffer (L) := C (L);
369 end loop;
370
371 Name_Len := Name_Len + K - 1;
372 end if;
373
374 for L in K + 1 .. Plen loop
375 Name_Len := Name_Len + 1;
376 Name_Buffer (Name_Len) := C (L);
377 end loop;
378
379 exit;
380 end if;
381 end loop;
382
383 -- Execute possible crunch on constructed name. The krunch
384 -- operation excludes any extension that may be present.
385
386 J := Name_Len;
387 while J > 1 loop
388 exit when Name_Buffer (J) = '.';
389 J := J - 1;
390 end loop;
391
392 -- Case of extension present
393
394 if J > 1 then
395 declare
396 Ext : constant String := Name_Buffer (J .. Name_Len);
397
398 begin
399 -- Remove extension
400
401 Name_Len := J - 1;
402
403 -- Krunch what's left
404
405 Krunch
406 (Name_Buffer,
407 Name_Len,
408 Integer (Maximum_File_Name_Length),
409 Debug_Flag_4);
410
411 -- Replace extension
412
413 Name_Buffer
414 (Name_Len + 1 .. Name_Len + Ext'Length) := Ext;
415 Name_Len := Name_Len + Ext'Length;
416 end;
417
418 -- Case of no extension present, straight krunch on the
419 -- entire file name.
420
421 else
422 Krunch
423 (Name_Buffer,
424 Name_Len,
425 Integer (Maximum_File_Name_Length),
426 Debug_Flag_4);
427 end if;
428
429 Fnam := Name_Find;
430
431 -- If we are in the second search of the table, we accept
432 -- the file name without checking, because we know that the
433 -- file does not exist, except when May_Fail is True, in
434 -- which case we return No_File.
435
436 if No_File_Check then
437 if May_Fail then
438 return No_File;
439 else
440 return Fnam;
441 end if;
442
443 -- Otherwise we check if the file exists
444
445 else
446 Pname := Find_File (Fnam, Source);
447
448 -- If it does exist, we add it to the mappings and return
449 -- the file name.
450
451 if Pname /= No_File then
452
453 -- Add to mapping, so that we don't do another path
454 -- search in Find_File for this file name and, if we
455 -- use a mapping file, we are ready to update it at
456 -- the end of this compilation for the benefit of
457 -- other compilation processes.
458
459 Add_To_File_Map (Get_File_Name.Uname, Fnam, Pname);
460 return Fnam;
461
462 -- If there are only two entries, they are those of the
463 -- default GNAT naming scheme. The file does not exist,
464 -- but there is no point doing the second search, because
465 -- we will end up with the same file name. Just return
466 -- the file name, or No_File if May_Fail is True.
467
468 elsif SFN_Patterns.Last = 2 then
469 if May_Fail then
470 return No_File;
471 else
472 return Fnam;
473 end if;
474
475 -- The file does not exist, but there may be other naming
476 -- scheme. Keep on searching.
477
478 else
479 Fnam := No_File;
480 end if;
481 end if;
482 end if;
483
484 Pent := Pent + 1;
485 end loop;
486
487 -- If search failed, and was for a subunit, repeat the search with
488 -- Unit_Char_Search reset to 'b', since in the normal case we
489 -- simply treat subunits as bodies.
490
491 if Fnam = No_File and then Unit_Char_Search = 'u' then
492 Unit_Char_Search := 'b';
493 goto Repeat_Search;
494 end if;
495
496 -- Repeat entire search in No_File_Check mode if necessary
497
498 end loop;
499
500 -- Something is wrong if search fails completely, since the default
501 -- entries should catch all possibilities at this stage.
502
503 raise Program_Error;
504 end;
505 end Get_File_Name;
506
507 --------------------
508 -- Get_Unit_Index --
509 --------------------
510
511 function Get_Unit_Index (Uname : Unit_Name_Type) return Nat is
512 N : constant Int := SFN_HTable.Get (Uname);
513 begin
514 if N /= No_Entry then
515 return SFN_Table.Table (N).Index;
516 else
517 return 0;
518 end if;
519 end Get_Unit_Index;
520
521 ----------------
522 -- Initialize --
523 ----------------
524
525 procedure Initialize is
526 begin
527 SFN_Table.Init;
528 SFN_Patterns.Init;
529
530 -- Add default entries to SFN_Patterns.Table to represent the standard
531 -- default GNAT rules for file name translation.
532
533 SFN_Patterns.Append (New_Val =>
534 (Pat => new String'("*.ads"),
535 Typ => 's',
536 Dot => new String'("-"),
537 Cas => All_Lower_Case));
538
539 SFN_Patterns.Append (New_Val =>
540 (Pat => new String'("*.adb"),
541 Typ => 'b',
542 Dot => new String'("-"),
543 Cas => All_Lower_Case));
544 end Initialize;
545
546 ----------
547 -- Lock --
548 ----------
549
550 procedure Lock is
551 begin
552 SFN_Table.Release;
553 SFN_Table.Locked := True;
554 end Lock;
555
556 -------------------
557 -- Set_File_Name --
558 -------------------
559
560 procedure Set_File_Name
561 (U : Unit_Name_Type;
562 F : File_Name_Type;
563 Index : Nat)
564 is
565 begin
566 SFN_Table.Increment_Last;
567 SFN_Table.Table (SFN_Table.Last) := (U, F, Index);
568 SFN_HTable.Set (U, SFN_Table.Last);
569 end Set_File_Name;
570
571 ---------------------------
572 -- Set_File_Name_Pattern --
573 ---------------------------
574
575 procedure Set_File_Name_Pattern
576 (Pat : String_Ptr;
577 Typ : Character;
578 Dot : String_Ptr;
579 Cas : Casing_Type)
580 is
581 L : constant Nat := SFN_Patterns.Last;
582
583 begin
584 SFN_Patterns.Increment_Last;
585
586 -- Move up the last two entries (the default ones) and then put the new
587 -- entry into the table just before them (we always have the default
588 -- entries be the last ones).
589
590 SFN_Patterns.Table (L + 1) := SFN_Patterns.Table (L);
591 SFN_Patterns.Table (L) := SFN_Patterns.Table (L - 1);
592 SFN_Patterns.Table (L - 1) := (Pat, Typ, Dot, Cas);
593 end Set_File_Name_Pattern;
594
595 --------------
596 -- SFN_Hash --
597 --------------
598
599 function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num is
600 begin
601 return SFN_Header_Num (Int (F) rem SFN_Header_Num'Range_Length);
602 end SFN_Hash;
603
604 begin
605
606 -- We call the initialization routine from the package body, so that
607 -- Fname.Init only needs to be called explicitly to reinitialize.
608
609 Fname.UF.Initialize;
610 end Fname.UF;