1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
28 with Debug; use Debug;
31 with Namet; use Namet;
33 with Osint; use Osint;
35 with Targparm; use Targparm;
36 with Uname; use Uname;
37 with Widechar; use Widechar;
41 package body Fname.UF is
43 --------------------------------------------------------
44 -- Declarations for Handling Source_File_Name pragmas --
45 --------------------------------------------------------
47 type SFN_Entry is record
48 U : Unit_Name_Type; -- Unit name
49 F : File_Name_Type; -- Spec/Body file name
50 Index : Nat; -- Index from SFN pragma (0 if none)
52 -- Record single Unit_Name type call to Set_File_Name
54 package SFN_Table is new Table.Table (
55 Table_Component_Type => SFN_Entry,
56 Table_Index_Type => Int,
58 Table_Initial => Alloc.SFN_Table_Initial,
59 Table_Increment => Alloc.SFN_Table_Increment,
60 Table_Name => "SFN_Table");
61 -- Table recording all Unit_Name calls to Set_File_Name
63 type SFN_Header_Num is range 0 .. 100;
65 function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num;
66 -- Compute hash index for use by Simple_HTable
68 No_Entry : constant Int := -1;
69 -- Signals no entry in following table
71 package SFN_HTable is new GNAT.HTable.Simple_HTable (
72 Header_Num => SFN_Header_Num,
74 No_Element => No_Entry,
75 Key => Unit_Name_Type,
78 -- Hash table allowing rapid access to SFN_Table, the element value
79 -- is an index into this table.
81 type SFN_Pattern_Entry is record
82 Pat : String_Ptr; -- File name pattern (with asterisk in it)
83 Typ : Character; -- 'S'/'B'/'U' for spec/body/subunit
84 Dot : String_Ptr; -- Dot_Separator string
85 Cas : Casing_Type; -- Upper/Lower/Mixed
87 -- Records single call to Set_File_Name_Patterm
89 package SFN_Patterns is new Table.Table (
90 Table_Component_Type => SFN_Pattern_Entry,
91 Table_Index_Type => Int,
94 Table_Increment => 100,
95 Table_Name => "SFN_Patterns");
96 -- Table recording all calls to Set_File_Name_Pattern. Note that the
97 -- first two entries are set to represent the standard GNAT rules
100 -----------------------
101 -- File_Name_Of_Body --
102 -----------------------
104 function File_Name_Of_Body (Name : Name_Id) return File_Name_Type is
106 Get_Name_String (Name);
107 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%b";
108 Name_Len := Name_Len + 2;
109 return Get_File_Name (Name_Enter, Subunit => False);
110 end File_Name_Of_Body;
112 -----------------------
113 -- File_Name_Of_Spec --
114 -----------------------
116 function File_Name_Of_Spec (Name : Name_Id) return File_Name_Type is
118 Get_Name_String (Name);
119 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%s";
120 Name_Len := Name_Len + 2;
121 return Get_File_Name (Name_Enter, Subunit => False);
122 end File_Name_Of_Spec;
124 ----------------------------
125 -- Get_Expected_Unit_Type --
126 ----------------------------
128 function Get_Expected_Unit_Type
129 (Fname : File_Name_Type) return Expected_Unit_Type
132 -- In syntax checking only mode or in multiple unit per file mode,
133 -- there can be more than one unit in a file, so the file name is
134 -- not a useful guide to the nature of the unit.
136 if Operating_Mode = Check_Syntax
137 or else Multiple_Unit_Index /= 0
142 -- Search the file mapping table, if we find an entry for this
143 -- file we know whether it is a spec or a body.
145 for J in SFN_Table.First .. SFN_Table.Last loop
146 if Fname = SFN_Table.Table (J).F then
147 if Is_Body_Name (SFN_Table.Table (J).U) then
155 -- If no entry in file naming table, assume .ads/.adb for spec/body
156 -- and return unknown if we have neither of these two cases.
158 Get_Name_String (Fname);
161 if Name_Buffer (Name_Len - 3 .. Name_Len) = ".ads" then
163 elsif Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" then
169 end Get_Expected_Unit_Type;
175 function Get_File_Name
176 (Uname : Unit_Name_Type;
178 May_Fail : Boolean := False) return File_Name_Type
180 Unit_Char : Character;
181 -- Set to 's' or 'b' for spec or body or to 'u' for a subunit
183 Unit_Char_Search : Character;
184 -- Same as Unit_Char, except that in the case of 'u' for a subunit,
185 -- we set Unit_Char_Search to 'b' if we do not find a subunit match.
189 Pname : File_Name_Type := No_File;
190 Fname : File_Name_Type := No_File;
191 -- Path name and File name for mapping
194 -- Null or error name means that some previous error occurred
195 -- This is an unrecoverable error, so signal it.
197 if Uname <= Error_Name then
198 raise Unrecoverable_Error;
201 -- Look in the map from unit names to file names
203 Fname := Mapped_File_Name (Uname);
205 -- If the unit name is already mapped, return the corresponding
206 -- file name from the map.
208 if Fname /= No_File then
212 -- If there is a specific SFN pragma, return the corresponding file name
214 N := SFN_HTable.Get (Uname);
216 if N /= No_Entry then
217 return SFN_Table.Table (N).F;
220 -- Here for the case where the name was not found in the table
222 Get_Decoded_Name_String (Uname);
224 -- A special fudge, normally we don't have operator symbols present,
225 -- since it is always an error to do so. However, if we do, at this
226 -- stage it has a leading double quote.
228 -- What we do in this case is to go back to the undecoded name, which
229 -- is of the form, for example:
233 -- and build a file name that looks like:
237 -- which is bit peculiar, but we keep it that way. This means that
238 -- we avoid bombs due to writing a bad file name, and w get expected
239 -- error processing downstream, e.g. a compilation following gnatchop.
241 if Name_Buffer (1) = '"' then
242 Get_Name_String (Uname);
243 Name_Len := Name_Len + 1;
244 Name_Buffer (Name_Len) := Name_Buffer (Name_Len - 1);
245 Name_Buffer (Name_Len - 1) := Name_Buffer (Name_Len - 2);
246 Name_Buffer (Name_Len - 2) := '_';
247 Name_Buffer (1) := '_';
250 -- Deal with spec or body suffix
252 Unit_Char := Name_Buffer (Name_Len);
253 pragma Assert (Unit_Char = 'b' or else Unit_Char = 's');
254 pragma Assert (Name_Len >= 3 and then Name_Buffer (Name_Len - 1) = '%');
255 Name_Len := Name_Len - 2;
261 -- Now we need to find the proper translation of the name
264 Uname : constant String (1 .. Name_Len) :=
265 Name_Buffer (1 .. Name_Len);
269 Fnam : File_Name_Type := No_File;
275 -- Set True for predefined file
277 function C (N : Natural) return Character;
278 -- Return N'th character of pattern
280 function C (N : Natural) return Character is
282 return SFN_Patterns.Table (Pent).Pat (N);
285 -- Start of search through pattern table
288 -- Search pattern table to find a matching entry. In the general
289 -- case we do two complete searches. The first time through we
290 -- stop only if a matching file is found, the second time through
291 -- we accept the first match regardless. Note that there will
292 -- always be a match the second time around, because of the
293 -- default entries at the end of the table.
295 for No_File_Check in False .. True loop
296 Unit_Char_Search := Unit_Char;
299 -- The search is repeated with Unit_Char_Search set to b, if an
300 -- initial search for the subunit case fails to find any match.
302 Pent := SFN_Patterns.First;
303 while Pent <= SFN_Patterns.Last loop
304 if SFN_Patterns.Table (Pent).Typ = Unit_Char_Search then
307 -- Determine if we have a predefined file name
309 Name_Len := Uname'Length;
310 Name_Buffer (1 .. Name_Len) := Uname;
312 Is_Predefined_File_Name (Renamings_Included => True);
314 -- Found a match, execute the pattern
316 Name_Len := Uname'Length;
317 Name_Buffer (1 .. Name_Len) := Uname;
319 -- Apply casing, except that we do not do this for the case
320 -- of a predefined library file. For the latter, we always
321 -- use the all lower case name, regardless of the setting.
323 if not Is_Predef then
324 Set_Casing (SFN_Patterns.Table (Pent).Cas);
327 -- If dot translation required do it
329 Dot := SFN_Patterns.Table (Pent).Dot;
330 Dotl := Dot.all'Length;
332 if Dot.all /= "." then
335 while J <= Name_Len loop
336 if Name_Buffer (J) = '.' then
339 Name_Buffer (J) := Dot (Dot'First);
342 Name_Buffer (J + Dotl .. Name_Len + Dotl - 1) :=
343 Name_Buffer (J + 1 .. Name_Len);
344 Name_Buffer (J .. J + Dotl - 1) := Dot.all;
345 Name_Len := Name_Len + Dotl - 1;
350 -- Skip past wide char sequences to avoid messing
351 -- with dot characters that are part of a sequence.
353 elsif Name_Buffer (J) = ASCII.ESC
354 or else (Upper_Half_Encoding
356 Name_Buffer (J) in Upper_Half_Character)
358 Skip_Wide (Name_Buffer, J);
365 -- Here move result to right if preinsertion before *
367 Plen := SFN_Patterns.Table (Pent).Pat'Length;
368 for K in 1 .. Plen loop
371 Name_Buffer (1 + K - 1 .. Name_Len + K - 1) :=
372 Name_Buffer (1 .. Name_Len);
374 for L in 1 .. K - 1 loop
375 Name_Buffer (L) := C (L);
378 Name_Len := Name_Len + K - 1;
381 for L in K + 1 .. Plen loop
382 Name_Len := Name_Len + 1;
383 Name_Buffer (Name_Len) := C (L);
390 -- Execute possible crunch on constructed name. The krunch
391 -- operation excludes any extension that may be present.
395 exit when Name_Buffer (J) = '.';
399 -- Case of extension present
403 Ext : constant String := Name_Buffer (J .. Name_Len);
410 -- Krunch what's left
415 Integer (Maximum_File_Name_Length),
422 (Name_Len + 1 .. Name_Len + Ext'Length) := Ext;
423 Name_Len := Name_Len + Ext'Length;
426 -- Case of no extension present, straight krunch on
427 -- the entire file name.
433 Integer (Maximum_File_Name_Length),
437 Fnam := File_Name_Type (Name_Find);
439 -- If we are in the second search of the table, we accept
440 -- the file name without checking, because we know that
441 -- the file does not exist, except when May_Fail is True,
442 -- in which case we return No_File.
444 if No_File_Check then
451 -- Otherwise we check if the file exists
454 Pname := Find_File (Fnam, Source);
456 -- If it does exist, we add it to the mappings and
457 -- return the file name.
459 if Pname /= No_File then
461 -- Add to mapping, so that we don't do another
462 -- path search in Find_File for this file name
463 -- and, if we use a mapping file, we are ready
464 -- to update it at the end of this compilation
465 -- for the benefit of other compilation processes.
467 Add_To_File_Map (Get_File_Name.Uname, Fnam, Pname);
470 -- If there are only two entries, they are those of
471 -- the default GNAT naming scheme. The file does
472 -- not exist, but there is no point doing the
473 -- second search, because we will end up with the
474 -- same file name. Just return the file name.
476 elsif SFN_Patterns.Last = 2 then
479 -- The file does not exist, but there may be other
480 -- naming scheme. Keep on searching.
491 -- If search failed, and was for a subunit, repeat the search
492 -- with Unit_Char_Search reset to 'b', since in the normal case
493 -- we simply treat subunits as bodies.
495 if Fnam = No_File and then Unit_Char_Search = 'u' then
496 Unit_Char_Search := 'b';
500 -- Repeat entire search in No_File_Check mode if necessary
504 -- Something is wrong if search fails completely, since the
505 -- default entries should catch all possibilities at this stage.
515 function Get_Unit_Index (Uname : Unit_Name_Type) return Nat is
516 N : constant Int := SFN_HTable.Get (Uname);
518 if N /= No_Entry then
519 return SFN_Table.Table (N).Index;
529 procedure Initialize is
534 -- Add default entries to SFN_Patterns.Table to represent the
535 -- standard default GNAT rules for file name translation.
537 SFN_Patterns.Append (New_Val =>
538 (Pat => new String'("*.ads"),
540 Dot => new String'("-"),
541 Cas => All_Lower_Case));
543 SFN_Patterns.Append (New_Val =>
544 (Pat => new String'("*.adb"),
546 Dot => new String'("-"),
547 Cas => All_Lower_Case));
556 SFN_Table.Locked := True;
564 procedure Set_File_Name
570 SFN_Table.Increment_Last;
571 SFN_Table.Table (SFN_Table.Last) := (U, F, Index);
572 SFN_HTable.Set (U, SFN_Table.Last);
575 ---------------------------
576 -- Set_File_Name_Pattern --
577 ---------------------------
579 procedure Set_File_Name_Pattern
585 L : constant Nat := SFN_Patterns.Last;
588 SFN_Patterns.Increment_Last;
590 -- Move up the last two entries (the default ones) and then
591 -- put the new entry into the table just before them (we
592 -- always have the default entries be the last ones).
594 SFN_Patterns.Table (L + 1) := SFN_Patterns.Table (L);
595 SFN_Patterns.Table (L) := SFN_Patterns.Table (L - 1);
596 SFN_Patterns.Table (L - 1) := (Pat, Typ, Dot, Cas);
597 end Set_File_Name_Pattern;
603 function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num is
605 return SFN_Header_Num (Int (F) rem SFN_Header_Num'Range_Length);
610 -- We call the initialization routine from the package body, so that
611 -- Fname.Init only needs to be called explicitly to reinitialize.