Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/scn.adb @ 111:04ced10e8804
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 -- S C N -- | |
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. 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. -- | |
20 -- -- | |
21 -- GNAT was originally developed by the GNAT team at New York University. -- | |
22 -- Extensive contributions were provided by Ada Core Technologies Inc. -- | |
23 -- -- | |
24 ------------------------------------------------------------------------------ | |
25 | |
26 with Atree; use Atree; | |
27 with Csets; use Csets; | |
28 with Namet; use Namet; | |
29 with Opt; use Opt; | |
30 with Restrict; use Restrict; | |
31 with Rident; use Rident; | |
32 with Scans; use Scans; | |
33 with Sinfo; use Sinfo; | |
34 with Sinput; use Sinput; | |
35 with Uintp; use Uintp; | |
36 | |
37 package body Scn is | |
38 | |
39 use ASCII; | |
40 | |
41 Used_As_Identifier : array (Token_Type) of Boolean; | |
42 -- Flags set True if a given keyword is used as an identifier (used to | |
43 -- make sure that we only post an error message for incorrect use of a | |
44 -- keyword as an identifier once for a given keyword). | |
45 | |
46 function Determine_License return License_Type; | |
47 -- Scan header of file and check that it has an appropriate GNAT-style | |
48 -- header with a proper license statement. Returns GPL, Unrestricted, | |
49 -- or Modified_GPL depending on header. If none of these, returns Unknown. | |
50 | |
51 ----------------------- | |
52 -- Determine_License -- | |
53 ----------------------- | |
54 | |
55 function Determine_License return License_Type is | |
56 GPL_Found : Boolean := False; | |
57 Result : License_Type; | |
58 | |
59 function Contains (S : String) return Boolean; | |
60 -- See if current comment contains successive non-blank characters | |
61 -- matching the contents of S. If so leave Scan_Ptr unchanged and | |
62 -- return True, otherwise leave Scan_Ptr unchanged and return False. | |
63 | |
64 procedure Skip_EOL; | |
65 -- Skip to line terminator character | |
66 | |
67 -------------- | |
68 -- Contains -- | |
69 -------------- | |
70 | |
71 function Contains (S : String) return Boolean is | |
72 CP : Natural; | |
73 SP : Source_Ptr; | |
74 SS : Source_Ptr; | |
75 | |
76 begin | |
77 -- Loop to check characters. This loop is terminated by end of | |
78 -- line, and also we need to check for the EOF case, to take | |
79 -- care of files containing only comments. | |
80 | |
81 SP := Scan_Ptr; | |
82 while Source (SP) /= CR and then | |
83 Source (SP) /= LF and then | |
84 Source (SP) /= EOF | |
85 loop | |
86 if Source (SP) = S (S'First) then | |
87 SS := SP; | |
88 CP := S'First; | |
89 | |
90 loop | |
91 SS := SS + 1; | |
92 CP := CP + 1; | |
93 | |
94 if CP > S'Last then | |
95 return True; | |
96 end if; | |
97 | |
98 while Source (SS) = ' ' loop | |
99 SS := SS + 1; | |
100 end loop; | |
101 | |
102 exit when Source (SS) /= S (CP); | |
103 end loop; | |
104 end if; | |
105 | |
106 SP := SP + 1; | |
107 end loop; | |
108 | |
109 return False; | |
110 end Contains; | |
111 | |
112 -------------- | |
113 -- Skip_EOL -- | |
114 -------------- | |
115 | |
116 procedure Skip_EOL is | |
117 begin | |
118 while Source (Scan_Ptr) /= CR | |
119 and then Source (Scan_Ptr) /= LF | |
120 and then Source (Scan_Ptr) /= EOF | |
121 loop | |
122 Scan_Ptr := Scan_Ptr + 1; | |
123 end loop; | |
124 end Skip_EOL; | |
125 | |
126 -- Start of processing for Determine_License | |
127 | |
128 begin | |
129 loop | |
130 if Source (Scan_Ptr) /= '-' | |
131 or else Source (Scan_Ptr + 1) /= '-' | |
132 then | |
133 if GPL_Found then | |
134 Result := GPL; | |
135 exit; | |
136 else | |
137 Result := Unknown; | |
138 exit; | |
139 end if; | |
140 | |
141 elsif Contains ("Asaspecialexception") then | |
142 if GPL_Found then | |
143 Result := Modified_GPL; | |
144 exit; | |
145 end if; | |
146 | |
147 elsif Contains ("GNUGeneralPublicLicense") then | |
148 GPL_Found := True; | |
149 | |
150 elsif | |
151 Contains | |
152 ("ThisspecificationisadaptedfromtheAdaSemanticInterface") | |
153 or else | |
154 Contains | |
155 ("ThisspecificationisderivedfromtheAdaReferenceManual") | |
156 then | |
157 Result := Unrestricted; | |
158 exit; | |
159 end if; | |
160 | |
161 Skip_EOL; | |
162 | |
163 Scanner.Check_End_Of_Line; | |
164 | |
165 if Source (Scan_Ptr) /= EOF then | |
166 | |
167 -- We have to take into account a degenerate case when the source | |
168 -- file contains only comments and no Ada code. | |
169 | |
170 declare | |
171 Physical : Boolean; | |
172 | |
173 begin | |
174 Skip_Line_Terminators (Scan_Ptr, Physical); | |
175 | |
176 -- If we are at start of physical line, update scan pointers | |
177 -- to reflect the start of the new line. | |
178 | |
179 if Physical then | |
180 Current_Line_Start := Scan_Ptr; | |
181 Start_Column := Scanner.Set_Start_Column; | |
182 First_Non_Blank_Location := Scan_Ptr; | |
183 end if; | |
184 end; | |
185 end if; | |
186 end loop; | |
187 | |
188 return Result; | |
189 end Determine_License; | |
190 | |
191 ---------------------------- | |
192 -- Determine_Token_Casing -- | |
193 ---------------------------- | |
194 | |
195 function Determine_Token_Casing return Casing_Type is | |
196 begin | |
197 return Scanner.Determine_Token_Casing; | |
198 end Determine_Token_Casing; | |
199 | |
200 ------------------------ | |
201 -- Initialize_Scanner -- | |
202 ------------------------ | |
203 | |
204 procedure Initialize_Scanner | |
205 (Unit : Unit_Number_Type; | |
206 Index : Source_File_Index) | |
207 is | |
208 GNAT_Hedr : constant Text_Buffer (1 .. 78) := (others => '-'); | |
209 | |
210 begin | |
211 Scanner.Initialize_Scanner (Index); | |
212 Set_Unit (Index, Unit); | |
213 | |
214 Current_Source_Unit := Unit; | |
215 | |
216 -- Set default for Comes_From_Source. All nodes built now until we | |
217 -- reenter the analyzer will have Comes_From_Source set to True | |
218 | |
219 Set_Comes_From_Source_Default (True); | |
220 | |
221 -- Check license if GNAT type header possibly present | |
222 | |
223 if Source_Last (Index) - Scan_Ptr > 80 | |
224 and then Source (Scan_Ptr .. Scan_Ptr + 77) = GNAT_Hedr | |
225 then | |
226 Set_License (Current_Source_File, Determine_License); | |
227 end if; | |
228 | |
229 Check_For_BOM; | |
230 | |
231 -- Because of the License stuff above, Scng.Initialize_Scanner cannot | |
232 -- call Scan. Scan initial token (note this initializes Prev_Token, | |
233 -- Prev_Token_Ptr). | |
234 | |
235 Scan; | |
236 | |
237 -- Clear flags for reserved words used as identifiers | |
238 | |
239 Used_As_Identifier := (others => False); | |
240 end Initialize_Scanner; | |
241 | |
242 --------------- | |
243 -- Post_Scan -- | |
244 --------------- | |
245 | |
246 procedure Post_Scan is | |
247 procedure Check_Obsolescent_Features_Restriction (S : Source_Ptr); | |
248 -- This checks for Obsolescent_Features restriction being active, and | |
249 -- if so, flags the restriction as occurring at the given scan location. | |
250 | |
251 procedure Check_Obsolete_Base_Char; | |
252 -- Check for numeric literal using ':' instead of '#' for based case | |
253 | |
254 -------------------------------------------- | |
255 -- Check_Obsolescent_Features_Restriction -- | |
256 -------------------------------------------- | |
257 | |
258 procedure Check_Obsolescent_Features_Restriction (S : Source_Ptr) is | |
259 begin | |
260 -- Normally we have a node handy for posting restrictions. We don't | |
261 -- have such a node here, so construct a dummy one with the right | |
262 -- scan pointer. This is only used to get the Sloc value anyway. | |
263 | |
264 Check_Restriction (No_Obsolescent_Features, New_Node (N_Empty, S)); | |
265 end Check_Obsolescent_Features_Restriction; | |
266 | |
267 ------------------------------ | |
268 -- Check_Obsolete_Base_Char -- | |
269 ------------------------------ | |
270 | |
271 procedure Check_Obsolete_Base_Char is | |
272 S : Source_Ptr; | |
273 | |
274 begin | |
275 if Based_Literal_Uses_Colon then | |
276 | |
277 -- Find the : for the restriction or warning message | |
278 | |
279 S := Token_Ptr; | |
280 while Source (S) /= ':' loop | |
281 S := S + 1; | |
282 end loop; | |
283 | |
284 Check_Obsolescent_Features_Restriction (S); | |
285 | |
286 if Warn_On_Obsolescent_Feature then | |
287 Error_Msg | |
288 ("?j?use of "":"" is an obsolescent feature (RM J.2(3))", S); | |
289 Error_Msg | |
290 ("\?j?use ""'#"" instead", S); | |
291 end if; | |
292 end if; | |
293 end Check_Obsolete_Base_Char; | |
294 | |
295 -- Start of processing for Post_Scan | |
296 | |
297 begin | |
298 case Token is | |
299 when Tok_Char_Literal => | |
300 Token_Node := New_Node (N_Character_Literal, Token_Ptr); | |
301 Set_Char_Literal_Value (Token_Node, UI_From_CC (Character_Code)); | |
302 Set_Chars (Token_Node, Token_Name); | |
303 | |
304 when Tok_Identifier => | |
305 Token_Node := New_Node (N_Identifier, Token_Ptr); | |
306 Set_Chars (Token_Node, Token_Name); | |
307 | |
308 when Tok_Real_Literal => | |
309 Token_Node := New_Node (N_Real_Literal, Token_Ptr); | |
310 Set_Realval (Token_Node, Real_Literal_Value); | |
311 Check_Obsolete_Base_Char; | |
312 | |
313 when Tok_Integer_Literal => | |
314 Token_Node := New_Node (N_Integer_Literal, Token_Ptr); | |
315 Set_Intval (Token_Node, Int_Literal_Value); | |
316 Check_Obsolete_Base_Char; | |
317 | |
318 when Tok_String_Literal => | |
319 Token_Node := New_Node (N_String_Literal, Token_Ptr); | |
320 Set_Has_Wide_Character | |
321 (Token_Node, Wide_Character_Found); | |
322 Set_Has_Wide_Wide_Character | |
323 (Token_Node, Wide_Wide_Character_Found); | |
324 Set_Strval (Token_Node, String_Literal_Id); | |
325 | |
326 if Source (Token_Ptr) = '%' then | |
327 Check_Obsolescent_Features_Restriction (Token_Ptr); | |
328 | |
329 if Warn_On_Obsolescent_Feature then | |
330 Error_Msg_SC | |
331 ("?j?use of ""'%"" is an obsolescent feature (RM J.2(4))"); | |
332 Error_Msg_SC ("\?j?use """""" instead"); | |
333 end if; | |
334 end if; | |
335 | |
336 when Tok_Operator_Symbol => | |
337 Token_Node := New_Node (N_Operator_Symbol, Token_Ptr); | |
338 Set_Chars (Token_Node, Token_Name); | |
339 Set_Strval (Token_Node, String_Literal_Id); | |
340 | |
341 when Tok_Vertical_Bar => | |
342 if Source (Token_Ptr) = '!' then | |
343 Check_Obsolescent_Features_Restriction (Token_Ptr); | |
344 | |
345 if Warn_On_Obsolescent_Feature then | |
346 Error_Msg_SC | |
347 ("?j?use of ""'!"" is an obsolescent feature (RM J.2(2))"); | |
348 Error_Msg_SC ("\?j?use ""'|"" instead"); | |
349 end if; | |
350 end if; | |
351 | |
352 when others => | |
353 null; | |
354 end case; | |
355 end Post_Scan; | |
356 | |
357 ------------------------------ | |
358 -- Scan_Reserved_Identifier -- | |
359 ------------------------------ | |
360 | |
361 procedure Scan_Reserved_Identifier (Force_Msg : Boolean) is | |
362 Token_Chars : String := Token_Type'Image (Token); | |
363 Len : Natural := 0; | |
364 | |
365 begin | |
366 -- AI12-0125 : '@' denotes the target_name, i.e. serves as an | |
367 -- abbreviation for the LHS of an assignment. | |
368 | |
369 if Token = Tok_At_Sign then | |
370 Token_Node := New_Node (N_Target_Name, Token_Ptr); | |
371 return; | |
372 end if; | |
373 | |
374 -- We have in Token_Chars the image of the Token name, i.e. Tok_xxx. | |
375 -- This code extracts the xxx and makes an identifier out of it. | |
376 | |
377 for J in 5 .. Token_Chars'Length loop | |
378 Len := Len + 1; | |
379 Token_Chars (Len) := Fold_Lower (Token_Chars (J)); | |
380 end loop; | |
381 | |
382 Token_Name := Name_Find (Token_Chars (1 .. Len)); | |
383 | |
384 -- If Inside_Pragma is True, we don't give an error. This is to allow | |
385 -- things like "pragma Ignore_Pragma (Interface)", where "Interface" is | |
386 -- a reserved word. There is no danger of missing errors, because any | |
387 -- misuse must have been preceded by an illegal declaration. For | |
388 -- example, in "pragma Pack (Begin);", either Begin is not declared, | |
389 -- which is an error, or it is declared, which will be an error on that | |
390 -- declaration. | |
391 | |
392 if (not Used_As_Identifier (Token) or else Force_Msg) | |
393 and then not Inside_Pragma | |
394 then | |
395 Error_Msg_Name_1 := Token_Name; | |
396 Error_Msg_SC ("reserved word* cannot be used as identifier!"); | |
397 Used_As_Identifier (Token) := True; | |
398 end if; | |
399 | |
400 Token := Tok_Identifier; | |
401 Token_Node := New_Node (N_Identifier, Token_Ptr); | |
402 Set_Chars (Token_Node, Token_Name); | |
403 end Scan_Reserved_Identifier; | |
404 | |
405 end Scn; |