1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2018, 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 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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Csets
; use Csets
;
28 with Namet
; use Namet
;
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
;
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).
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.
51 -----------------------
52 -- Determine_License --
53 -----------------------
55 function Determine_License
return License_Type
is
56 GPL_Found
: Boolean := False;
57 Result
: License_Type
;
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.
65 -- Skip to line terminator character
71 function Contains
(S
: String) return Boolean is
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.
82 while Source
(SP
) /= CR
and then
83 Source
(SP
) /= LF
and then
86 if Source
(SP
) = S
(S
'First) then
98 while Source
(SS
) = ' ' loop
102 exit when Source
(SS
) /= S
(CP
);
116 procedure Skip_EOL
is
118 while Source
(Scan_Ptr
) /= CR
119 and then Source
(Scan_Ptr
) /= LF
120 and then Source
(Scan_Ptr
) /= EOF
122 Scan_Ptr
:= Scan_Ptr
+ 1;
126 -- Start of processing for Determine_License
130 if Source
(Scan_Ptr
) /= '-'
131 or else Source
(Scan_Ptr
+ 1) /= '-'
141 elsif Contains
("Asaspecialexception") then
143 Result
:= Modified_GPL
;
147 elsif Contains
("GNUGeneralPublicLicense") then
152 ("ThisspecificationisadaptedfromtheAdaSemanticInterface")
155 ("ThisspecificationisderivedfromtheAdaReferenceManual")
157 Result
:= Unrestricted
;
163 Scanner
.Check_End_Of_Line
;
165 if Source
(Scan_Ptr
) /= EOF
then
167 -- We have to take into account a degenerate case when the source
168 -- file contains only comments and no Ada code.
174 Skip_Line_Terminators
(Scan_Ptr
, Physical
);
176 -- If we are at start of physical line, update scan pointers
177 -- to reflect the start of the new line.
180 Current_Line_Start
:= Scan_Ptr
;
181 Start_Column
:= Scanner
.Set_Start_Column
;
182 First_Non_Blank_Location
:= Scan_Ptr
;
189 end Determine_License
;
191 ----------------------------
192 -- Determine_Token_Casing --
193 ----------------------------
195 function Determine_Token_Casing
return Casing_Type
is
197 return Scanner
.Determine_Token_Casing
;
198 end Determine_Token_Casing
;
200 ------------------------
201 -- Initialize_Scanner --
202 ------------------------
204 procedure Initialize_Scanner
205 (Unit
: Unit_Number_Type
;
206 Index
: Source_File_Index
)
208 GNAT_Hedr
: constant Text_Buffer
(1 .. 78) := (others => '-');
211 Scanner
.Initialize_Scanner
(Index
);
212 Set_Unit
(Index
, Unit
);
214 Current_Source_Unit
:= Unit
;
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
219 Set_Comes_From_Source_Default
(True);
221 -- Check license if GNAT type header possibly present
223 if Source_Last
(Index
) - Scan_Ptr
> 80
224 and then Source
(Scan_Ptr
.. Scan_Ptr
+ 77) = GNAT_Hedr
226 Set_License
(Current_Source_File
, Determine_License
);
231 -- Because of the License stuff above, Scng.Initialize_Scanner cannot
232 -- call Scan. Scan initial token (note this initializes Prev_Token,
237 -- Clear flags for reserved words used as identifiers
239 Used_As_Identifier
:= (others => False);
240 end Initialize_Scanner
;
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.
251 procedure Check_Obsolete_Base_Char
;
252 -- Check for numeric literal using ':' instead of '#' for based case
254 --------------------------------------------
255 -- Check_Obsolescent_Features_Restriction --
256 --------------------------------------------
258 procedure Check_Obsolescent_Features_Restriction
(S
: Source_Ptr
) is
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.
264 Check_Restriction
(No_Obsolescent_Features
, New_Node
(N_Empty
, S
));
265 end Check_Obsolescent_Features_Restriction
;
267 ------------------------------
268 -- Check_Obsolete_Base_Char --
269 ------------------------------
271 procedure Check_Obsolete_Base_Char
is
275 if Based_Literal_Uses_Colon
then
277 -- Find the : for the restriction or warning message
280 while Source
(S
) /= ':' loop
284 Check_Obsolescent_Features_Restriction
(S
);
286 if Warn_On_Obsolescent_Feature
then
288 ("?j?use of "":"" is an obsolescent feature (RM J.2(3))", S
);
290 ("\?j?use ""'#"" instead", S
);
293 end Check_Obsolete_Base_Char
;
295 -- Start of processing for Post_Scan
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
);
304 when Tok_Identifier
=>
305 Token_Node
:= New_Node
(N_Identifier
, Token_Ptr
);
306 Set_Chars
(Token_Node
, Token_Name
);
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
;
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
;
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
);
326 if Source
(Token_Ptr
) = '%' then
327 Check_Obsolescent_Features_Restriction
(Token_Ptr
);
329 if Warn_On_Obsolescent_Feature
then
331 ("?j?use of ""'%"" is an obsolescent feature (RM J.2(4))");
332 Error_Msg_SC
("\?j?use """""" instead");
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
);
341 when Tok_Vertical_Bar
=>
342 if Source
(Token_Ptr
) = '!' then
343 Check_Obsolescent_Features_Restriction
(Token_Ptr
);
345 if Warn_On_Obsolescent_Feature
then
347 ("?j?use of ""'!"" is an obsolescent feature (RM J.2(2))");
348 Error_Msg_SC
("\?j?use ""'|"" instead");
357 ------------------------------
358 -- Scan_Reserved_Identifier --
359 ------------------------------
361 procedure Scan_Reserved_Identifier
(Force_Msg
: Boolean) is
362 Token_Chars
: String := Token_Type
'Image (Token
);
366 -- AI12-0125 : '@' denotes the target_name, i.e. serves as an
367 -- abbreviation for the LHS of an assignment.
369 if Token
= Tok_At_Sign
then
370 Token_Node
:= New_Node
(N_Target_Name
, Token_Ptr
);
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.
377 for J
in 5 .. Token_Chars
'Length loop
379 Token_Chars
(Len
) := Fold_Lower
(Token_Chars
(J
));
382 Token_Name
:= Name_Find
(Token_Chars
(1 .. Len
));
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
392 if (not Used_As_Identifier
(Token
) or else Force_Msg
)
393 and then not Inside_Pragma
395 Error_Msg_Name_1
:= Token_Name
;
396 Error_Msg_SC
("reserved word* cannot be used as identifier!");
397 Used_As_Identifier
(Token
) := True;
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
;