1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
11 -- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
27 ------------------------------------------------------------------------------
30 with Debug; use Debug;
33 with Namet; use Namet;
35 with Osint; use Osint;
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
51 -- Record single Unit_Name type call to Set_File_Name
53 package SFN_Table is new Table.Table (
54 Table_Component_Type => SFN_Entry,
55 Table_Index_Type => Int,
57 Table_Initial => Alloc.SFN_Table_Initial,
58 Table_Increment => Alloc.SFN_Table_Increment,
59 Table_Name => "SFN_Table");
60 -- Table recording all Unit_Name calls to Set_File_Name
62 type SFN_Header_Num is range 0 .. 100;
64 function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num;
65 -- Compute hash index for use by Simple_HTable
67 No_Entry : constant Int := -1;
68 -- Signals no entry in following table
70 package SFN_HTable is new GNAT.HTable.Simple_HTable (
71 Header_Num => SFN_Header_Num,
73 No_Element => No_Entry,
74 Key => Unit_Name_Type,
77 -- Hash table allowing rapid access to SFN_Table, the element value
78 -- is an index into this table.
80 type SFN_Pattern_Entry is record
81 Pat : String_Ptr; -- File name pattern (with asterisk in it)
82 Typ : Character; -- 'S'/'B'/'U' for spec/body/subunit
83 Dot : String_Ptr; -- Dot_Separator string
84 Cas : Casing_Type; -- Upper/Lower/Mixed
86 -- Records single call to Set_File_Name_Patterm
88 package SFN_Patterns is new Table.Table (
89 Table_Component_Type => SFN_Pattern_Entry,
90 Table_Index_Type => Int,
93 Table_Increment => 100,
94 Table_Name => "SFN_Patterns");
95 -- Table recording all calls to Set_File_Name_Pattern. Note that the
96 -- first two entries are set to represent the standard GNAT rules
99 -----------------------
100 -- File_Name_Of_Body --
101 -----------------------
103 function File_Name_Of_Body (Name : Name_Id) return File_Name_Type is
105 Get_Name_String (Name);
106 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%b";
107 Name_Len := Name_Len + 2;
108 return Get_File_Name (Name_Enter, Subunit => False);
109 end File_Name_Of_Body;
111 -----------------------
112 -- File_Name_Of_Spec --
113 -----------------------
115 function File_Name_Of_Spec (Name : Name_Id) return File_Name_Type is
117 Get_Name_String (Name);
118 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%s";
119 Name_Len := Name_Len + 2;
120 return Get_File_Name (Name_Enter, Subunit => False);
121 end File_Name_Of_Spec;
127 function Get_File_Name
128 (Uname : Unit_Name_Type;
130 return File_Name_Type
132 Unit_Char : Character;
133 -- Set to 's' or 'b' for spec or body or to 'u' for a subunit
135 Unit_Char_Search : Character;
136 -- Same as Unit_Char, except that in the case of 'u' for a subunit,
137 -- we set Unit_Char_Search to 'b' if we do not find a subunit match.
141 Pname : File_Name_Type := No_File;
142 Fname : File_Name_Type := No_File;
145 -- Null or error name means that some previous error occurred
146 -- This is an unrecoverable error, so signal it.
148 if Uname <= Error_Name then
149 raise Unrecoverable_Error;
152 -- Look into the mapping from unit names to file names
154 Fname := Fmap.File_Name_Of (Uname);
156 -- If the unit name is already mapped, return the corresponding
159 if Fname /= No_File then
163 -- If there is a specific SFN pragma, return the corresponding file name
165 N := SFN_HTable.Get (Uname);
167 if N /= No_Entry then
168 return SFN_Table.Table (N).F;
171 -- Here for the case where the name was not found in the table
173 Get_Decoded_Name_String (Uname);
175 -- A special fudge, normally we don't have operator symbols present,
176 -- since it is always an error to do so. However, if we do, at this
177 -- stage it has a leading double quote.
179 -- What we do in this case is to go back to the undecoded name, which
180 -- is of the form, for example:
184 -- and build a file name that looks like:
188 -- which is bit peculiar, but we keep it that way. This means that
189 -- we avoid bombs due to writing a bad file name, and w get expected
190 -- error processing downstream, e.g. a compilation following gnatchop.
192 if Name_Buffer (1) = '"' then
193 Get_Name_String (Uname);
194 Name_Len := Name_Len + 1;
195 Name_Buffer (Name_Len) := Name_Buffer (Name_Len - 1);
196 Name_Buffer (Name_Len - 1) := Name_Buffer (Name_Len - 2);
197 Name_Buffer (Name_Len - 2) := '_';
198 Name_Buffer (1) := '_';
201 -- Deal with spec or body suffix
203 Unit_Char := Name_Buffer (Name_Len);
204 pragma Assert (Unit_Char = 'b' or else Unit_Char = 's');
205 pragma Assert (Name_Len >= 3 and then Name_Buffer (Name_Len - 1) = '%');
206 Name_Len := Name_Len - 2;
212 -- Now we need to find the proper translation of the name
215 Uname : constant String (1 .. Name_Len) :=
216 Name_Buffer (1 .. Name_Len);
220 Fnam : File_Name_Type := No_File;
225 function C (N : Natural) return Character;
226 -- Return N'th character of pattern
228 function C (N : Natural) return Character is
230 return SFN_Patterns.Table (Pent).Pat (N);
233 -- Start of search through pattern table
236 -- Search pattern table to find a matching entry. In the general
237 -- case we do two complete searches. The first time through we
238 -- stop only if a matching file is found, the second time through
239 -- we accept the first match regardless. Note that there will
240 -- always be a match the second time around, because of the
241 -- default entries at the end of the table.
243 for No_File_Check in False .. True loop
244 Unit_Char_Search := Unit_Char;
247 -- The search is repeated with Unit_Char_Search set to b, if an
248 -- initial search for the subunit case fails to find any match.
250 Pent := SFN_Patterns.First;
251 while Pent <= SFN_Patterns.Last loop
252 if SFN_Patterns.Table (Pent).Typ = Unit_Char_Search then
255 -- Found a match, execute the pattern
257 Name_Len := Uname'Length;
258 Name_Buffer (1 .. Name_Len) := Uname;
259 Set_Casing (SFN_Patterns.Table (Pent).Cas);
261 -- If dot translation required do it
263 Dot := SFN_Patterns.Table (Pent).Dot;
264 Dotl := Dot.all'Length;
266 if Dot.all /= "." then
269 while J <= Name_Len loop
270 if Name_Buffer (J) = '.' then
273 Name_Buffer (J) := Dot (Dot'First);
276 Name_Buffer (J + Dotl .. Name_Len + Dotl - 1) :=
277 Name_Buffer (J + 1 .. Name_Len);
278 Name_Buffer (J .. J + Dotl - 1) := Dot.all;
279 Name_Len := Name_Len + Dotl - 1;
284 -- Skip past wide char sequences to avoid messing
285 -- with dot characters that are part of a sequence.
287 elsif Name_Buffer (J) = ASCII.ESC
288 or else (Upper_Half_Encoding
290 Name_Buffer (J) in Upper_Half_Character)
292 Skip_Wide (Name_Buffer, J);
299 -- Here move result to right if preinsertion before *
301 Plen := SFN_Patterns.Table (Pent).Pat'Length;
302 for K in 1 .. Plen loop
305 Name_Buffer (1 + K - 1 .. Name_Len + K - 1) :=
306 Name_Buffer (1 .. Name_Len);
308 for L in 1 .. K - 1 loop
309 Name_Buffer (L) := C (L);
312 Name_Len := Name_Len + K - 1;
315 for L in K + 1 .. Plen loop
316 Name_Len := Name_Len + 1;
317 Name_Buffer (Name_Len) := C (L);
324 -- Execute possible crunch on constructed name. The krunch
325 -- operation excludes any extension that may be present.
329 exit when Name_Buffer (J) = '.';
333 -- Case of extension present
337 Ext : constant String := Name_Buffer (J .. Name_Len);
344 -- Krunch what's left
349 Integer (Maximum_File_Name_Length),
355 (Name_Len + 1 .. Name_Len + Ext'Length) := Ext;
356 Name_Len := Name_Len + Ext'Length;
359 -- Case of no extension present, straight krunch on
360 -- the entire file name.
366 Integer (Maximum_File_Name_Length),
370 Fnam := File_Name_Type (Name_Find);
372 -- If we are in the first search of the table, then
373 -- we check if the file is present, and only accept
374 -- the entry if it is indeed present. For the second
375 -- search, we accept the entry without this check.
377 -- If we only have two entries in the table, then there
378 -- is no point in seeing if the file exists, since we
379 -- will end up accepting it anyway on the second search,
380 -- so just quit and accept it now to save time.
382 if No_File_Check or else SFN_Patterns.Last = 2 then
385 -- Check if file exists and if so, return the entry
388 Pname := Find_File (Fnam, Source);
390 -- Check if file exists and if so, return the entry
392 if Pname /= No_File then
394 -- Add to mapping, so that we don't do another
395 -- path search in Find_File for this file name
397 Fmap.Add (Get_File_Name.Uname, Fnam, Pname);
400 -- This entry does not match after all, because this is
401 -- the first search loop, and the file does not exist.
412 -- If search failed, and was for a subunit, repeat the search
413 -- with Unit_Char_Search reset to 'b', since in the normal case
414 -- we simply treat subunits as bodies.
416 if Fnam = No_File and then Unit_Char_Search = 'u' then
417 Unit_Char_Search := 'b';
421 -- Repeat entire search in No_File_Check mode if necessary
425 -- Something is wrong if search fails completely, since the
426 -- default entries should catch all possibilities at this stage.
436 procedure Initialize is
441 -- Add default entries to SFN_Patterns.Table to represent the
442 -- standard default GNAT rules for file name translation.
444 SFN_Patterns.Append (New_Val =>
445 (Pat => new String'("*.ads"),
447 Dot => new String'("-"),
448 Cas => All_Lower_Case));
450 SFN_Patterns.Append (New_Val =>
451 (Pat => new String'("*.adb"),
453 Dot => new String'("-"),
454 Cas => All_Lower_Case));
463 SFN_Table.Locked := True;
471 procedure Set_File_Name (U : Unit_Name_Type; F : File_Name_Type) is
473 SFN_Table.Increment_Last;
474 SFN_Table.Table (SFN_Table.Last) := (U, F);
475 SFN_HTable.Set (U, SFN_Table.Last);
478 ---------------------------
479 -- Set_File_Name_Pattern --
480 ---------------------------
482 procedure Set_File_Name_Pattern
488 L : constant Nat := SFN_Patterns.Last;
490 SFN_Patterns.Increment_Last;
492 -- Move up the last two entries (the default ones) and then
493 -- put the new entry into the table just before them (we
494 -- always have the default entries be the last ones).
496 SFN_Patterns.Table (L + 1) := SFN_Patterns.Table (L);
497 SFN_Patterns.Table (L) := SFN_Patterns.Table (L - 1);
498 SFN_Patterns.Table (L - 1) := (Pat, Typ, Dot, Cas);
499 end Set_File_Name_Pattern;
505 function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num is
507 return SFN_Header_Num (Int (F) rem SFN_Header_Num'Range_Length);
512 -- We call the initialization routine from the package body, so that
513 -- Fname.Init only needs to be called explicitly to reinitialize.