|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- F N A M E . U F --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1992-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 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;
|
