1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P A R . U T I L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2003, 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 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, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Csets; use Csets; 28with Uintp; use Uintp; 29 30with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; 31 32separate (Par) 33package body Util is 34 35 --------------------- 36 -- Bad_Spelling_Of -- 37 --------------------- 38 39 function Bad_Spelling_Of (T : Token_Type) return Boolean is 40 Tname : constant String := Token_Type'Image (T); 41 -- Characters of token name 42 43 S : String (1 .. Tname'Last - 4); 44 -- Characters of token name folded to lower case, omitting TOK_ at start 45 46 M1 : String (1 .. 42) := "incorrect spelling of keyword ************"; 47 M2 : String (1 .. 44) := "illegal abbreviation of keyword ************"; 48 -- Buffers used to construct error message 49 50 P1 : constant := 30; 51 P2 : constant := 32; 52 -- Starting subscripts in M1, M2 for keyword name 53 54 SL : constant Natural := S'Length; 55 -- Length of expected token name excluding TOK_ at start 56 57 begin 58 if Token /= Tok_Identifier then 59 return False; 60 end if; 61 62 for J in S'Range loop 63 S (J) := Fold_Lower (Tname (Integer (J) + 4)); 64 end loop; 65 66 Get_Name_String (Token_Name); 67 68 -- A special check for case of PROGRAM used for PROCEDURE 69 70 if T = Tok_Procedure 71 and then Name_Len = 7 72 and then Name_Buffer (1 .. 7) = "program" 73 then 74 Error_Msg_SC ("PROCEDURE expected"); 75 Token := T; 76 return True; 77 78 -- A special check for an illegal abbrevation 79 80 elsif Name_Len < S'Length 81 and then Name_Len >= 4 82 and then Name_Buffer (1 .. Name_Len) = S (1 .. Name_Len) 83 then 84 for J in 1 .. S'Last loop 85 M2 (P2 + J - 1) := Fold_Upper (S (J)); 86 end loop; 87 88 Error_Msg_SC (M2 (1 .. P2 - 1 + S'Last)); 89 Token := T; 90 return True; 91 end if; 92 93 -- Now we go into the full circuit to check for a misspelling 94 95 -- Never consider something a misspelling if either the actual or 96 -- expected string is less than 3 characters (before this check we 97 -- used to consider i to be a misspelled if in some cases!) 98 99 if SL < 3 or else Name_Len < 3 then 100 return False; 101 102 -- Special case: prefix matches, i.e. the leading characters of the 103 -- token that we have exactly match the required keyword. If there 104 -- are at least two characters left over, assume that we have a case 105 -- of two keywords joined together which should not be joined. 106 107 elsif Name_Len > SL + 1 108 and then S = Name_Buffer (1 .. SL) 109 then 110 Scan_Ptr := Token_Ptr + S'Length; 111 Error_Msg_S ("missing space"); 112 Token := T; 113 return True; 114 end if; 115 116 if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then 117 118 for J in 1 .. S'Last loop 119 M1 (P1 + J - 1) := Fold_Upper (S (J)); 120 end loop; 121 122 Error_Msg_SC (M1 (1 .. P1 - 1 + S'Last)); 123 Token := T; 124 return True; 125 126 else 127 return False; 128 end if; 129 130 end Bad_Spelling_Of; 131 132 ---------------------- 133 -- Check_95_Keyword -- 134 ---------------------- 135 136 -- On entry, the caller has checked that current token is an identifier 137 -- whose name matches the name of the 95 keyword New_Tok. 138 139 procedure Check_95_Keyword (Token_95, Next : Token_Type) is 140 Scan_State : Saved_Scan_State; 141 142 begin 143 Save_Scan_State (Scan_State); -- at identifier/keyword 144 Scan; -- past identifier/keyword 145 146 if Token = Next then 147 Restore_Scan_State (Scan_State); -- to identifier 148 Error_Msg_Name_1 := Token_Name; 149 Error_Msg_SC ("(Ada 83) keyword* cannot be used!"); 150 Token := Token_95; 151 else 152 Restore_Scan_State (Scan_State); -- to identifier 153 end if; 154 end Check_95_Keyword; 155 156 ---------------------- 157 -- Check_Bad_Layout -- 158 ---------------------- 159 160 procedure Check_Bad_Layout is 161 begin 162 if Style.RM_Column_Check and then Token_Is_At_Start_Of_Line 163 and then Start_Column <= Scope.Table (Scope.Last).Ecol 164 then 165 Error_Msg_BC ("(style) incorrect layout"); 166 end if; 167 end Check_Bad_Layout; 168 169 -------------------------- 170 -- Check_Misspelling_Of -- 171 -------------------------- 172 173 procedure Check_Misspelling_Of (T : Token_Type) is 174 begin 175 if Bad_Spelling_Of (T) then 176 null; 177 end if; 178 end Check_Misspelling_Of; 179 180 ----------------------------- 181 -- Check_Simple_Expression -- 182 ----------------------------- 183 184 procedure Check_Simple_Expression (E : Node_Id) is 185 begin 186 if Expr_Form = EF_Non_Simple then 187 Error_Msg_N ("this expression must be parenthesized", E); 188 end if; 189 end Check_Simple_Expression; 190 191 --------------------------------------- 192 -- Check_Simple_Expression_In_Ada_83 -- 193 --------------------------------------- 194 195 procedure Check_Simple_Expression_In_Ada_83 (E : Node_Id) is 196 begin 197 if Expr_Form = EF_Non_Simple then 198 if Ada_83 then 199 Error_Msg_N ("(Ada 83) this expression must be parenthesized!", E); 200 end if; 201 end if; 202 end Check_Simple_Expression_In_Ada_83; 203 204 ------------------------ 205 -- Check_Subtype_Mark -- 206 ------------------------ 207 208 function Check_Subtype_Mark (Mark : Node_Id) return Node_Id is 209 begin 210 if Nkind (Mark) = N_Identifier 211 or else Nkind (Mark) = N_Selected_Component 212 or else (Nkind (Mark) = N_Attribute_Reference 213 and then Is_Type_Attribute_Name (Attribute_Name (Mark))) 214 or else Mark = Error 215 then 216 return Mark; 217 else 218 Error_Msg ("subtype mark expected", Sloc (Mark)); 219 return Error; 220 end if; 221 end Check_Subtype_Mark; 222 223 ------------------- 224 -- Comma_Present -- 225 ------------------- 226 227 function Comma_Present return Boolean is 228 Scan_State : Saved_Scan_State; 229 Paren_Count : Nat; 230 231 begin 232 -- First check, if a comma is present, then a comma is present! 233 234 if Token = Tok_Comma then 235 T_Comma; 236 return True; 237 238 -- If we have a right paren, then that is taken as ending the list 239 -- i.e. no comma is present. 240 241 elsif Token = Tok_Right_Paren then 242 return False; 243 244 -- If pragmas, then get rid of them and make a recursive call 245 -- to process what follows these pragmas. 246 247 elsif Token = Tok_Pragma then 248 P_Pragmas_Misplaced; 249 return Comma_Present; 250 251 -- At this stage we have an error, and the goal is to decide on whether 252 -- or not we should diagnose an error and report a (non-existent) 253 -- comma as being present, or simply to report no comma is present 254 255 -- If we are a semicolon, then the question is whether we have a missing 256 -- right paren, or whether the semicolon should have been a comma. To 257 -- guess the right answer, we scan ahead keeping track of the paren 258 -- level, looking for a clue that helps us make the right decision. 259 260 -- This approach is highly accurate in the single error case, and does 261 -- not make bad mistakes in the multiple error case (indeed we can't 262 -- really make a very bad decision at this point in any case). 263 264 elsif Token = Tok_Semicolon then 265 Save_Scan_State (Scan_State); 266 Scan; -- past semicolon 267 268 -- Check for being followed by identifier => which almost certainly 269 -- means we are still in a parameter list and the comma should have 270 -- been a semicolon (such a sequence could not follow a semicolon) 271 272 if Token = Tok_Identifier then 273 Scan; 274 275 if Token = Tok_Arrow then 276 goto Assume_Comma; 277 end if; 278 end if; 279 280 -- If that test didn't work, loop ahead looking for a comma or 281 -- semicolon at the same parenthesis level. Always remember that 282 -- we can't go badly wrong in an error situation like this! 283 284 Paren_Count := 0; 285 286 -- Here is the look ahead loop, Paren_Count tells us whether the 287 -- token we are looking at is at the same paren level as the 288 -- suspicious semicolon that we are trying to figure out. 289 290 loop 291 292 -- If we hit another semicolon or an end of file, and we have 293 -- not seen a right paren or another comma on the way, then 294 -- probably the semicolon did end the list. Indeed that is 295 -- certainly the only single error correction possible here. 296 297 if Token = Tok_Semicolon or else Token = Tok_EOF then 298 Restore_Scan_State (Scan_State); 299 return False; 300 301 -- A comma at the same paren level as the semicolon is a strong 302 -- indicator that the semicolon should have been a comma, indeed 303 -- again this is the only possible single error correction. 304 305 elsif Token = Tok_Comma then 306 exit when Paren_Count = 0; 307 308 -- A left paren just bumps the paren count 309 310 elsif Token = Tok_Left_Paren then 311 Paren_Count := Paren_Count + 1; 312 313 -- A right paren that is at the same paren level as the semicolon 314 -- also means that the only possible single error correction is 315 -- to assume that the semicolon should have been a comma. If we 316 -- are not at the same paren level, then adjust the paren level. 317 318 elsif Token = Tok_Right_Paren then 319 exit when Paren_Count = 0; 320 Paren_Count := Paren_Count - 1; 321 end if; 322 323 -- Keep going, we haven't made a decision yet 324 325 Scan; 326 end loop; 327 328 -- If we fall through the loop, it means that we found a terminating 329 -- right paren or another comma. In either case it is reasonable to 330 -- assume that the semicolon was really intended to be a comma. Also 331 -- come here for the identifier arrow case. 332 333 <<Assume_Comma>> 334 Restore_Scan_State (Scan_State); 335 Error_Msg_SC (""";"" illegal here, replaced by "","""); 336 Scan; -- past the semicolon 337 return True; 338 339 -- If we are not at semicolon or a right paren, then we base the 340 -- decision on whether or not the next token can be part of an 341 -- expression. If not, then decide that no comma is present (the 342 -- caller will eventually generate a missing right parent message) 343 344 elsif Token in Token_Class_Eterm then 345 return False; 346 347 -- Otherwise we assume a comma is present, even if none is present, 348 -- since the next token must be part of an expression, so if we were 349 -- at the end of the list, then there is more than one error present. 350 351 else 352 T_Comma; -- to give error 353 return True; 354 end if; 355 end Comma_Present; 356 357 ----------------------- 358 -- Discard_Junk_List -- 359 ----------------------- 360 361 procedure Discard_Junk_List (L : List_Id) is 362 pragma Warnings (Off, L); 363 364 begin 365 null; 366 end Discard_Junk_List; 367 368 ----------------------- 369 -- Discard_Junk_Node -- 370 ----------------------- 371 372 procedure Discard_Junk_Node (N : Node_Id) is 373 pragma Warnings (Off, N); 374 375 begin 376 null; 377 end Discard_Junk_Node; 378 379 ------------ 380 -- Ignore -- 381 ------------ 382 383 procedure Ignore (T : Token_Type) is 384 begin 385 if Token = T then 386 if T = Tok_Comma then 387 Error_Msg_SC ("unexpected "","" ignored"); 388 389 elsif T = Tok_Left_Paren then 390 Error_Msg_SC ("unexpected ""("" ignored"); 391 392 elsif T = Tok_Right_Paren then 393 Error_Msg_SC ("unexpected "")"" ignored"); 394 395 elsif T = Tok_Semicolon then 396 Error_Msg_SC ("unexpected "";"" ignored"); 397 398 else 399 declare 400 Tname : constant String := Token_Type'Image (Token); 401 Msg : String := "unexpected keyword ????????????????????????"; 402 403 begin 404 -- Loop to copy characters of keyword name (ignoring Tok_) 405 406 for J in 5 .. Tname'Last loop 407 Msg (J + 14) := Fold_Upper (Tname (J)); 408 end loop; 409 410 Msg (Tname'Last + 15 .. Tname'Last + 22) := " ignored"; 411 Error_Msg_SC (Msg (1 .. Tname'Last + 22)); 412 end; 413 end if; 414 415 Scan; -- Scan past ignored token 416 end if; 417 end Ignore; 418 419 ---------------------------- 420 -- Is_Reserved_Identifier -- 421 ---------------------------- 422 423 function Is_Reserved_Identifier (C : Id_Check := None) return Boolean is 424 begin 425 if not Is_Reserved_Keyword (Token) then 426 return False; 427 428 else 429 declare 430 Ident_Casing : constant Casing_Type := 431 Identifier_Casing (Current_Source_File); 432 433 Key_Casing : constant Casing_Type := 434 Keyword_Casing (Current_Source_File); 435 436 begin 437 -- If the casing of identifiers and keywords is different in 438 -- this source file, and the casing of this token matches the 439 -- keyword casing, then we return False, since it is pretty 440 -- clearly intended to be a keyword. 441 442 if Ident_Casing = Unknown 443 or else Key_Casing = Unknown 444 or else Ident_Casing = Key_Casing 445 or else Determine_Token_Casing /= Key_Casing 446 then 447 return True; 448 449 -- Here we have a keyword written clearly with keyword casing. 450 -- In default mode, we would not be willing to consider this as 451 -- a reserved identifier, but if C is set, we may still accept it 452 453 elsif C /= None then 454 declare 455 Scan_State : Saved_Scan_State; 456 OK_Next_Tok : Boolean; 457 458 begin 459 Save_Scan_State (Scan_State); 460 Scan; 461 462 if Token_Is_At_Start_Of_Line then 463 return False; 464 end if; 465 466 case C is 467 when None => 468 raise Program_Error; 469 470 when C_Comma_Right_Paren => 471 OK_Next_Tok := 472 Token = Tok_Comma or else Token = Tok_Right_Paren; 473 474 when C_Comma_Colon => 475 OK_Next_Tok := 476 Token = Tok_Comma or else Token = Tok_Colon; 477 478 when C_Do => 479 OK_Next_Tok := 480 Token = Tok_Do; 481 482 when C_Dot => 483 OK_Next_Tok := 484 Token = Tok_Dot; 485 486 when C_Greater_Greater => 487 OK_Next_Tok := 488 Token = Tok_Greater_Greater; 489 490 when C_In => 491 OK_Next_Tok := 492 Token = Tok_In; 493 494 when C_Is => 495 OK_Next_Tok := 496 Token = Tok_Is; 497 498 when C_Left_Paren_Semicolon => 499 OK_Next_Tok := 500 Token = Tok_Left_Paren or else Token = Tok_Semicolon; 501 502 when C_Use => 503 OK_Next_Tok := 504 Token = Tok_Use; 505 506 when C_Vertical_Bar_Arrow => 507 OK_Next_Tok := 508 Token = Tok_Vertical_Bar or else Token = Tok_Arrow; 509 end case; 510 511 Restore_Scan_State (Scan_State); 512 513 if OK_Next_Tok then 514 return True; 515 end if; 516 end; 517 end if; 518 end; 519 end if; 520 521 -- If we fall through it is not a reserved identifier 522 523 return False; 524 end Is_Reserved_Identifier; 525 526 ---------------------- 527 -- Merge_Identifier -- 528 ---------------------- 529 530 procedure Merge_Identifier (Prev : Node_Id; Nxt : Token_Type) is 531 begin 532 if Token /= Tok_Identifier then 533 return; 534 end if; 535 536 declare 537 S : Saved_Scan_State; 538 T : Token_Type; 539 540 begin 541 Save_Scan_State (S); 542 Scan; 543 T := Token; 544 Restore_Scan_State (S); 545 546 if T /= Nxt then 547 return; 548 end if; 549 end; 550 551 -- Check exactly one space between identifiers 552 553 if Source (Token_Ptr - 1) /= ' ' 554 or else Int (Token_Ptr) /= 555 Int (Prev_Token_Ptr) + Length_Of_Name (Chars (Prev)) + 1 556 then 557 return; 558 end if; 559 560 -- Do the merge 561 562 Get_Name_String (Chars (Token_Node)); 563 564 declare 565 Buf : constant String (1 .. Name_Len) := 566 Name_Buffer (1 .. Name_Len); 567 568 begin 569 Get_Name_String (Chars (Prev)); 570 Add_Char_To_Name_Buffer ('_'); 571 Add_Str_To_Name_Buffer (Buf); 572 Set_Chars (Prev, Name_Find); 573 end; 574 575 Error_Msg_Node_1 := Prev; 576 Error_Msg_SC 577 ("unexpected identifier, possibly & was meant here"); 578 Scan; 579 end Merge_Identifier; 580 581 ------------------- 582 -- No_Constraint -- 583 ------------------- 584 585 procedure No_Constraint is 586 begin 587 if Token in Token_Class_Consk then 588 Error_Msg_SC ("constraint not allowed here"); 589 Discard_Junk_Node (P_Constraint_Opt); 590 end if; 591 end No_Constraint; 592 593 -------------------- 594 -- No_Right_Paren -- 595 -------------------- 596 597 function No_Right_Paren (Expr : Node_Id) return Node_Id is 598 begin 599 if Token = Tok_Right_Paren then 600 Error_Msg_SC ("unexpected right parenthesis"); 601 Resync_Expression; 602 return Error; 603 else 604 return Expr; 605 end if; 606 end No_Right_Paren; 607 608 --------------------- 609 -- Pop_Scope_Stack -- 610 --------------------- 611 612 procedure Pop_Scope_Stack is 613 begin 614 pragma Assert (Scope.Last > 0); 615 Scope.Decrement_Last; 616 617 if Debug_Flag_P then 618 Error_Msg_Uint_1 := UI_From_Int (Scope.Last); 619 Error_Msg_SC ("decrement scope stack ptr, new value = ^!"); 620 end if; 621 end Pop_Scope_Stack; 622 623 ---------------------- 624 -- Push_Scope_Stack -- 625 ---------------------- 626 627 procedure Push_Scope_Stack is 628 begin 629 Scope.Increment_Last; 630 Scope.Table (Scope.Last).Junk := False; 631 Scope.Table (Scope.Last).Node := Empty; 632 633 if Debug_Flag_P then 634 Error_Msg_Uint_1 := UI_From_Int (Scope.Last); 635 Error_Msg_SC ("increment scope stack ptr, new value = ^!"); 636 end if; 637 end Push_Scope_Stack; 638 639 ---------------------- 640 -- Separate_Present -- 641 ---------------------- 642 643 function Separate_Present return Boolean is 644 Scan_State : Saved_Scan_State; 645 646 begin 647 if Token = Tok_Separate then 648 return True; 649 650 elsif Token /= Tok_Identifier then 651 return False; 652 653 else 654 Save_Scan_State (Scan_State); 655 Scan; -- past identifier 656 657 if Token = Tok_Semicolon then 658 Restore_Scan_State (Scan_State); 659 return Bad_Spelling_Of (Tok_Separate); 660 661 else 662 Restore_Scan_State (Scan_State); 663 return False; 664 end if; 665 end if; 666 end Separate_Present; 667 668 -------------------------- 669 -- Signal_Bad_Attribute -- 670 -------------------------- 671 672 procedure Signal_Bad_Attribute is 673 begin 674 Error_Msg_N ("unrecognized attribute&", Token_Node); 675 676 -- Check for possible misspelling 677 678 Get_Name_String (Token_Name); 679 680 declare 681 AN : constant String := Name_Buffer (1 .. Name_Len); 682 683 begin 684 Error_Msg_Name_1 := First_Attribute_Name; 685 while Error_Msg_Name_1 <= Last_Attribute_Name loop 686 Get_Name_String (Error_Msg_Name_1); 687 688 if Is_Bad_Spelling_Of 689 (AN, Name_Buffer (1 .. Name_Len)) 690 then 691 Error_Msg_N 692 ("\possible misspelling of %", Token_Node); 693 exit; 694 end if; 695 696 Error_Msg_Name_1 := Error_Msg_Name_1 + 1; 697 end loop; 698 end; 699 end Signal_Bad_Attribute; 700 701 ----------------------------- 702 -- Token_Is_At_End_Of_Line -- 703 ----------------------------- 704 705 function Token_Is_At_End_Of_Line return Boolean is 706 S : Source_Ptr; 707 708 begin 709 -- Skip past blanks and horizontal tabs 710 711 S := Scan_Ptr; 712 while Source (S) = ' ' or else Source (S) = ASCII.HT loop 713 S := S + 1; 714 end loop; 715 716 -- We are at end of line if at a control character (CR/LF/VT/FF/EOF) 717 -- or if we are at the start of an end of line comment sequence. 718 719 return Source (S) < ' ' 720 or else (Source (S) = '-' and then Source (S + 1) = '-'); 721 end Token_Is_At_End_Of_Line; 722 723 ------------------------------- 724 -- Token_Is_At_Start_Of_Line -- 725 ------------------------------- 726 727 function Token_Is_At_Start_Of_Line return Boolean is 728 begin 729 return (Token_Ptr = First_Non_Blank_Location or else Token = Tok_EOF); 730 end Token_Is_At_Start_Of_Line; 731 732end Util; 733