1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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 Hostparm
; use Hostparm
;
29 with Namet
; use Namet
;
31 with Output
; use Output
;
32 with Restrict
; use Restrict
;
33 with Rident
; use Rident
;
34 with Scans
; use Scans
;
35 with Sinfo
; use Sinfo
;
36 with Sinput
; use Sinput
;
37 with Uintp
; use Uintp
;
39 with GNAT
.Byte_Order_Mark
; use GNAT
.Byte_Order_Mark
;
41 with System
.WCh_Con
; use System
.WCh_Con
;
47 Used_As_Identifier
: array (Token_Type
) of Boolean;
48 -- Flags set True if a given keyword is used as an identifier (used to
49 -- make sure that we only post an error message for incorrect use of a
50 -- keyword as an identifier once for a given keyword).
52 procedure Check_End_Of_Line
;
53 -- Called when end of line encountered. Checks that line is not too long,
54 -- and that other style checks for the end of line are met.
56 function Determine_License
return License_Type
;
57 -- Scan header of file and check that it has an appropriate GNAT-style
58 -- header with a proper license statement. Returns GPL, Unrestricted,
59 -- or Modified_GPL depending on header. If none of these, returns Unknown.
61 procedure Error_Long_Line
;
62 -- Signal error of excessively long line
64 -----------------------
65 -- Check_End_Of_Line --
66 -----------------------
68 procedure Check_End_Of_Line
is
69 Len
: constant Int
:= Int
(Scan_Ptr
) - Int
(Current_Line_Start
);
72 Style
.Check_Line_Terminator
(Len
);
73 elsif Len
> Max_Line_Length
then
76 end Check_End_Of_Line
;
78 -----------------------
79 -- Determine_License --
80 -----------------------
82 function Determine_License
return License_Type
is
83 GPL_Found
: Boolean := False;
84 Result
: License_Type
;
86 function Contains
(S
: String) return Boolean;
87 -- See if current comment contains successive non-blank characters
88 -- matching the contents of S. If so leave Scan_Ptr unchanged and
89 -- return True, otherwise leave Scan_Ptr unchanged and return False.
92 -- Skip to line terminator character
98 function Contains
(S
: String) return Boolean is
104 -- Loop to check characters. This loop is terminated by end of
105 -- line, and also we need to check for the EOF case, to take
106 -- care of files containing only comments.
109 while Source
(SP
) /= CR
and then
110 Source
(SP
) /= LF
and then
113 if Source
(SP
) = S
(S
'First) then
125 while Source
(SS
) = ' ' loop
129 exit when Source
(SS
) /= S
(CP
);
143 procedure Skip_EOL
is
145 while Source
(Scan_Ptr
) /= CR
146 and then Source
(Scan_Ptr
) /= LF
147 and then Source
(Scan_Ptr
) /= EOF
149 Scan_Ptr
:= Scan_Ptr
+ 1;
153 -- Start of processing for Determine_License
157 if Source
(Scan_Ptr
) /= '-'
158 or else Source
(Scan_Ptr
+ 1) /= '-'
168 elsif Contains
("Asaspecialexception") then
170 Result
:= Modified_GPL
;
174 elsif Contains
("GNUGeneralPublicLicense") then
179 ("ThisspecificationisadaptedfromtheAdaSemanticInterface")
182 ("ThisspecificationisderivedfromtheAdaReferenceManual")
184 Result
:= Unrestricted
;
192 if Source
(Scan_Ptr
) /= EOF
then
194 -- We have to take into account a degenerate case when the source
195 -- file contains only comments and no Ada code.
201 Skip_Line_Terminators
(Scan_Ptr
, Physical
);
203 -- If we are at start of physical line, update scan pointers
204 -- to reflect the start of the new line.
207 Current_Line_Start
:= Scan_Ptr
;
208 Start_Column
:= Scanner
.Set_Start_Column
;
209 First_Non_Blank_Location
:= Scan_Ptr
;
216 end Determine_License
;
218 ----------------------------
219 -- Determine_Token_Casing --
220 ----------------------------
222 function Determine_Token_Casing
return Casing_Type
is
224 return Scanner
.Determine_Token_Casing
;
225 end Determine_Token_Casing
;
227 ---------------------
228 -- Error_Long_Line --
229 ---------------------
231 procedure Error_Long_Line
is
234 ("this line is too long",
235 Current_Line_Start
+ Source_Ptr
(Max_Line_Length
));
238 ------------------------
239 -- Initialize_Scanner --
240 ------------------------
242 procedure Initialize_Scanner
243 (Unit
: Unit_Number_Type
;
244 Index
: Source_File_Index
)
246 GNAT_Hedr
: constant Text_Buffer
(1 .. 78) := (others => '-');
249 Scanner
.Initialize_Scanner
(Index
);
251 if Index
/= Internal_Source_File
then
252 Set_Unit
(Index
, Unit
);
255 Current_Source_Unit
:= Unit
;
257 -- Set default for Comes_From_Source (except if we are going to process
258 -- an artificial string internally created within the compiler and
259 -- placed into internal source duffer). All nodes built now until we
260 -- reenter the analyzer will have Comes_From_Source set to True
262 if Index
/= Internal_Source_File
then
263 Set_Comes_From_Source_Default
(True);
266 -- Check license if GNAT type header possibly present
268 if Source_Last
(Index
) - Scan_Ptr
> 80
269 and then Source
(Scan_Ptr
.. Scan_Ptr
+ 77) = GNAT_Hedr
271 Set_License
(Current_Source_File
, Determine_License
);
279 Tst
: String (1 .. 5);
283 Tst
(J
) := Source
(Scan_Ptr
+ Source_Ptr
(J
) - 1);
286 Read_BOM
(Tst
, Len
, BOM
, False);
290 Scan_Ptr
:= Scan_Ptr
+ Source_Ptr
(Len
);
291 Wide_Character_Encoding_Method
:= WCEM_UTF8
;
292 Upper_Half_Encoding
:= True;
294 when UTF16_LE | UTF16_BE
=>
296 Write_Line
("UTF-16 encoding format not recognized");
298 raise Unrecoverable_Error
;
300 when UTF32_LE | UTF32_BE
=>
302 Write_Line
("UTF-32 encoding format not recognized");
304 raise Unrecoverable_Error
;
314 -- Because of the License stuff above, Scng.Initialize_Scanner cannot
315 -- call Scan. Scan initial token (note this initializes Prev_Token,
318 -- There are two reasons not to do the Scan step in case if we
319 -- initialize the scanner for the internal source buffer:
321 -- - The artificial string may not be created by the compiler in this
322 -- buffer when we call Initialize_Scanner
324 -- - For these artificial strings a special way of scanning is used, so
325 -- the standard step of the scanner may just break the algorithm of
326 -- processing these strings.
328 if Index
/= Internal_Source_File
then
332 -- Clear flags for reserved words used as identifiers
334 for J
in Token_Type
loop
335 Used_As_Identifier
(J
) := False;
337 end Initialize_Scanner
;
343 procedure Post_Scan
is
344 procedure Check_Obsolescent_Features_Restriction
(S
: Source_Ptr
);
345 -- This checks for Obsolescent_Features restriction being active, and
346 -- if so, flags the restriction as occurring at the given scan location.
348 procedure Check_Obsolete_Base_Char
;
349 -- Check for numeric literal using ':' instead of '#' for based case
351 --------------------------------------------
352 -- Check_Obsolescent_Features_Restriction --
353 --------------------------------------------
355 procedure Check_Obsolescent_Features_Restriction
(S
: Source_Ptr
) is
357 -- Normally we have a node handy for posting restrictions. We don't
358 -- have such a node here, so construct a dummy one with the right
359 -- scan pointer. This is only used to get the Sloc value anyway.
361 Check_Restriction
(No_Obsolescent_Features
, New_Node
(N_Empty
, S
));
362 end Check_Obsolescent_Features_Restriction
;
364 ------------------------------
365 -- Check_Obsolete_Base_Char --
366 ------------------------------
368 procedure Check_Obsolete_Base_Char
is
372 if Based_Literal_Uses_Colon
then
374 -- Find the : for the restriction or warning message
377 while Source
(S
) /= ':' loop
381 Check_Obsolescent_Features_Restriction
(S
);
383 if Warn_On_Obsolescent_Feature
then
385 ("use of "":"" is an obsolescent feature (RM J.2(3))?", S
);
387 ("\use ""'#"" instead?", S
);
390 end Check_Obsolete_Base_Char
;
392 -- Start of processing for Post_Scan
396 when Tok_Char_Literal
=>
397 Token_Node
:= New_Node
(N_Character_Literal
, Token_Ptr
);
398 Set_Char_Literal_Value
(Token_Node
, UI_From_CC
(Character_Code
));
399 Set_Chars
(Token_Node
, Token_Name
);
401 when Tok_Identifier
=>
402 Token_Node
:= New_Node
(N_Identifier
, Token_Ptr
);
403 Set_Chars
(Token_Node
, Token_Name
);
405 when Tok_Real_Literal
=>
406 Token_Node
:= New_Node
(N_Real_Literal
, Token_Ptr
);
407 Set_Realval
(Token_Node
, Real_Literal_Value
);
408 Check_Obsolete_Base_Char
;
410 when Tok_Integer_Literal
=>
411 Token_Node
:= New_Node
(N_Integer_Literal
, Token_Ptr
);
412 Set_Intval
(Token_Node
, Int_Literal_Value
);
413 Check_Obsolete_Base_Char
;
415 when Tok_String_Literal
=>
416 Token_Node
:= New_Node
(N_String_Literal
, Token_Ptr
);
417 Set_Has_Wide_Character
418 (Token_Node
, Wide_Character_Found
);
419 Set_Has_Wide_Wide_Character
420 (Token_Node
, Wide_Wide_Character_Found
);
421 Set_Strval
(Token_Node
, String_Literal_Id
);
423 if Source
(Token_Ptr
) = '%' then
424 Check_Obsolescent_Features_Restriction
(Token_Ptr
);
426 if Warn_On_Obsolescent_Feature
then
428 ("use of ""'%"" is an obsolescent feature (RM J.2(4))?");
429 Error_Msg_SC
("\use """""" instead?");
433 when Tok_Operator_Symbol
=>
434 Token_Node
:= New_Node
(N_Operator_Symbol
, Token_Ptr
);
435 Set_Chars
(Token_Node
, Token_Name
);
436 Set_Strval
(Token_Node
, String_Literal_Id
);
438 when Tok_Vertical_Bar
=>
439 if Source
(Token_Ptr
) = '!' then
440 Check_Obsolescent_Features_Restriction
(Token_Ptr
);
442 if Warn_On_Obsolescent_Feature
then
444 ("use of ""'!"" is an obsolescent feature (RM J.2(2))?");
445 Error_Msg_SC
("\use ""'|"" instead?");
454 ------------------------------
455 -- Scan_Reserved_Identifier --
456 ------------------------------
458 procedure Scan_Reserved_Identifier
(Force_Msg
: Boolean) is
459 Token_Chars
: constant String := Token_Type
'Image (Token
);
462 -- We have in Token_Chars the image of the Token name, i.e. Tok_xxx.
463 -- This code extracts the xxx and makes an identifier out of it.
467 for J
in 5 .. Token_Chars
'Length loop
468 Name_Len
:= Name_Len
+ 1;
469 Name_Buffer
(Name_Len
) := Fold_Lower
(Token_Chars
(J
));
472 Token_Name
:= Name_Find
;
474 if not Used_As_Identifier
(Token
) or else Force_Msg
then
476 -- If "some" is made into a reserved work in Ada2012, the following
477 -- check will make it into a regular identifier in earlier versions
480 if Token
= Tok_Some
and then Ada_Version
< Ada_2012
then
483 Error_Msg_Name_1
:= Token_Name
;
484 Error_Msg_SC
("reserved word* cannot be used as identifier!");
485 Used_As_Identifier
(Token
) := True;
489 Token
:= Tok_Identifier
;
490 Token_Node
:= New_Node
(N_Identifier
, Token_Ptr
);
491 Set_Chars
(Token_Node
, Token_Name
);
492 end Scan_Reserved_Identifier
;