1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S C N -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- 10-- -- 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. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Csets; use Csets; 28with Hostparm; use Hostparm; 29with Namet; use Namet; 30with Opt; use Opt; 31with Restrict; use Restrict; 32with Rident; use Rident; 33with Scans; use Scans; 34with Sinfo; use Sinfo; 35with Sinput; use Sinput; 36with Uintp; use Uintp; 37 38package body Scn is 39 40 use ASCII; 41 42 Used_As_Identifier : array (Token_Type) of Boolean; 43 -- Flags set True if a given keyword is used as an identifier (used to 44 -- make sure that we only post an error message for incorrect use of a 45 -- keyword as an identifier once for a given keyword). 46 47 procedure Check_End_Of_Line; 48 -- Called when end of line encountered. Checks that line is not too long, 49 -- and that other style checks for the end of line are met. 50 51 function Determine_License return License_Type; 52 -- Scan header of file and check that it has an appropriate GNAT-style 53 -- header with a proper license statement. Returns GPL, Unrestricted, 54 -- or Modified_GPL depending on header. If none of these, returns Unknown. 55 56 procedure Error_Long_Line; 57 -- Signal error of excessively long line 58 59 ----------------------- 60 -- Check_End_Of_Line -- 61 ----------------------- 62 63 procedure Check_End_Of_Line is 64 Len : constant Int := Int (Scan_Ptr) - Int (Current_Line_Start); 65 begin 66 if Style_Check then 67 Style.Check_Line_Terminator (Len); 68 elsif Len > Max_Line_Length then 69 Error_Long_Line; 70 end if; 71 end Check_End_Of_Line; 72 73 ----------------------- 74 -- Determine_License -- 75 ----------------------- 76 77 function Determine_License return License_Type is 78 GPL_Found : Boolean := False; 79 Result : License_Type; 80 81 function Contains (S : String) return Boolean; 82 -- See if current comment contains successive non-blank characters 83 -- matching the contents of S. If so leave Scan_Ptr unchanged and 84 -- return True, otherwise leave Scan_Ptr unchanged and return False. 85 86 procedure Skip_EOL; 87 -- Skip to line terminator character 88 89 -------------- 90 -- Contains -- 91 -------------- 92 93 function Contains (S : String) return Boolean is 94 CP : Natural; 95 SP : Source_Ptr; 96 SS : Source_Ptr; 97 98 begin 99 -- Loop to check characters. This loop is terminated by end of 100 -- line, and also we need to check for the EOF case, to take 101 -- care of files containing only comments. 102 103 SP := Scan_Ptr; 104 while Source (SP) /= CR and then 105 Source (SP) /= LF and then 106 Source (SP) /= EOF 107 loop 108 if Source (SP) = S (S'First) then 109 SS := SP; 110 CP := S'First; 111 112 loop 113 SS := SS + 1; 114 CP := CP + 1; 115 116 if CP > S'Last then 117 return True; 118 end if; 119 120 while Source (SS) = ' ' loop 121 SS := SS + 1; 122 end loop; 123 124 exit when Source (SS) /= S (CP); 125 end loop; 126 end if; 127 128 SP := SP + 1; 129 end loop; 130 131 return False; 132 end Contains; 133 134 -------------- 135 -- Skip_EOL -- 136 -------------- 137 138 procedure Skip_EOL is 139 begin 140 while Source (Scan_Ptr) /= CR 141 and then Source (Scan_Ptr) /= LF 142 and then Source (Scan_Ptr) /= EOF 143 loop 144 Scan_Ptr := Scan_Ptr + 1; 145 end loop; 146 end Skip_EOL; 147 148 -- Start of processing for Determine_License 149 150 begin 151 loop 152 if Source (Scan_Ptr) /= '-' 153 or else Source (Scan_Ptr + 1) /= '-' 154 then 155 if GPL_Found then 156 Result := GPL; 157 exit; 158 else 159 Result := Unknown; 160 exit; 161 end if; 162 163 elsif Contains ("Asaspecialexception") then 164 if GPL_Found then 165 Result := Modified_GPL; 166 exit; 167 end if; 168 169 elsif Contains ("GNUGeneralPublicLicense") then 170 GPL_Found := True; 171 172 elsif 173 Contains 174 ("ThisspecificationisadaptedfromtheAdaSemanticInterface") 175 or else 176 Contains 177 ("ThisspecificationisderivedfromtheAdaReferenceManual") 178 then 179 Result := Unrestricted; 180 exit; 181 end if; 182 183 Skip_EOL; 184 185 Check_End_Of_Line; 186 187 if Source (Scan_Ptr) /= EOF then 188 189 -- We have to take into account a degenerate case when the source 190 -- file contains only comments and no Ada code. 191 192 declare 193 Physical : Boolean; 194 195 begin 196 Skip_Line_Terminators (Scan_Ptr, Physical); 197 198 -- If we are at start of physical line, update scan pointers 199 -- to reflect the start of the new line. 200 201 if Physical then 202 Current_Line_Start := Scan_Ptr; 203 Start_Column := Scanner.Set_Start_Column; 204 First_Non_Blank_Location := Scan_Ptr; 205 end if; 206 end; 207 end if; 208 end loop; 209 210 return Result; 211 end Determine_License; 212 213 ---------------------------- 214 -- Determine_Token_Casing -- 215 ---------------------------- 216 217 function Determine_Token_Casing return Casing_Type is 218 begin 219 return Scanner.Determine_Token_Casing; 220 end Determine_Token_Casing; 221 222 --------------------- 223 -- Error_Long_Line -- 224 --------------------- 225 226 procedure Error_Long_Line is 227 begin 228 Error_Msg 229 ("this line is too long", 230 Current_Line_Start + Source_Ptr (Max_Line_Length)); 231 end Error_Long_Line; 232 233 ------------------------ 234 -- Initialize_Scanner -- 235 ------------------------ 236 237 procedure Initialize_Scanner 238 (Unit : Unit_Number_Type; 239 Index : Source_File_Index) 240 is 241 GNAT_Hedr : constant Text_Buffer (1 .. 78) := (others => '-'); 242 243 begin 244 Scanner.Initialize_Scanner (Index); 245 246 if Index /= Internal_Source_File then 247 Set_Unit (Index, Unit); 248 end if; 249 250 Current_Source_Unit := Unit; 251 252 -- Set default for Comes_From_Source (except if we are going to process 253 -- an artificial string internally created within the compiler and 254 -- placed into internal source duffer). All nodes built now until we 255 -- reenter the analyzer will have Comes_From_Source set to True 256 257 if Index /= Internal_Source_File then 258 Set_Comes_From_Source_Default (True); 259 end if; 260 261 -- Check license if GNAT type header possibly present 262 263 if Source_Last (Index) - Scan_Ptr > 80 264 and then Source (Scan_Ptr .. Scan_Ptr + 77) = GNAT_Hedr 265 then 266 Set_License (Current_Source_File, Determine_License); 267 end if; 268 269 Check_For_BOM; 270 271 -- Because of the License stuff above, Scng.Initialize_Scanner cannot 272 -- call Scan. Scan initial token (note this initializes Prev_Token, 273 -- Prev_Token_Ptr). 274 275 -- There are two reasons not to do the Scan step in case if we 276 -- initialize the scanner for the internal source buffer: 277 278 -- - The artificial string may not be created by the compiler in this 279 -- buffer when we call Initialize_Scanner 280 281 -- - For these artificial strings a special way of scanning is used, so 282 -- the standard step of the scanner may just break the algorithm of 283 -- processing these strings. 284 285 if Index /= Internal_Source_File then 286 Scan; 287 end if; 288 289 -- Clear flags for reserved words used as identifiers 290 291 for J in Token_Type loop 292 Used_As_Identifier (J) := False; 293 end loop; 294 end Initialize_Scanner; 295 296 --------------- 297 -- Post_Scan -- 298 --------------- 299 300 procedure Post_Scan is 301 procedure Check_Obsolescent_Features_Restriction (S : Source_Ptr); 302 -- This checks for Obsolescent_Features restriction being active, and 303 -- if so, flags the restriction as occurring at the given scan location. 304 305 procedure Check_Obsolete_Base_Char; 306 -- Check for numeric literal using ':' instead of '#' for based case 307 308 -------------------------------------------- 309 -- Check_Obsolescent_Features_Restriction -- 310 -------------------------------------------- 311 312 procedure Check_Obsolescent_Features_Restriction (S : Source_Ptr) is 313 begin 314 -- Normally we have a node handy for posting restrictions. We don't 315 -- have such a node here, so construct a dummy one with the right 316 -- scan pointer. This is only used to get the Sloc value anyway. 317 318 Check_Restriction (No_Obsolescent_Features, New_Node (N_Empty, S)); 319 end Check_Obsolescent_Features_Restriction; 320 321 ------------------------------ 322 -- Check_Obsolete_Base_Char -- 323 ------------------------------ 324 325 procedure Check_Obsolete_Base_Char is 326 S : Source_Ptr; 327 328 begin 329 if Based_Literal_Uses_Colon then 330 331 -- Find the : for the restriction or warning message 332 333 S := Token_Ptr; 334 while Source (S) /= ':' loop 335 S := S + 1; 336 end loop; 337 338 Check_Obsolescent_Features_Restriction (S); 339 340 if Warn_On_Obsolescent_Feature then 341 Error_Msg 342 ("?j?use of "":"" is an obsolescent feature (RM J.2(3))", S); 343 Error_Msg 344 ("\?j?use ""'#"" instead", S); 345 end if; 346 end if; 347 end Check_Obsolete_Base_Char; 348 349 -- Start of processing for Post_Scan 350 351 begin 352 case Token is 353 when Tok_Char_Literal => 354 Token_Node := New_Node (N_Character_Literal, Token_Ptr); 355 Set_Char_Literal_Value (Token_Node, UI_From_CC (Character_Code)); 356 Set_Chars (Token_Node, Token_Name); 357 358 when Tok_Identifier => 359 Token_Node := New_Node (N_Identifier, Token_Ptr); 360 Set_Chars (Token_Node, Token_Name); 361 362 when Tok_Real_Literal => 363 Token_Node := New_Node (N_Real_Literal, Token_Ptr); 364 Set_Realval (Token_Node, Real_Literal_Value); 365 Check_Obsolete_Base_Char; 366 367 when Tok_Integer_Literal => 368 Token_Node := New_Node (N_Integer_Literal, Token_Ptr); 369 Set_Intval (Token_Node, Int_Literal_Value); 370 Check_Obsolete_Base_Char; 371 372 when Tok_String_Literal => 373 Token_Node := New_Node (N_String_Literal, Token_Ptr); 374 Set_Has_Wide_Character 375 (Token_Node, Wide_Character_Found); 376 Set_Has_Wide_Wide_Character 377 (Token_Node, Wide_Wide_Character_Found); 378 Set_Strval (Token_Node, String_Literal_Id); 379 380 if Source (Token_Ptr) = '%' then 381 Check_Obsolescent_Features_Restriction (Token_Ptr); 382 383 if Warn_On_Obsolescent_Feature then 384 Error_Msg_SC 385 ("?j?use of ""'%"" is an obsolescent feature (RM J.2(4))"); 386 Error_Msg_SC ("\?j?use """""" instead"); 387 end if; 388 end if; 389 390 when Tok_Operator_Symbol => 391 Token_Node := New_Node (N_Operator_Symbol, Token_Ptr); 392 Set_Chars (Token_Node, Token_Name); 393 Set_Strval (Token_Node, String_Literal_Id); 394 395 when Tok_Vertical_Bar => 396 if Source (Token_Ptr) = '!' then 397 Check_Obsolescent_Features_Restriction (Token_Ptr); 398 399 if Warn_On_Obsolescent_Feature then 400 Error_Msg_SC 401 ("?j?use of ""'!"" is an obsolescent feature (RM J.2(2))"); 402 Error_Msg_SC ("\?j?use ""'|"" instead"); 403 end if; 404 end if; 405 406 when others => 407 null; 408 end case; 409 end Post_Scan; 410 411 ------------------------------ 412 -- Scan_Reserved_Identifier -- 413 ------------------------------ 414 415 procedure Scan_Reserved_Identifier (Force_Msg : Boolean) is 416 Token_Chars : constant String := Token_Type'Image (Token); 417 418 begin 419 -- We have in Token_Chars the image of the Token name, i.e. Tok_xxx. 420 -- This code extracts the xxx and makes an identifier out of it. 421 422 Name_Len := 0; 423 424 for J in 5 .. Token_Chars'Length loop 425 Name_Len := Name_Len + 1; 426 Name_Buffer (Name_Len) := Fold_Lower (Token_Chars (J)); 427 end loop; 428 429 Token_Name := Name_Find; 430 431 if not Used_As_Identifier (Token) or else Force_Msg then 432 Error_Msg_Name_1 := Token_Name; 433 Error_Msg_SC ("reserved word* cannot be used as identifier!"); 434 Used_As_Identifier (Token) := True; 435 end if; 436 437 Token := Tok_Identifier; 438 Token_Node := New_Node (N_Identifier, Token_Ptr); 439 Set_Chars (Token_Node, Token_Name); 440 end Scan_Reserved_Identifier; 441 442end Scn; 443