1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2003, 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 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
49 -- Record single Unit_Name type call to Set_File_Name
51 package SFN_Table
is new Table
.Table
(
52 Table_Component_Type
=> SFN_Entry
,
53 Table_Index_Type
=> Int
,
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
60 type SFN_Header_Num
is range 0 .. 100;
62 function SFN_Hash
(F
: Unit_Name_Type
) return SFN_Header_Num
;
63 -- Compute hash index for use by Simple_HTable
65 No_Entry
: constant Int
:= -1;
66 -- Signals no entry in following table
68 package SFN_HTable
is new GNAT
.HTable
.Simple_HTable
(
69 Header_Num
=> SFN_Header_Num
,
71 No_Element
=> No_Entry
,
72 Key
=> Unit_Name_Type
,
75 -- Hash table allowing rapid access to SFN_Table, the element value
76 -- is an index into this table.
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
84 -- Records single call to Set_File_Name_Patterm
86 package SFN_Patterns
is new Table
.Table
(
87 Table_Component_Type
=> SFN_Pattern_Entry
,
88 Table_Index_Type
=> Int
,
91 Table_Increment
=> 100,
92 Table_Name
=> "SFN_Patterns");
93 -- Table recording all calls to Set_File_Name_Pattern. Note that the
94 -- first two entries are set to represent the standard GNAT rules
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
;
125 function Get_File_Name
126 (Uname
: Unit_Name_Type
;
128 return File_Name_Type
130 Unit_Char
: Character;
131 -- Set to 's' or 'b' for spec or body or to 'u' for a subunit
133 Unit_Char_Search
: Character;
134 -- Same as Unit_Char, except that in the case of 'u' for a subunit,
135 -- we set Unit_Char_Search to 'b' if we do not find a subunit match.
139 Pname
: File_Name_Type
:= No_File
;
140 Fname
: File_Name_Type
:= No_File
;
141 -- Path name and File name for mapping
144 -- Null or error name means that some previous error occurred
145 -- This is an unrecoverable error, so signal it.
147 if Uname
<= Error_Name
then
148 raise Unrecoverable_Error
;
151 -- Look in the map from unit names to file names
153 Fname
:= Mapped_File_Name
(Uname
);
155 -- If the unit name is already mapped, return the corresponding
156 -- file name from the map.
158 if Fname
/= No_File
then
162 -- If there is a specific SFN pragma, return the corresponding file name
164 N
:= SFN_HTable
.Get
(Uname
);
166 if N
/= No_Entry
then
167 return SFN_Table
.Table
(N
).F
;
170 -- Here for the case where the name was not found in the table
172 Get_Decoded_Name_String
(Uname
);
174 -- A special fudge, normally we don't have operator symbols present,
175 -- since it is always an error to do so. However, if we do, at this
176 -- stage it has a leading double quote.
178 -- What we do in this case is to go back to the undecoded name, which
179 -- is of the form, for example:
183 -- and build a file name that looks like:
187 -- which is bit peculiar, but we keep it that way. This means that
188 -- we avoid bombs due to writing a bad file name, and w get expected
189 -- error processing downstream, e.g. a compilation following gnatchop.
191 if Name_Buffer
(1) = '"' then
192 Get_Name_String
(Uname
);
193 Name_Len
:= Name_Len
+ 1;
194 Name_Buffer
(Name_Len
) := Name_Buffer
(Name_Len
- 1);
195 Name_Buffer
(Name_Len
- 1) := Name_Buffer
(Name_Len
- 2);
196 Name_Buffer
(Name_Len
- 2) := '_';
197 Name_Buffer
(1) := '_';
200 -- Deal with spec or body suffix
202 Unit_Char
:= Name_Buffer
(Name_Len
);
203 pragma Assert
(Unit_Char
= 'b' or else Unit_Char
= 's');
204 pragma Assert
(Name_Len
>= 3 and then Name_Buffer
(Name_Len
- 1) = '%');
205 Name_Len
:= Name_Len
- 2;
211 -- Now we need to find the proper translation of the name
214 Uname
: constant String (1 .. Name_Len
) :=
215 Name_Buffer
(1 .. Name_Len
);
219 Fnam
: File_Name_Type
:= No_File
;
224 function C
(N
: Natural) return Character;
225 -- Return N'th character of pattern
227 function C
(N
: Natural) return Character is
229 return SFN_Patterns
.Table
(Pent
).Pat
(N
);
232 -- Start of search through pattern table
235 -- Search pattern table to find a matching entry. In the general
236 -- case we do two complete searches. The first time through we
237 -- stop only if a matching file is found, the second time through
238 -- we accept the first match regardless. Note that there will
239 -- always be a match the second time around, because of the
240 -- default entries at the end of the table.
242 for No_File_Check
in False .. True loop
243 Unit_Char_Search
:= Unit_Char
;
246 -- The search is repeated with Unit_Char_Search set to b, if an
247 -- initial search for the subunit case fails to find any match.
249 Pent
:= SFN_Patterns
.First
;
250 while Pent
<= SFN_Patterns
.Last
loop
251 if SFN_Patterns
.Table
(Pent
).Typ
= Unit_Char_Search
then
254 -- Found a match, execute the pattern
256 Name_Len
:= Uname
'Length;
257 Name_Buffer
(1 .. Name_Len
) := Uname
;
258 Set_Casing
(SFN_Patterns
.Table
(Pent
).Cas
);
260 -- If dot translation required do it
262 Dot
:= SFN_Patterns
.Table
(Pent
).Dot
;
263 Dotl
:= Dot
.all'Length;
265 if Dot
.all /= "." then
268 while J
<= Name_Len
loop
269 if Name_Buffer
(J
) = '.' then
272 Name_Buffer
(J
) := Dot
(Dot
'First);
275 Name_Buffer
(J
+ Dotl
.. Name_Len
+ Dotl
- 1) :=
276 Name_Buffer
(J
+ 1 .. Name_Len
);
277 Name_Buffer
(J
.. J
+ Dotl
- 1) := Dot
.all;
278 Name_Len
:= Name_Len
+ Dotl
- 1;
283 -- Skip past wide char sequences to avoid messing
284 -- with dot characters that are part of a sequence.
286 elsif Name_Buffer
(J
) = ASCII
.ESC
287 or else (Upper_Half_Encoding
289 Name_Buffer
(J
) in Upper_Half_Character
)
291 Skip_Wide
(Name_Buffer
, J
);
298 -- Here move result to right if preinsertion before *
300 Plen
:= SFN_Patterns
.Table
(Pent
).Pat
'Length;
301 for K
in 1 .. Plen
loop
304 Name_Buffer
(1 + K
- 1 .. Name_Len
+ K
- 1) :=
305 Name_Buffer
(1 .. Name_Len
);
307 for L
in 1 .. K
- 1 loop
308 Name_Buffer
(L
) := C
(L
);
311 Name_Len
:= Name_Len
+ K
- 1;
314 for L
in K
+ 1 .. Plen
loop
315 Name_Len
:= Name_Len
+ 1;
316 Name_Buffer
(Name_Len
) := C
(L
);
323 -- Execute possible crunch on constructed name. The krunch
324 -- operation excludes any extension that may be present.
328 exit when Name_Buffer
(J
) = '.';
332 -- Case of extension present
336 Ext
: constant String := Name_Buffer
(J
.. Name_Len
);
343 -- Krunch what's left
348 Integer (Maximum_File_Name_Length
),
354 (Name_Len
+ 1 .. Name_Len
+ Ext
'Length) := Ext
;
355 Name_Len
:= Name_Len
+ Ext
'Length;
358 -- Case of no extension present, straight krunch on
359 -- the entire file name.
365 Integer (Maximum_File_Name_Length
),
369 Fnam
:= File_Name_Type
(Name_Find
);
371 -- If we are in the second search of the table, we accept
372 -- the file name without checking, because we know that
373 -- the file does not exist.
375 if No_File_Check
then
378 -- Otherwise we check if the file exists
381 Pname
:= Find_File
(Fnam
, Source
);
383 -- If it does exist, we add it to the mappings and
384 -- return the file name.
386 if Pname
/= No_File
then
388 -- Add to mapping, so that we don't do another
389 -- path search in Find_File for this file name
390 -- and, if we use a mapping file, we are ready
391 -- to update it at the end of this compilation
392 -- for the benefit of other compilation processes.
394 Add_To_File_Map
(Get_File_Name
.Uname
, Fnam
, Pname
);
397 -- If there are only two entries, they are those of
398 -- the default GNAT naming scheme. The file does
399 -- not exist, but there is no point doing the
400 -- second search, because we will end up with the
401 -- same file name. Just return the file name.
403 elsif SFN_Patterns
.Last
= 2 then
406 -- The file does not exist, but there may be other
407 -- naming scheme. Keep on searching.
418 -- If search failed, and was for a subunit, repeat the search
419 -- with Unit_Char_Search reset to 'b', since in the normal case
420 -- we simply treat subunits as bodies.
422 if Fnam
= No_File
and then Unit_Char_Search
= 'u' then
423 Unit_Char_Search
:= 'b';
427 -- Repeat entire search in No_File_Check mode if necessary
431 -- Something is wrong if search fails completely, since the
432 -- default entries should catch all possibilities at this stage.
442 procedure Initialize
is
447 -- Add default entries to SFN_Patterns.Table to represent the
448 -- standard default GNAT rules for file name translation.
450 SFN_Patterns
.Append
(New_Val
=>
451 (Pat
=> new String'("*.ads"),
453 Dot => new String'("-"),
454 Cas
=> All_Lower_Case
));
456 SFN_Patterns
.Append
(New_Val
=>
457 (Pat
=> new String'("*.adb"),
459 Dot => new String'("-"),
460 Cas
=> All_Lower_Case
));
469 SFN_Table
.Locked
:= True;
477 procedure Set_File_Name
(U
: Unit_Name_Type
; F
: File_Name_Type
) is
479 SFN_Table
.Increment_Last
;
480 SFN_Table
.Table
(SFN_Table
.Last
) := (U
, F
);
481 SFN_HTable
.Set
(U
, SFN_Table
.Last
);
484 ---------------------------
485 -- Set_File_Name_Pattern --
486 ---------------------------
488 procedure Set_File_Name_Pattern
494 L
: constant Nat
:= SFN_Patterns
.Last
;
496 SFN_Patterns
.Increment_Last
;
498 -- Move up the last two entries (the default ones) and then
499 -- put the new entry into the table just before them (we
500 -- always have the default entries be the last ones).
502 SFN_Patterns
.Table
(L
+ 1) := SFN_Patterns
.Table
(L
);
503 SFN_Patterns
.Table
(L
) := SFN_Patterns
.Table
(L
- 1);
504 SFN_Patterns
.Table
(L
- 1) := (Pat
, Typ
, Dot
, Cas
);
505 end Set_File_Name_Pattern
;
511 function SFN_Hash
(F
: Unit_Name_Type
) return SFN_Header_Num
is
513 return SFN_Header_Num
(Int
(F
) rem SFN_Header_Num
'Range_Length);
518 -- We call the initialization routine from the package body, so that
519 -- Fname.Init only needs to be called explicitly to reinitialize.