|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- F N A M E --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
|
|
|
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. --
|
|
|
17 -- --
|
|
|
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
|
19 -- additional permissions described in the GCC Runtime Library Exception, --
|
|
|
20 -- version 3.1, as published by the Free Software Foundation. --
|
|
|
21 -- --
|
|
|
22 -- You should have received a copy of the GNU General Public License and --
|
|
|
23 -- a copy of the GCC Runtime Library Exception along with this program; --
|
|
|
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
|
25 -- <http://www.gnu.org/licenses/>. --
|
|
|
26 -- --
|
|
|
27 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
32 with Alloc;
|
|
|
33 with Table;
|
|
|
34 with Types; use Types;
|
|
|
35
|
|
|
36 package body Fname is
|
|
|
37
|
|
|
38 -----------------------------
|
|
|
39 -- Dummy Table Definitions --
|
|
|
40 -----------------------------
|
|
|
41
|
|
|
42 -- The following table was used in old versions of the compiler. We retain
|
|
|
43 -- the declarations here for compatibility with old tree files. The new
|
|
|
44 -- version of the compiler does not use this table, and will write out a
|
|
|
45 -- dummy empty table for Tree_Write.
|
|
|
46
|
|
|
47 type SFN_Entry is record
|
|
|
48 U : Unit_Name_Type;
|
|
|
49 F : File_Name_Type;
|
|
|
50 end record;
|
|
|
51
|
|
|
52 package SFN_Table is new Table.Table (
|
|
|
53 Table_Component_Type => SFN_Entry,
|
|
|
54 Table_Index_Type => Int,
|
|
|
55 Table_Low_Bound => 0,
|
|
|
56 Table_Initial => Alloc.SFN_Table_Initial,
|
|
|
57 Table_Increment => Alloc.SFN_Table_Increment,
|
|
|
58 Table_Name => "Fname_Dummy_Table");
|
|
|
59
|
|
|
60 function Has_Internal_Extension (Fname : String) return Boolean;
|
|
|
61 pragma Inline (Has_Internal_Extension);
|
|
|
62 -- True if the extension is appropriate for an internal/predefined unit.
|
|
|
63 -- That means ".ads" or ".adb" for source files, and ".ali" for ALI files.
|
|
|
64
|
|
|
65 function Has_Prefix (X, Prefix : String) return Boolean;
|
|
|
66 pragma Inline (Has_Prefix);
|
|
|
67 -- True if Prefix is at the beginning of X. For example,
|
|
|
68 -- Has_Prefix ("a-filename.ads", Prefix => "a-") is True.
|
|
|
69
|
|
|
70 ----------------------------
|
|
|
71 -- Has_Internal_Extension --
|
|
|
72 ----------------------------
|
|
|
73
|
|
|
74 function Has_Internal_Extension (Fname : String) return Boolean is
|
|
|
75 begin
|
|
|
76 if Fname'Length >= 4 then
|
|
|
77 declare
|
|
|
78 S : String renames Fname (Fname'Last - 3 .. Fname'Last);
|
|
|
79 begin
|
|
|
80 return S = ".ads" or else S = ".adb" or else S = ".ali";
|
|
|
81 end;
|
|
|
82 end if;
|
|
|
83 return False;
|
|
|
84 end Has_Internal_Extension;
|
|
|
85
|
|
|
86 ----------------
|
|
|
87 -- Has_Prefix --
|
|
|
88 ----------------
|
|
|
89
|
|
|
90 function Has_Prefix (X, Prefix : String) return Boolean is
|
|
|
91 begin
|
|
|
92 if X'Length >= Prefix'Length then
|
|
|
93 declare
|
|
|
94 S : String renames X (X'First .. X'First + Prefix'Length - 1);
|
|
|
95 begin
|
|
|
96 return S = Prefix;
|
|
|
97 end;
|
|
|
98 end if;
|
|
|
99 return False;
|
|
|
100 end Has_Prefix;
|
|
|
101
|
|
|
102 -----------------------
|
|
|
103 -- Is_GNAT_File_Name --
|
|
|
104 -----------------------
|
|
|
105
|
|
|
106 function Is_GNAT_File_Name (Fname : String) return Boolean is
|
|
|
107 begin
|
|
|
108 -- Check for internal extensions before checking prefixes, so we don't
|
|
|
109 -- think (e.g.) "gnat.adc" is internal.
|
|
|
110
|
|
|
111 if not Has_Internal_Extension (Fname) then
|
|
|
112 return False;
|
|
|
113 end if;
|
|
|
114
|
|
|
115 -- Definitely internal if prefix is g-
|
|
|
116
|
|
|
117 if Has_Prefix (Fname, "g-") then
|
|
|
118 return True;
|
|
|
119 end if;
|
|
|
120
|
|
|
121 -- See the note in Is_Predefined_File_Name for the rationale
|
|
|
122
|
|
|
123 return Fname'Length = 8 and then Has_Prefix (Fname, "gnat");
|
|
|
124 end Is_GNAT_File_Name;
|
|
|
125
|
|
|
126 function Is_GNAT_File_Name (Fname : File_Name_Type) return Boolean is
|
|
|
127 Result : constant Boolean :=
|
|
|
128 Is_GNAT_File_Name (Get_Name_String (Fname));
|
|
|
129 begin
|
|
|
130 return Result;
|
|
|
131 end Is_GNAT_File_Name;
|
|
|
132
|
|
|
133 ---------------------------
|
|
|
134 -- Is_Internal_File_Name --
|
|
|
135 ---------------------------
|
|
|
136
|
|
|
137 function Is_Internal_File_Name
|
|
|
138 (Fname : String;
|
|
|
139 Renamings_Included : Boolean := True) return Boolean
|
|
|
140 is
|
|
|
141 begin
|
|
|
142 if Is_Predefined_File_Name (Fname, Renamings_Included) then
|
|
|
143 return True;
|
|
|
144 end if;
|
|
|
145
|
|
|
146 return Is_GNAT_File_Name (Fname);
|
|
|
147 end Is_Internal_File_Name;
|
|
|
148
|
|
|
149 function Is_Internal_File_Name
|
|
|
150 (Fname : File_Name_Type;
|
|
|
151 Renamings_Included : Boolean := True) return Boolean
|
|
|
152 is
|
|
|
153 Result : constant Boolean :=
|
|
|
154 Is_Internal_File_Name
|
|
|
155 (Get_Name_String (Fname), Renamings_Included);
|
|
|
156 begin
|
|
|
157 return Result;
|
|
|
158 end Is_Internal_File_Name;
|
|
|
159
|
|
|
160 -----------------------------
|
|
|
161 -- Is_Predefined_File_Name --
|
|
|
162 -----------------------------
|
|
|
163
|
|
|
164 function Is_Predefined_File_Name
|
|
|
165 (Fname : String;
|
|
|
166 Renamings_Included : Boolean := True) return Boolean
|
|
|
167 is
|
|
|
168 begin
|
|
|
169 -- Definitely false if longer than 12 characters (8.3)
|
|
|
170
|
|
|
171 if Fname'Length > 12 then
|
|
|
172 return False;
|
|
|
173 end if;
|
|
|
174
|
|
|
175 if not Has_Internal_Extension (Fname) then
|
|
|
176 return False;
|
|
|
177 end if;
|
|
|
178
|
|
|
179 -- Definitely predefined if prefix is a- i- or s-
|
|
|
180
|
|
|
181 if Fname'Length >= 2 then
|
|
|
182 declare
|
|
|
183 S : String renames Fname (Fname'First .. Fname'First + 1);
|
|
|
184 begin
|
|
|
185 if S = "a-" or else S = "i-" or else S = "s-" then
|
|
|
186 return True;
|
|
|
187 end if;
|
|
|
188 end;
|
|
|
189 end if;
|
|
|
190
|
|
|
191 -- We include the "." in the prefixes below, so we don't match (e.g.)
|
|
|
192 -- adamant.ads. So the first line matches "ada.ads", "ada.adb", and
|
|
|
193 -- "ada.ali". But that's not necessary if they have 8 characters.
|
|
|
194
|
|
|
195 if Has_Prefix (Fname, "ada.") -- Ada
|
|
|
196 or else Has_Prefix (Fname, "interfac") -- Interfaces
|
|
|
197 or else Has_Prefix (Fname, "system.a") -- System
|
|
|
198 then
|
|
|
199 return True;
|
|
|
200 end if;
|
|
|
201
|
|
|
202 -- If instructed and the name has 8+ characters, check for renamings
|
|
|
203
|
|
|
204 if Renamings_Included
|
|
|
205 and then Is_Predefined_Renaming_File_Name (Fname)
|
|
|
206 then
|
|
|
207 return True;
|
|
|
208 end if;
|
|
|
209
|
|
|
210 return False;
|
|
|
211 end Is_Predefined_File_Name;
|
|
|
212
|
|
|
213 function Is_Predefined_File_Name
|
|
|
214 (Fname : File_Name_Type;
|
|
|
215 Renamings_Included : Boolean := True) return Boolean
|
|
|
216 is
|
|
|
217 Result : constant Boolean :=
|
|
|
218 Is_Predefined_File_Name
|
|
|
219 (Get_Name_String (Fname), Renamings_Included);
|
|
|
220 begin
|
|
|
221 return Result;
|
|
|
222 end Is_Predefined_File_Name;
|
|
|
223
|
|
|
224 --------------------------------------
|
|
|
225 -- Is_Predefined_Renaming_File_Name --
|
|
|
226 --------------------------------------
|
|
|
227
|
|
|
228 function Is_Predefined_Renaming_File_Name
|
|
|
229 (Fname : String) return Boolean
|
|
|
230 is
|
|
|
231 subtype Str8 is String (1 .. 8);
|
|
|
232
|
|
|
233 Renaming_Names : constant array (1 .. 8) of Str8 :=
|
|
|
234 ("calendar", -- Calendar
|
|
|
235 "machcode", -- Machine_Code
|
|
|
236 "unchconv", -- Unchecked_Conversion
|
|
|
237 "unchdeal", -- Unchecked_Deallocation
|
|
|
238 "directio", -- Direct_IO
|
|
|
239 "ioexcept", -- IO_Exceptions
|
|
|
240 "sequenio", -- Sequential_IO
|
|
|
241 "text_io."); -- Text_IO
|
|
|
242 begin
|
|
|
243 -- Definitely false if longer than 12 characters (8.3)
|
|
|
244
|
|
|
245 if Fname'Length in 8 .. 12 then
|
|
|
246 declare
|
|
|
247 S : String renames Fname (Fname'First .. Fname'First + 7);
|
|
|
248 begin
|
|
|
249 for J in Renaming_Names'Range loop
|
|
|
250 if S = Renaming_Names (J) then
|
|
|
251 return True;
|
|
|
252 end if;
|
|
|
253 end loop;
|
|
|
254 end;
|
|
|
255 end if;
|
|
|
256
|
|
|
257 return False;
|
|
|
258 end Is_Predefined_Renaming_File_Name;
|
|
|
259
|
|
|
260 function Is_Predefined_Renaming_File_Name
|
|
|
261 (Fname : File_Name_Type) return Boolean is
|
|
|
262 Result : constant Boolean :=
|
|
|
263 Is_Predefined_Renaming_File_Name (Get_Name_String (Fname));
|
|
|
264 begin
|
|
|
265 return Result;
|
|
|
266 end Is_Predefined_Renaming_File_Name;
|
|
|
267
|
|
|
268 ---------------
|
|
|
269 -- Tree_Read --
|
|
|
270 ---------------
|
|
|
271
|
|
|
272 procedure Tree_Read is
|
|
|
273 begin
|
|
|
274 SFN_Table.Tree_Read;
|
|
|
275 end Tree_Read;
|
|
|
276
|
|
|
277 ----------------
|
|
|
278 -- Tree_Write --
|
|
|
279 ----------------
|
|
|
280
|
|
|
281 procedure Tree_Write is
|
|
|
282 begin
|
|
|
283 SFN_Table.Tree_Write;
|
|
|
284 end Tree_Write;
|
|
|
285
|
|
|
286 end Fname;
|
