Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/fname.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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;