1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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
;
339 -----------------------
340 -- Obsolescent_Check --
341 -----------------------
343 procedure Obsolescent_Check
(S
: Source_Ptr
) is
345 -- This is a pain in the neck case, since we normally need a node to
346 -- call Check_Restrictions, and all we have is a source pointer. The
347 -- easiest thing is to construct a dummy node. A bit kludgy, but this
348 -- is a marginal case. It's not worth trying to do things more cleanly.
350 Check_Restriction
(No_Obsolescent_Features
, New_Node
(N_Empty
, S
));
351 end Obsolescent_Check
;
357 procedure Post_Scan
is
360 when Tok_Char_Literal
=>
361 Token_Node
:= New_Node
(N_Character_Literal
, Token_Ptr
);
362 Set_Char_Literal_Value
(Token_Node
, UI_From_CC
(Character_Code
));
363 Set_Chars
(Token_Node
, Token_Name
);
365 when Tok_Identifier
=>
366 Token_Node
:= New_Node
(N_Identifier
, Token_Ptr
);
367 Set_Chars
(Token_Node
, Token_Name
);
369 when Tok_Real_Literal
=>
370 Token_Node
:= New_Node
(N_Real_Literal
, Token_Ptr
);
371 Set_Realval
(Token_Node
, Real_Literal_Value
);
373 when Tok_Integer_Literal
=>
374 Token_Node
:= New_Node
(N_Integer_Literal
, Token_Ptr
);
375 Set_Intval
(Token_Node
, Int_Literal_Value
);
377 when Tok_String_Literal
=>
378 Token_Node
:= New_Node
(N_String_Literal
, Token_Ptr
);
379 Set_Has_Wide_Character
(Token_Node
, Wide_Character_Found
);
380 Set_Strval
(Token_Node
, String_Literal_Id
);
382 when Tok_Operator_Symbol
=>
383 Token_Node
:= New_Node
(N_Operator_Symbol
, Token_Ptr
);
384 Set_Chars
(Token_Node
, Token_Name
);
385 Set_Strval
(Token_Node
, String_Literal_Id
);
392 ------------------------------
393 -- Scan_Reserved_Identifier --
394 ------------------------------
396 procedure Scan_Reserved_Identifier
(Force_Msg
: Boolean) is
397 Token_Chars
: constant String := Token_Type
'Image (Token
);
400 -- We have in Token_Chars the image of the Token name, i.e. Tok_xxx.
401 -- This code extracts the xxx and makes an identifier out of it.
405 for J
in 5 .. Token_Chars
'Length loop
406 Name_Len
:= Name_Len
+ 1;
407 Name_Buffer
(Name_Len
) := Fold_Lower
(Token_Chars
(J
));
410 Token_Name
:= Name_Find
;
412 if not Used_As_Identifier
(Token
) or else Force_Msg
then
413 Error_Msg_Name_1
:= Token_Name
;
414 Error_Msg_SC
("reserved word* cannot be used as identifier!");
415 Used_As_Identifier
(Token
) := True;
418 Token
:= Tok_Identifier
;
419 Token_Node
:= New_Node
(N_Identifier
, Token_Ptr
);
420 Set_Chars
(Token_Node
, Token_Name
);
421 end Scan_Reserved_Identifier
;