1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Csets
; use Csets
;
29 with Hostparm
; use Hostparm
;
30 with Namet
; use Namet
;
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
;
43 Used_As_Identifier
: array (Token_Type
) of Boolean;
44 -- Flags set True if a given keyword is used as an identifier (used to
45 -- make sure that we only post an error message for incorrect use of a
46 -- keyword as an identifier once for a given keyword).
48 procedure Check_End_Of_Line
;
49 -- Called when end of line encountered. Checks that line is not too long,
50 -- and that other style checks for the end of line are met.
52 function Determine_License
return License_Type
;
53 -- Scan header of file and check that it has an appropriate GNAT-style
54 -- header with a proper license statement. Returns GPL, Unrestricted,
55 -- or Modified_GPL depending on header. If none of these, returns Unknown.
57 procedure Error_Long_Line
;
58 -- Signal error of excessively long line
60 -----------------------
61 -- Check_End_Of_Line --
62 -----------------------
64 procedure Check_End_Of_Line
is
65 Len
: constant Int
:= Int
(Scan_Ptr
) - Int
(Current_Line_Start
);
68 Style
.Check_Line_Terminator
(Len
);
69 elsif Len
> Max_Line_Length
then
72 end Check_End_Of_Line
;
74 -----------------------
75 -- Determine_License --
76 -----------------------
78 function Determine_License
return License_Type
is
79 GPL_Found
: Boolean := False;
80 Result
: License_Type
;
82 function Contains
(S
: String) return Boolean;
83 -- See if current comment contains successive non-blank characters
84 -- matching the contents of S. If so leave Scan_Ptr unchanged and
85 -- return True, otherwise leave Scan_Ptr unchanged and return False.
88 -- Skip to line terminator character
94 function Contains
(S
: String) return Boolean is
100 -- Loop to check characters. This loop is terminated by end of
101 -- line, and also we need to check for the EOF case, to take
102 -- care of files containing only comments.
105 while Source
(SP
) /= CR
and then
106 Source
(SP
) /= LF
and then
109 if Source
(SP
) = S
(S
'First) then
121 while Source
(SS
) = ' ' loop
125 exit when Source
(SS
) /= S
(CP
);
139 procedure Skip_EOL
is
141 while Source
(Scan_Ptr
) /= CR
142 and then Source
(Scan_Ptr
) /= LF
143 and then Source
(Scan_Ptr
) /= EOF
145 Scan_Ptr
:= Scan_Ptr
+ 1;
149 -- Start of processing for Determine_License
153 if Source
(Scan_Ptr
) /= '-'
154 or else Source
(Scan_Ptr
+ 1) /= '-'
164 elsif Contains
("Asaspecialexception") then
166 Result
:= Modified_GPL
;
170 elsif Contains
("GNUGeneralPublicLicense") then
175 ("ThisspecificationisadaptedfromtheAdaSemanticInterface")
178 ("ThisspecificationisderivedfromtheAdaReferenceManual")
180 Result
:= Unrestricted
;
188 if Source
(Scan_Ptr
) /= EOF
then
190 -- We have to take into account a degenerate case when the source
191 -- file contains only comments and no Ada code.
197 Skip_Line_Terminators
(Scan_Ptr
, Physical
);
199 -- If we are at start of physical line, update scan pointers
200 -- to reflect the start of the new line.
203 Current_Line_Start
:= Scan_Ptr
;
204 Start_Column
:= Scanner
.Set_Start_Column
;
205 First_Non_Blank_Location
:= Scan_Ptr
;
212 end Determine_License
;
214 ----------------------------
215 -- Determine_Token_Casing --
216 ----------------------------
218 function Determine_Token_Casing
return Casing_Type
is
220 return Scanner
.Determine_Token_Casing
;
221 end Determine_Token_Casing
;
223 ---------------------
224 -- Error_Long_Line --
225 ---------------------
227 procedure Error_Long_Line
is
230 ("this line is too long",
231 Current_Line_Start
+ Source_Ptr
(Max_Line_Length
));
234 ------------------------
235 -- Initialize_Scanner --
236 ------------------------
238 procedure Initialize_Scanner
239 (Unit
: Unit_Number_Type
;
240 Index
: Source_File_Index
)
242 GNAT_Hedr
: constant Text_Buffer
(1 .. 78) := (others => '-');
245 Scanner
.Initialize_Scanner
(Index
);
247 if Index
/= Internal_Source_File
then
248 Set_Unit
(Index
, Unit
);
251 Current_Source_Unit
:= Unit
;
253 -- Set default for Comes_From_Source (except if we are going to process
254 -- an artificial string internally created within the compiler and
255 -- placed into internal source duffer). All nodes built now until we
256 -- reenter the analyzer will have Comes_From_Source set to True
258 if Index
/= Internal_Source_File
then
259 Set_Comes_From_Source_Default
(True);
262 -- Check license if GNAT type header possibly present
264 if Source_Last
(Index
) - Scan_Ptr
> 80
265 and then Source
(Scan_Ptr
.. Scan_Ptr
+ 77) = GNAT_Hedr
267 Set_License
(Current_Source_File
, Determine_License
);
270 -- Because of the License stuff above, Scng.Initialize_Scanner cannot
271 -- call Scan. Scan initial token (note this initializes Prev_Token,
274 -- There are two reasons not to do the Scan step in case if we
275 -- initialize the scanner for the internal source buffer:
277 -- - The artificial string may not be created by the compiler in this
278 -- buffer when we call Initialize_Scanner
280 -- - For these artificial strings a special way of scanning is used, so
281 -- the standard step of the scanner may just break the algorithm of
282 -- processing these strings.
284 if Index
/= Internal_Source_File
then
288 -- Clear flags for reserved words used as indentifiers
290 for J
in Token_Type
loop
291 Used_As_Identifier
(J
) := False;
293 end Initialize_Scanner
;
295 -----------------------
296 -- Obsolescent_Check --
297 -----------------------
299 procedure Obsolescent_Check
(S
: Source_Ptr
) is
301 -- This is a pain in the neck case, since we normally need a node to
302 -- call Check_Restrictions, and all we have is a source pointer. The
303 -- easiest thing is to construct a dummy node. A bit kludgy, but this
304 -- is a marginal case. It's not worth trying to do things more cleanly.
306 Check_Restriction
(No_Obsolescent_Features
, New_Node
(N_Empty
, S
));
307 end Obsolescent_Check
;
313 procedure Post_Scan
is
316 when Tok_Char_Literal
=>
317 Token_Node
:= New_Node
(N_Character_Literal
, Token_Ptr
);
318 Set_Char_Literal_Value
(Token_Node
, UI_From_CC
(Character_Code
));
319 Set_Chars
(Token_Node
, Token_Name
);
321 when Tok_Identifier
=>
322 Token_Node
:= New_Node
(N_Identifier
, Token_Ptr
);
323 Set_Chars
(Token_Node
, Token_Name
);
325 when Tok_Real_Literal
=>
326 Token_Node
:= New_Node
(N_Real_Literal
, Token_Ptr
);
327 Set_Realval
(Token_Node
, Real_Literal_Value
);
329 when Tok_Integer_Literal
=>
330 Token_Node
:= New_Node
(N_Integer_Literal
, Token_Ptr
);
331 Set_Intval
(Token_Node
, Int_Literal_Value
);
333 when Tok_String_Literal
=>
334 Token_Node
:= New_Node
(N_String_Literal
, Token_Ptr
);
335 Set_Has_Wide_Character
(Token_Node
, Wide_Character_Found
);
336 Set_Strval
(Token_Node
, String_Literal_Id
);
338 when Tok_Operator_Symbol
=>
339 Token_Node
:= New_Node
(N_Operator_Symbol
, Token_Ptr
);
340 Set_Chars
(Token_Node
, Token_Name
);
341 Set_Strval
(Token_Node
, String_Literal_Id
);
348 ------------------------------
349 -- Scan_Reserved_Identifier --
350 ------------------------------
352 procedure Scan_Reserved_Identifier
(Force_Msg
: Boolean) is
353 Token_Chars
: constant String := Token_Type
'Image (Token
);
356 -- We have in Token_Chars the image of the Token name, i.e. Tok_xxx.
357 -- This code extracts the xxx and makes an identifier out of it.
361 for J
in 5 .. Token_Chars
'Length loop
362 Name_Len
:= Name_Len
+ 1;
363 Name_Buffer
(Name_Len
) := Fold_Lower
(Token_Chars
(J
));
366 Token_Name
:= Name_Find
;
368 if not Used_As_Identifier
(Token
) or else Force_Msg
then
369 Error_Msg_Name_1
:= Token_Name
;
370 Error_Msg_SC
("reserved word* cannot be used as identifier!");
371 Used_As_Identifier
(Token
) := True;
374 Token
:= Tok_Identifier
;
375 Token_Node
:= New_Node
(N_Identifier
, Token_Ptr
);
376 Set_Chars
(Token_Node
, Token_Name
);
377 end Scan_Reserved_Identifier
;