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
64 procedure Post_Scan
is
67 when Tok_Char_Literal
=>
68 Token_Node
:= New_Node
(N_Character_Literal
, Token_Ptr
);
69 Set_Char_Literal_Value
(Token_Node
, UI_From_CC
(Character_Code
));
70 Set_Chars
(Token_Node
, Token_Name
);
72 when Tok_Identifier
=>
73 Token_Node
:= New_Node
(N_Identifier
, Token_Ptr
);
74 Set_Chars
(Token_Node
, Token_Name
);
76 when Tok_Real_Literal
=>
77 Token_Node
:= New_Node
(N_Real_Literal
, Token_Ptr
);
78 Set_Realval
(Token_Node
, Real_Literal_Value
);
80 when Tok_Integer_Literal
=>
81 Token_Node
:= New_Node
(N_Integer_Literal
, Token_Ptr
);
82 Set_Intval
(Token_Node
, Int_Literal_Value
);
84 when Tok_String_Literal
=>
85 Token_Node
:= New_Node
(N_String_Literal
, Token_Ptr
);
86 Set_Has_Wide_Character
(Token_Node
, Wide_Character_Found
);
87 Set_Strval
(Token_Node
, String_Literal_Id
);
89 when Tok_Operator_Symbol
=>
90 Token_Node
:= New_Node
(N_Operator_Symbol
, Token_Ptr
);
91 Set_Chars
(Token_Node
, Token_Name
);
92 Set_Strval
(Token_Node
, String_Literal_Id
);
99 -----------------------
100 -- Check_End_Of_Line --
101 -----------------------
103 procedure Check_End_Of_Line
is
104 Len
: constant Int
:= Int
(Scan_Ptr
) - Int
(Current_Line_Start
);
107 Style
.Check_Line_Terminator
(Len
);
108 elsif Len
> Max_Line_Length
then
111 end Check_End_Of_Line
;
113 -----------------------
114 -- Determine_License --
115 -----------------------
117 function Determine_License
return License_Type
is
118 GPL_Found
: Boolean := False;
119 Result
: License_Type
;
121 function Contains
(S
: String) return Boolean;
122 -- See if current comment contains successive non-blank characters
123 -- matching the contents of S. If so leave Scan_Ptr unchanged and
124 -- return True, otherwise leave Scan_Ptr unchanged and return False.
127 -- Skip to line terminator character
133 function Contains
(S
: String) return Boolean is
139 -- Loop to check characters. This loop is terminated by end of
140 -- line, and also we need to check for the EOF case, to take
141 -- care of files containing only comments.
144 while Source
(SP
) /= CR
and then
145 Source
(SP
) /= LF
and then
148 if Source
(SP
) = S
(S
'First) then
160 while Source
(SS
) = ' ' loop
164 exit when Source
(SS
) /= S
(CP
);
178 procedure Skip_EOL
is
180 while Source
(Scan_Ptr
) /= CR
181 and then Source
(Scan_Ptr
) /= LF
182 and then Source
(Scan_Ptr
) /= EOF
184 Scan_Ptr
:= Scan_Ptr
+ 1;
188 -- Start of processing for Determine_License
192 if Source
(Scan_Ptr
) /= '-'
193 or else Source
(Scan_Ptr
+ 1) /= '-'
203 elsif Contains
("Asaspecialexception") then
205 Result
:= Modified_GPL
;
209 elsif Contains
("GNUGeneralPublicLicense") then
214 ("ThisspecificationisadaptedfromtheAdaSemanticInterface")
217 ("ThisspecificationisderivedfromtheAdaReferenceManual")
219 Result
:= Unrestricted
;
227 if Source
(Scan_Ptr
) /= EOF
then
229 -- We have to take into account a degenerate case when the source
230 -- file contains only comments and no Ada code.
236 Skip_Line_Terminators
(Scan_Ptr
, Physical
);
238 -- If we are at start of physical line, update scan pointers
239 -- to reflect the start of the new line.
242 Current_Line_Start
:= Scan_Ptr
;
243 Start_Column
:= Scanner
.Set_Start_Column
;
244 First_Non_Blank_Location
:= Scan_Ptr
;
251 end Determine_License
;
253 ----------------------------
254 -- Determine_Token_Casing --
255 ----------------------------
257 function Determine_Token_Casing
return Casing_Type
is
259 return Scanner
.Determine_Token_Casing
;
260 end Determine_Token_Casing
;
262 ---------------------
263 -- Error_Long_Line --
264 ---------------------
266 procedure Error_Long_Line
is
269 ("this line is too long",
270 Current_Line_Start
+ Source_Ptr
(Max_Line_Length
));
273 ------------------------
274 -- Initialize_Scanner --
275 ------------------------
277 procedure Initialize_Scanner
278 (Unit
: Unit_Number_Type
;
279 Index
: Source_File_Index
)
281 GNAT_Hedr
: constant Text_Buffer
(1 .. 78) := (others => '-');
284 Scanner
.Initialize_Scanner
(Index
);
286 if Index
/= Internal_Source_File
then
287 Set_Unit
(Index
, Unit
);
290 Current_Source_Unit
:= Unit
;
292 -- Set default for Comes_From_Source (except if we are going to process
293 -- an artificial string internally created within the compiler and
294 -- placed into internal source duffer). All nodes built now until we
295 -- reenter the analyzer will have Comes_From_Source set to True
297 if Index
/= Internal_Source_File
then
298 Set_Comes_From_Source_Default
(True);
301 -- Check license if GNAT type header possibly present
303 if Source_Last
(Index
) - Scan_Ptr
> 80
304 and then Source
(Scan_Ptr
.. Scan_Ptr
+ 77) = GNAT_Hedr
306 Set_License
(Current_Source_File
, Determine_License
);
309 -- Because of the License stuff above, Scng.Initialize_Scanner cannot
310 -- call Scan. Scan initial token (note this initializes Prev_Token,
313 -- There are two reasons not to do the Scan step in case if we
314 -- initialize the scanner for the internal source buffer:
316 -- - The artificial string may not be created by the compiler in this
317 -- buffer when we call Initialize_Scanner
319 -- - For these artificial strings a special way of scanning is used, so
320 -- the standard step of the scanner may just break the algorithm of
321 -- processing these strings.
323 if Index
/= Internal_Source_File
then
327 -- Clear flags for reserved words used as indentifiers
329 for J
in Token_Type
loop
330 Used_As_Identifier
(J
) := False;
332 end Initialize_Scanner
;
334 -----------------------
335 -- Obsolescent_Check --
336 -----------------------
338 procedure Obsolescent_Check
(S
: Source_Ptr
) is
340 -- This is a pain in the neck case, since we normally need a node to
341 -- call Check_Restrictions, and all we have is a source pointer. The
342 -- easiest thing is to construct a dummy node. A bit kludgy, but this
343 -- is a marginal case. It's not worth trying to do things more cleanly.
345 Check_Restriction
(No_Obsolescent_Features
, New_Node
(N_Empty
, S
));
346 end Obsolescent_Check
;
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
;