1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E R R U T I L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1991-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 Err_Vars; use Err_Vars; 28with Erroutc; use Erroutc; 29with Namet; use Namet; 30with Opt; use Opt; 31with Output; use Output; 32with Scans; use Scans; 33with Sinput; use Sinput; 34with Stylesw; use Stylesw; 35 36package body Errutil is 37 38 Errors_Must_Be_Ignored : Boolean := False; 39 -- Set to True by procedure Set_Ignore_Errors (True), when calls to 40 -- error message procedures should be ignored (when parsing irrelevant 41 -- text in sources being preprocessed). 42 43 ----------------------- 44 -- Local Subprograms -- 45 ----------------------- 46 47 procedure Error_Msg_AP (Msg : String); 48 -- Output a message just after the previous token 49 50 procedure Output_Source_Line 51 (L : Physical_Line_Number; 52 Sfile : Source_File_Index; 53 Errs : Boolean; 54 Source_Type : String); 55 -- Outputs text of source line L, in file S, together with preceding line 56 -- number, as described above for Output_Line_Number. The Errs parameter 57 -- indicates if there are errors attached to the line, which forces 58 -- listing on, even in the presence of pragma List (Off). 59 60 procedure Set_Msg_Insertion_Column; 61 -- Handle column number insertion (@ insertion character) 62 63 procedure Set_Msg_Text (Text : String; Flag : Source_Ptr); 64 -- Add a sequence of characters to the current message. The characters may 65 -- be one of the special insertion characters (see documentation in spec). 66 -- Flag is the location at which the error is to be posted, which is used 67 -- to determine whether or not the # insertion needs a file name. The 68 -- variables Msg_Buffer, Msglen, Is_Style_Msg, Is_Warning_Msg, and 69 -- Is_Unconditional_Msg are set on return. 70 71 ------------------ 72 -- Error_Msg_AP -- 73 ------------------ 74 75 procedure Error_Msg_AP (Msg : String) is 76 S1 : Source_Ptr; 77 C : Character; 78 79 begin 80 -- If we had saved the Scan_Ptr value after scanning the previous 81 -- token, then we would have exactly the right place for putting 82 -- the flag immediately at hand. However, that would add at least 83 -- two instructions to a Scan call *just* to service the possibility 84 -- of an Error_Msg_AP call. So instead we reconstruct that value. 85 86 -- We have two possibilities, start with Prev_Token_Ptr and skip over 87 -- the current token, which is made harder by the possibility that this 88 -- token may be in error, or start with Token_Ptr and work backwards. 89 -- We used to take the second approach, but it's hard because of 90 -- comments, and harder still because things that look like comments 91 -- can appear inside strings. So now we take the first approach. 92 93 -- Note: in the case where there is no previous token, Prev_Token_Ptr 94 -- is set to Source_First, which is a reasonable position for the 95 -- error flag in this situation. 96 97 S1 := Prev_Token_Ptr; 98 C := Source (S1); 99 100 -- If the previous token is a string literal, we need a special approach 101 -- since there may be white space inside the literal and we don't want 102 -- to stop on that white space. 103 104 -- Note that it is not worth worrying about special UTF_32 line 105 -- terminator characters in this context, since this is only about 106 -- error recovery anyway. 107 108 if Prev_Token = Tok_String_Literal then 109 loop 110 S1 := S1 + 1; 111 112 if Source (S1) = C then 113 S1 := S1 + 1; 114 exit when Source (S1) /= C; 115 elsif Source (S1) in Line_Terminator then 116 exit; 117 end if; 118 end loop; 119 120 -- Character literal also needs special handling 121 122 elsif Prev_Token = Tok_Char_Literal then 123 S1 := S1 + 3; 124 125 -- Otherwise we search forward for the end of the current token, marked 126 -- by a line terminator, white space, a comment symbol or if we bump 127 -- into the following token (i.e. the current token) 128 129 -- Note that it is not worth worrying about special UTF_32 line 130 -- terminator characters in this context, since this is only about 131 -- error recovery anyway. 132 133 else 134 while Source (S1) not in Line_Terminator 135 and then Source (S1) /= ' ' 136 and then Source (S1) /= ASCII.HT 137 and then (Source (S1) /= '-' or else Source (S1 + 1) /= '-') 138 and then S1 /= Token_Ptr 139 loop 140 S1 := S1 + 1; 141 end loop; 142 end if; 143 144 -- S1 is now set to the location for the flag 145 146 Error_Msg (Msg, S1); 147 148 end Error_Msg_AP; 149 150 --------------- 151 -- Error_Msg -- 152 --------------- 153 154 procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is 155 156 Next_Msg : Error_Msg_Id; 157 -- Pointer to next message at insertion point 158 159 Prev_Msg : Error_Msg_Id; 160 -- Pointer to previous message at insertion point 161 162 Sptr : Source_Ptr renames Flag_Location; 163 -- Corresponds to the Sptr value in the error message object 164 165 Optr : Source_Ptr renames Flag_Location; 166 -- Corresponds to the Optr value in the error message object. Note 167 -- that for this usage, Sptr and Optr always have the same value, 168 -- since we do not have to worry about generic instantiations. 169 170 begin 171 if Errors_Must_Be_Ignored then 172 return; 173 end if; 174 175 if Raise_Exception_On_Error /= 0 then 176 raise Error_Msg_Exception; 177 end if; 178 179 Test_Style_Warning_Serious_Msg (Msg); 180 Set_Msg_Text (Msg, Sptr); 181 182 -- Kill continuation if parent message killed 183 184 if Continuation and Last_Killed then 185 return; 186 end if; 187 188 -- Return without doing anything if message is killed and this is not 189 -- the first error message. The philosophy is that if we get a weird 190 -- error message and we already have had a message, then we hope the 191 -- weird message is a junk cascaded message 192 193 -- Immediate return if warning message and warnings are suppressed. 194 -- Note that style messages are not warnings for this purpose. 195 196 if Is_Warning_Msg and then Warnings_Suppressed (Sptr) then 197 Cur_Msg := No_Error_Msg; 198 return; 199 end if; 200 201 -- Otherwise build error message object for new message 202 203 Errors.Increment_Last; 204 Cur_Msg := Errors.Last; 205 Errors.Table (Cur_Msg).Text := new String'(Msg_Buffer (1 .. Msglen)); 206 Errors.Table (Cur_Msg).Next := No_Error_Msg; 207 Errors.Table (Cur_Msg).Sptr := Sptr; 208 Errors.Table (Cur_Msg).Optr := Optr; 209 Errors.Table (Cur_Msg).Sfile := Get_Source_File_Index (Sptr); 210 Errors.Table (Cur_Msg).Line := Get_Physical_Line_Number (Sptr); 211 Errors.Table (Cur_Msg).Col := Get_Column_Number (Sptr); 212 Errors.Table (Cur_Msg).Style := Is_Style_Msg; 213 Errors.Table (Cur_Msg).Warn := Is_Warning_Msg; 214 Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char; 215 Errors.Table (Cur_Msg).Serious := Is_Serious_Error; 216 Errors.Table (Cur_Msg).Uncond := Is_Unconditional_Msg; 217 Errors.Table (Cur_Msg).Msg_Cont := Continuation; 218 Errors.Table (Cur_Msg).Deleted := False; 219 220 Prev_Msg := No_Error_Msg; 221 Next_Msg := First_Error_Msg; 222 223 while Next_Msg /= No_Error_Msg loop 224 exit when 225 Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile; 226 227 if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile then 228 exit when Sptr < Errors.Table (Next_Msg).Sptr; 229 end if; 230 231 Prev_Msg := Next_Msg; 232 Next_Msg := Errors.Table (Next_Msg).Next; 233 end loop; 234 235 -- Now we insert the new message in the error chain. The insertion 236 -- point for the message is after Prev_Msg and before Next_Msg. 237 238 -- The possible insertion point for the new message is after Prev_Msg 239 -- and before Next_Msg. However, this is where we do a special check 240 -- for redundant parsing messages, defined as messages posted on the 241 -- same line. The idea here is that probably such messages are junk 242 -- from the parser recovering. In full errors mode, we don't do this 243 -- deletion, but otherwise such messages are discarded at this stage. 244 245 if Prev_Msg /= No_Error_Msg 246 and then Errors.Table (Prev_Msg).Line = 247 Errors.Table (Cur_Msg).Line 248 and then Errors.Table (Prev_Msg).Sfile = 249 Errors.Table (Cur_Msg).Sfile 250 then 251 -- Don't delete unconditional messages and at this stage, don't 252 -- delete continuation lines (we attempted to delete those earlier 253 -- if the parent message was deleted. 254 255 if not Errors.Table (Cur_Msg).Uncond 256 and then not Continuation 257 then 258 259 -- Don't delete if prev msg is warning and new msg is an error. 260 -- This is because we don't want a real error masked by a warning. 261 -- In all other cases (that is parse errors for the same line that 262 -- are not unconditional) we do delete the message. This helps to 263 -- avoid junk extra messages from cascaded parsing errors 264 265 if not (Errors.Table (Prev_Msg).Warn 266 or else 267 Errors.Table (Prev_Msg).Style) 268 or else 269 (Errors.Table (Cur_Msg).Warn 270 or else 271 Errors.Table (Cur_Msg).Style) 272 then 273 -- All tests passed, delete the message by simply returning 274 -- without any further processing. 275 276 if not Continuation then 277 Last_Killed := True; 278 end if; 279 280 return; 281 end if; 282 end if; 283 end if; 284 285 -- Come here if message is to be inserted in the error chain 286 287 if not Continuation then 288 Last_Killed := False; 289 end if; 290 291 if Prev_Msg = No_Error_Msg then 292 First_Error_Msg := Cur_Msg; 293 else 294 Errors.Table (Prev_Msg).Next := Cur_Msg; 295 end if; 296 297 Errors.Table (Cur_Msg).Next := Next_Msg; 298 299 -- Bump appropriate statistics count 300 301 if Errors.Table (Cur_Msg).Warn 302 or else 303 Errors.Table (Cur_Msg).Style 304 then 305 Warnings_Detected := Warnings_Detected + 1; 306 307 else 308 Total_Errors_Detected := Total_Errors_Detected + 1; 309 310 if Errors.Table (Cur_Msg).Serious then 311 Serious_Errors_Detected := Serious_Errors_Detected + 1; 312 end if; 313 end if; 314 315 end Error_Msg; 316 317 ----------------- 318 -- Error_Msg_S -- 319 ----------------- 320 321 procedure Error_Msg_S (Msg : String) is 322 begin 323 Error_Msg (Msg, Scan_Ptr); 324 end Error_Msg_S; 325 326 ------------------ 327 -- Error_Msg_SC -- 328 ------------------ 329 330 procedure Error_Msg_SC (Msg : String) is 331 begin 332 -- If we are at end of file, post the flag after the previous token 333 334 if Token = Tok_EOF then 335 Error_Msg_AP (Msg); 336 337 -- For all other cases the message is posted at the current token 338 -- pointer position 339 340 else 341 Error_Msg (Msg, Token_Ptr); 342 end if; 343 end Error_Msg_SC; 344 345 ------------------ 346 -- Error_Msg_SP -- 347 ------------------ 348 349 procedure Error_Msg_SP (Msg : String) is 350 begin 351 -- Note: in the case where there is no previous token, Prev_Token_Ptr 352 -- is set to Source_First, which is a reasonable position for the 353 -- error flag in this situation 354 355 Error_Msg (Msg, Prev_Token_Ptr); 356 end Error_Msg_SP; 357 358 -------------- 359 -- Finalize -- 360 -------------- 361 362 procedure Finalize (Source_Type : String := "project") is 363 Cur : Error_Msg_Id; 364 Nxt : Error_Msg_Id; 365 E, F : Error_Msg_Id; 366 Err_Flag : Boolean; 367 368 begin 369 -- Eliminate any duplicated error messages from the list. This is 370 -- done after the fact to avoid problems with Change_Error_Text. 371 372 Cur := First_Error_Msg; 373 while Cur /= No_Error_Msg loop 374 Nxt := Errors.Table (Cur).Next; 375 376 F := Nxt; 377 while F /= No_Error_Msg 378 and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr 379 loop 380 Check_Duplicate_Message (Cur, F); 381 F := Errors.Table (F).Next; 382 end loop; 383 384 Cur := Nxt; 385 end loop; 386 387 -- Brief Error mode 388 389 if Brief_Output or (not Full_List and not Verbose_Mode) then 390 E := First_Error_Msg; 391 Set_Standard_Error; 392 393 while E /= No_Error_Msg loop 394 if not Errors.Table (E).Deleted then 395 if Full_Path_Name_For_Brief_Errors then 396 Write_Name (Full_Ref_Name (Errors.Table (E).Sfile)); 397 else 398 Write_Name (Reference_Name (Errors.Table (E).Sfile)); 399 end if; 400 401 Write_Char (':'); 402 Write_Int (Int (Physical_To_Logical 403 (Errors.Table (E).Line, 404 Errors.Table (E).Sfile))); 405 Write_Char (':'); 406 407 if Errors.Table (E).Col < 10 then 408 Write_Char ('0'); 409 end if; 410 411 Write_Int (Int (Errors.Table (E).Col)); 412 Write_Str (": "); 413 Output_Msg_Text (E); 414 Write_Eol; 415 end if; 416 417 E := Errors.Table (E).Next; 418 end loop; 419 420 Set_Standard_Output; 421 end if; 422 423 -- Full source listing case 424 425 if Full_List then 426 List_Pragmas_Index := 1; 427 List_Pragmas_Mode := True; 428 E := First_Error_Msg; 429 Write_Eol; 430 431 -- First list initial main source file with its error messages 432 433 for N in 1 .. Last_Source_Line (Main_Source_File) loop 434 Err_Flag := 435 E /= No_Error_Msg 436 and then Errors.Table (E).Line = N 437 and then Errors.Table (E).Sfile = Main_Source_File; 438 439 Output_Source_Line (N, Main_Source_File, Err_Flag, Source_Type); 440 441 if Err_Flag then 442 Output_Error_Msgs (E); 443 444 Write_Eol; 445 end if; 446 end loop; 447 448 -- Then output errors, if any, for subsidiary units 449 450 while E /= No_Error_Msg 451 and then Errors.Table (E).Sfile /= Main_Source_File 452 loop 453 Write_Eol; 454 Output_Source_Line 455 (Errors.Table (E).Line, 456 Errors.Table (E).Sfile, 457 True, 458 Source_Type); 459 Output_Error_Msgs (E); 460 end loop; 461 end if; 462 463 -- Verbose mode (error lines only with error flags) 464 465 if Verbose_Mode then 466 E := First_Error_Msg; 467 468 -- Loop through error lines 469 470 while E /= No_Error_Msg loop 471 Write_Eol; 472 Output_Source_Line 473 (Errors.Table (E).Line, 474 Errors.Table (E).Sfile, 475 True, 476 Source_Type); 477 Output_Error_Msgs (E); 478 end loop; 479 end if; 480 481 -- Output error summary if verbose or full list mode 482 483 if Verbose_Mode or else Full_List then 484 485 -- Extra blank line if error messages or source listing were output 486 487 if Total_Errors_Detected + Warnings_Detected > 0 488 or else Full_List 489 then 490 Write_Eol; 491 end if; 492 493 -- Message giving number of lines read and number of errors detected. 494 -- This normally goes to Standard_Output. The exception is when brief 495 -- mode is not set, verbose mode (or full list mode) is set, and 496 -- there are errors. In this case we send the message to standard 497 -- error to make sure that *something* appears on standard error in 498 -- an error situation. 499 500 -- Formerly, only the "# errors" suffix was sent to stderr, whereas 501 -- "# lines:" appeared on stdout. This caused problems on VMS when 502 -- the stdout buffer was flushed, giving an extra line feed after 503 -- the prefix. 504 505 if Total_Errors_Detected + Warnings_Detected /= 0 506 and then not Brief_Output 507 and then (Verbose_Mode or Full_List) 508 then 509 Set_Standard_Error; 510 end if; 511 512 -- Message giving total number of lines 513 514 Write_Str (" "); 515 Write_Int (Num_Source_Lines (Main_Source_File)); 516 517 if Num_Source_Lines (Main_Source_File) = 1 then 518 Write_Str (" line: "); 519 else 520 Write_Str (" lines: "); 521 end if; 522 523 if Total_Errors_Detected = 0 then 524 Write_Str ("No errors"); 525 526 elsif Total_Errors_Detected = 1 then 527 Write_Str ("1 error"); 528 529 else 530 Write_Int (Total_Errors_Detected); 531 Write_Str (" errors"); 532 end if; 533 534 if Warnings_Detected /= 0 then 535 Write_Str (", "); 536 Write_Int (Warnings_Detected); 537 Write_Str (" warning"); 538 539 if Warnings_Detected /= 1 then 540 Write_Char ('s'); 541 end if; 542 543 if Warning_Mode = Treat_As_Error then 544 Write_Str (" (treated as error"); 545 546 if Warnings_Detected /= 1 then 547 Write_Char ('s'); 548 end if; 549 550 Write_Char (')'); 551 end if; 552 end if; 553 554 Write_Eol; 555 Set_Standard_Output; 556 end if; 557 558 if Maximum_Messages /= 0 then 559 if Warnings_Detected >= Maximum_Messages then 560 Set_Standard_Error; 561 Write_Line ("maximum number of warnings detected"); 562 Warning_Mode := Suppress; 563 end if; 564 565 if Total_Errors_Detected >= Maximum_Messages then 566 Set_Standard_Error; 567 Write_Line ("fatal error: maximum errors reached"); 568 Set_Standard_Output; 569 end if; 570 end if; 571 572 if Warning_Mode = Treat_As_Error then 573 Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected; 574 Warnings_Detected := 0; 575 end if; 576 577 -- Prevent displaying the same messages again in the future 578 579 First_Error_Msg := No_Error_Msg; 580 end Finalize; 581 582 ---------------- 583 -- Initialize -- 584 ---------------- 585 586 procedure Initialize is 587 begin 588 Errors.Init; 589 First_Error_Msg := No_Error_Msg; 590 Last_Error_Msg := No_Error_Msg; 591 Serious_Errors_Detected := 0; 592 Total_Errors_Detected := 0; 593 Warnings_Detected := 0; 594 Cur_Msg := No_Error_Msg; 595 596 -- Initialize warnings table, if all warnings are suppressed, supply 597 -- an initial dummy entry covering all possible source locations. 598 599 Warnings.Init; 600 601 if Warning_Mode = Suppress then 602 Warnings.Increment_Last; 603 Warnings.Table (Warnings.Last).Start := Source_Ptr'First; 604 Warnings.Table (Warnings.Last).Stop := Source_Ptr'Last; 605 end if; 606 end Initialize; 607 608 ------------------------ 609 -- Output_Source_Line -- 610 ------------------------ 611 612 procedure Output_Source_Line 613 (L : Physical_Line_Number; 614 Sfile : Source_File_Index; 615 Errs : Boolean; 616 Source_Type : String) 617 is 618 S : Source_Ptr; 619 C : Character; 620 621 Line_Number_Output : Boolean := False; 622 -- Set True once line number is output 623 624 begin 625 if Sfile /= Current_Error_Source_File then 626 Write_Str ("==============Error messages for "); 627 Write_Str (Source_Type); 628 Write_Str (" file: "); 629 Write_Name (Full_File_Name (Sfile)); 630 Write_Eol; 631 Current_Error_Source_File := Sfile; 632 end if; 633 634 if Errs then 635 Output_Line_Number (Physical_To_Logical (L, Sfile)); 636 Line_Number_Output := True; 637 end if; 638 639 S := Line_Start (L, Sfile); 640 641 loop 642 C := Source_Text (Sfile) (S); 643 exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF; 644 645 if Errs then 646 Write_Char (C); 647 end if; 648 649 S := S + 1; 650 end loop; 651 652 if Line_Number_Output then 653 Write_Eol; 654 end if; 655 end Output_Source_Line; 656 657 ----------------------- 658 -- Set_Ignore_Errors -- 659 ----------------------- 660 661 procedure Set_Ignore_Errors (To : Boolean) is 662 begin 663 Errors_Must_Be_Ignored := To; 664 end Set_Ignore_Errors; 665 666 ------------------------------ 667 -- Set_Msg_Insertion_Column -- 668 ------------------------------ 669 670 procedure Set_Msg_Insertion_Column is 671 begin 672 if RM_Column_Check then 673 Set_Msg_Str (" in column "); 674 Set_Msg_Int (Int (Error_Msg_Col) + 1); 675 end if; 676 end Set_Msg_Insertion_Column; 677 678 ------------------ 679 -- Set_Msg_Text -- 680 ------------------ 681 682 procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is 683 C : Character; -- Current character 684 P : Natural; -- Current index; 685 686 begin 687 Manual_Quote_Mode := False; 688 Msglen := 0; 689 Flag_Source := Get_Source_File_Index (Flag); 690 P := Text'First; 691 692 while P <= Text'Last loop 693 C := Text (P); 694 P := P + 1; 695 696 -- Check for insertion character 697 698 if C = '%' then 699 if P <= Text'Last and then Text (P) = '%' then 700 P := P + 1; 701 Set_Msg_Insertion_Name_Literal; 702 else 703 Set_Msg_Insertion_Name; 704 end if; 705 706 elsif C = '$' then 707 708 -- '$' is ignored 709 710 null; 711 712 elsif C = '{' then 713 Set_Msg_Insertion_File_Name; 714 715 elsif C = '}' then 716 717 -- '}' is ignored 718 719 null; 720 721 elsif C = '*' then 722 Set_Msg_Insertion_Reserved_Name; 723 724 elsif C = '&' then 725 726 -- '&' is ignored 727 728 null; 729 730 elsif C = '#' then 731 Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag); 732 733 elsif C = '\' then 734 Continuation := True; 735 736 elsif C = '@' then 737 Set_Msg_Insertion_Column; 738 739 elsif C = '^' then 740 Set_Msg_Insertion_Uint; 741 742 elsif C = '`' then 743 Manual_Quote_Mode := not Manual_Quote_Mode; 744 Set_Msg_Char ('"'); 745 746 elsif C = '!' then 747 Is_Unconditional_Msg := True; 748 749 elsif C = '?' then 750 null; 751 752 elsif C = '<' then 753 null; 754 755 elsif C = '|' then 756 null; 757 758 elsif C = ''' then 759 Set_Msg_Char (Text (P)); 760 P := P + 1; 761 762 -- Upper case letter (start of reserved word if 2 or more) 763 764 elsif C in 'A' .. 'Z' 765 and then P <= Text'Last 766 and then Text (P) in 'A' .. 'Z' 767 then 768 P := P - 1; 769 Set_Msg_Insertion_Reserved_Word (Text, P); 770 771 -- Normal character with no special treatment 772 773 else 774 Set_Msg_Char (C); 775 end if; 776 777 end loop; 778 end Set_Msg_Text; 779 780end Errutil; 781