1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, 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 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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
27 with Debug; use Debug;
31 with Osint; use Osint;
33 with Targparm; use Targparm;
34 with Uname; use Uname;
35 with Widechar; use Widechar;
39 package body Fname.UF is
41 --------------------------------------------------------
42 -- Declarations for Handling Source_File_Name pragmas --
43 --------------------------------------------------------
45 type SFN_Entry is record
46 U : Unit_Name_Type; -- Unit name
47 F : File_Name_Type; -- Spec/Body file name
48 Index : Nat; -- Index from SFN pragma (0 if none)
50 -- Record single Unit_Name type call to Set_File_Name
52 package SFN_Table is new Table.Table (
53 Table_Component_Type => SFN_Entry,
54 Table_Index_Type => Int,
56 Table_Initial => Alloc.SFN_Table_Initial,
57 Table_Increment => Alloc.SFN_Table_Increment,
58 Table_Name => "SFN_Table");
59 -- Table recording all Unit_Name calls to Set_File_Name
61 type SFN_Header_Num is range 0 .. 100;
63 function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num;
64 -- Compute hash index for use by Simple_HTable
66 No_Entry : constant Int := -1;
67 -- Signals no entry in following table
69 package SFN_HTable is new GNAT.HTable.Simple_HTable (
70 Header_Num => SFN_Header_Num,
72 No_Element => No_Entry,
73 Key => Unit_Name_Type,
76 -- Hash table allowing rapid access to SFN_Table, the element value is an
77 -- index into this table.
79 type SFN_Pattern_Entry is record
80 Pat : String_Ptr; -- File name pattern (with asterisk in it)
81 Typ : Character; -- 'S'/'B'/'U' for spec/body/subunit
82 Dot : String_Ptr; -- Dot_Separator string
83 Cas : Casing_Type; -- Upper/Lower/Mixed
85 -- Records single call to Set_File_Name_Patterm
87 package SFN_Patterns is new Table.Table (
88 Table_Component_Type => SFN_Pattern_Entry,
89 Table_Index_Type => Int,
92 Table_Increment => 100,
93 Table_Name => "SFN_Patterns");
94 -- Table recording calls to Set_File_Name_Pattern. Note that the first two
95 -- entries are set to represent the standard GNAT rules for file naming.
97 -----------------------
98 -- File_Name_Of_Body --
99 -----------------------
101 function File_Name_Of_Body (Name : Name_Id) return File_Name_Type is
103 Get_Name_String (Name);
104 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%b";
105 Name_Len := Name_Len + 2;
106 return Get_File_Name (Name_Enter, Subunit => False);
107 end File_Name_Of_Body;
109 -----------------------
110 -- File_Name_Of_Spec --
111 -----------------------
113 function File_Name_Of_Spec (Name : Name_Id) return File_Name_Type is
115 Get_Name_String (Name);
116 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%s";
117 Name_Len := Name_Len + 2;
118 return Get_File_Name (Name_Enter, Subunit => False);
119 end File_Name_Of_Spec;
121 ----------------------------
122 -- Get_Expected_Unit_Type --
123 ----------------------------
125 function Get_Expected_Unit_Type
126 (Fname : File_Name_Type) return Expected_Unit_Type
129 -- In syntax checking only mode or in multiple unit per file mode, there
130 -- can be more than one unit in a file, so the file name is not a useful
131 -- guide to the nature of the unit.
133 if Operating_Mode = Check_Syntax
134 or else Multiple_Unit_Index /= 0
139 -- Search the file mapping table, if we find an entry for this file we
140 -- know whether it is a spec or a body.
142 for J in SFN_Table.First .. SFN_Table.Last loop
143 if Fname = SFN_Table.Table (J).F then
144 if Is_Body_Name (SFN_Table.Table (J).U) then
152 -- If no entry in file naming table, assume .ads/.adb for spec/body and
153 -- return unknown if we have neither of these two cases.
155 Get_Name_String (Fname);
158 if Name_Buffer (Name_Len - 3 .. Name_Len) = ".ads" then
160 elsif Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" then
166 end Get_Expected_Unit_Type;
172 function Get_File_Name
173 (Uname : Unit_Name_Type;
175 May_Fail : Boolean := False) return File_Name_Type
177 Unit_Char : Character;
178 -- Set to 's' or 'b' for spec or body or to 'u' for a subunit
180 Unit_Char_Search : Character;
181 -- Same as Unit_Char, except that in the case of 'u' for a subunit, we
182 -- set Unit_Char_Search to 'b' if we do not find a subunit match.
186 Pname : File_Name_Type := No_File;
187 Fname : File_Name_Type := No_File;
188 -- Path name and File name for mapping
191 -- Null or error name means that some previous error occurred. This is
192 -- an unrecoverable error, so signal it.
194 if Uname in Error_Unit_Name_Or_No_Unit_Name then
195 raise Unrecoverable_Error;
198 -- Look in the map from unit names to file names
200 Fname := Mapped_File_Name (Uname);
202 -- If the unit name is already mapped, return the corresponding file
203 -- name from the map.
205 if Fname /= No_File then
209 -- If there is a specific SFN pragma, return the corresponding file name
211 N := SFN_HTable.Get (Uname);
213 if N /= No_Entry then
214 return SFN_Table.Table (N).F;
217 -- Here for the case where the name was not found in the table
219 Get_Decoded_Name_String (Uname);
221 -- A special fudge, normally we don't have operator symbols present,
222 -- since it is always an error to do so. However, if we do, at this
223 -- stage it has a leading double quote.
225 -- What we do in this case is to go back to the undecoded name, which
226 -- is of the form, for example:
230 -- and build a file name that looks like:
234 -- which is bit peculiar, but we keep it that way. This means that we
235 -- avoid bombs due to writing a bad file name, and w get expected error
236 -- processing downstream, e.g. a compilation following gnatchop.
238 if Name_Buffer (1) = '"' then
239 Get_Name_String (Uname);
240 Name_Len := Name_Len + 1;
241 Name_Buffer (Name_Len) := Name_Buffer (Name_Len - 1);
242 Name_Buffer (Name_Len - 1) := Name_Buffer (Name_Len - 2);
243 Name_Buffer (Name_Len - 2) := '_';
244 Name_Buffer (1) := '_';
247 -- Deal with spec or body suffix
249 Unit_Char := Name_Buffer (Name_Len);
250 pragma Assert (Unit_Char = 'b' or else Unit_Char = 's');
251 pragma Assert (Name_Len >= 3 and then Name_Buffer (Name_Len - 1) = '%');
252 Name_Len := Name_Len - 2;
258 -- Now we need to find the proper translation of the name
261 Uname : constant String (1 .. Name_Len) :=
262 Name_Buffer (1 .. Name_Len);
266 Fnam : File_Name_Type := No_File;
272 -- Set True for predefined file
274 function C (N : Natural) return Character;
275 -- Return N'th character of pattern
277 function C (N : Natural) return Character is
279 return SFN_Patterns.Table (Pent).Pat (N);
282 -- Start of search through pattern table
285 -- Search pattern table to find a matching entry. In the general case
286 -- we do two complete searches. The first time through we stop only
287 -- if a matching file is found, the second time through we accept the
288 -- first match regardless. Note that there will always be a match the
289 -- second time around, because of the default entries at the end of
292 for No_File_Check in False .. True loop
293 Unit_Char_Search := Unit_Char;
296 -- The search is repeated with Unit_Char_Search set to b, if an
297 -- initial search for the subunit case fails to find any match.
299 Pent := SFN_Patterns.First;
300 while Pent <= SFN_Patterns.Last loop
301 if SFN_Patterns.Table (Pent).Typ = Unit_Char_Search then
304 -- Determine if we have a predefined file name
306 Name_Len := Uname'Length;
307 Name_Buffer (1 .. Name_Len) := Uname;
309 Is_Predefined_File_Name (Renamings_Included => True);
311 -- Found a match, execute the pattern
313 Name_Len := Uname'Length;
314 Name_Buffer (1 .. Name_Len) := Uname;
316 -- Apply casing, except that we do not do this for the case
317 -- of a predefined library file. For the latter, we always
318 -- use the all lower case name, regardless of the setting.
320 if not Is_Predef then
321 Set_Casing (SFN_Patterns.Table (Pent).Cas);
324 -- If dot translation required do it
326 Dot := SFN_Patterns.Table (Pent).Dot;
327 Dotl := Dot.all'Length;
329 if Dot.all /= "." then
332 while J <= Name_Len loop
333 if Name_Buffer (J) = '.' then
336 Name_Buffer (J) := Dot (Dot'First);
339 Name_Buffer (J + Dotl .. Name_Len + Dotl - 1) :=
340 Name_Buffer (J + 1 .. Name_Len);
341 Name_Buffer (J .. J + Dotl - 1) := Dot.all;
342 Name_Len := Name_Len + Dotl - 1;
347 -- Skip past wide char sequences to avoid messing with
348 -- dot characters that are part of a sequence.
350 elsif Name_Buffer (J) = ASCII.ESC
351 or else (Upper_Half_Encoding
353 Name_Buffer (J) in Upper_Half_Character)
355 Skip_Wide (Name_Buffer, J);
362 -- Here move result to right if preinsertion before *
364 Plen := SFN_Patterns.Table (Pent).Pat'Length;
365 for K in 1 .. Plen loop
368 Name_Buffer (1 + K - 1 .. Name_Len + K - 1) :=
369 Name_Buffer (1 .. Name_Len);
371 for L in 1 .. K - 1 loop
372 Name_Buffer (L) := C (L);
375 Name_Len := Name_Len + K - 1;
378 for L in K + 1 .. Plen loop
379 Name_Len := Name_Len + 1;
380 Name_Buffer (Name_Len) := C (L);
387 -- Execute possible crunch on constructed name. The krunch
388 -- operation excludes any extension that may be present.
392 exit when Name_Buffer (J) = '.';
396 -- Case of extension present
400 Ext : constant String := Name_Buffer (J .. Name_Len);
407 -- Krunch what's left
412 Integer (Maximum_File_Name_Length),
419 (Name_Len + 1 .. Name_Len + Ext'Length) := Ext;
420 Name_Len := Name_Len + Ext'Length;
423 -- Case of no extension present, straight krunch on the
430 Integer (Maximum_File_Name_Length),
436 -- If we are in the second search of the table, we accept
437 -- the file name without checking, because we know that the
438 -- file does not exist, except when May_Fail is True, in
439 -- which case we return No_File.
441 if No_File_Check then
448 -- Otherwise we check if the file exists
451 Pname := Find_File (Fnam, Source);
453 -- If it does exist, we add it to the mappings and return
456 if Pname /= No_File then
458 -- Add to mapping, so that we don't do another path
459 -- search in Find_File for this file name and, if we
460 -- use a mapping file, we are ready to update it at
461 -- the end of this compilation for the benefit of
462 -- other compilation processes.
464 Add_To_File_Map (Get_File_Name.Uname, Fnam, Pname);
467 -- If there are only two entries, they are those of the
468 -- default GNAT naming scheme. The file does not exist,
469 -- but there is no point doing the second search, because
470 -- we will end up with the same file name. Just return
471 -- the file name, or No_File if May_Fail is True.
473 elsif SFN_Patterns.Last = 2 then
480 -- The file does not exist, but there may be other naming
481 -- scheme. Keep on searching.
492 -- If search failed, and was for a subunit, repeat the search with
493 -- Unit_Char_Search reset to 'b', since in the normal case we
494 -- simply treat subunits as bodies.
496 if Fnam = No_File and then Unit_Char_Search = 'u' then
497 Unit_Char_Search := 'b';
501 -- Repeat entire search in No_File_Check mode if necessary
505 -- Something is wrong if search fails completely, since the default
506 -- entries should catch all possibilities at this stage.
516 function Get_Unit_Index (Uname : Unit_Name_Type) return Nat is
517 N : constant Int := SFN_HTable.Get (Uname);
519 if N /= No_Entry then
520 return SFN_Table.Table (N).Index;
530 procedure Initialize is
535 -- Add default entries to SFN_Patterns.Table to represent the standard
536 -- default GNAT rules for file name translation.
538 SFN_Patterns.Append (New_Val =>
539 (Pat => new String'("*.ads"),
541 Dot => new String'("-"),
542 Cas => All_Lower_Case));
544 SFN_Patterns.Append (New_Val =>
545 (Pat => new String'("*.adb"),
547 Dot => new String'("-"),
548 Cas => All_Lower_Case));
557 SFN_Table.Locked := True;
565 procedure Set_File_Name
571 SFN_Table.Increment_Last;
572 SFN_Table.Table (SFN_Table.Last) := (U, F, Index);
573 SFN_HTable.Set (U, SFN_Table.Last);
576 ---------------------------
577 -- Set_File_Name_Pattern --
578 ---------------------------
580 procedure Set_File_Name_Pattern
586 L : constant Nat := SFN_Patterns.Last;
589 SFN_Patterns.Increment_Last;
591 -- Move up the last two entries (the default ones) and then put the new
592 -- entry into the table just before them (we always have the default
593 -- entries be the last ones).
595 SFN_Patterns.Table (L + 1) := SFN_Patterns.Table (L);
596 SFN_Patterns.Table (L) := SFN_Patterns.Table (L - 1);
597 SFN_Patterns.Table (L - 1) := (Pat, Typ, Dot, Cas);
598 end Set_File_Name_Pattern;
604 function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num is
606 return SFN_Header_Num (Int (F) rem SFN_Header_Num'Range_Length);
611 -- We call the initialization routine from the package body, so that
612 -- Fname.Init only needs to be called explicitly to reinitialize.