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