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-2014, 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 Prescan_Message (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.Append 205 (New_Val => 206 (Text => new String'(Msg_Buffer (1 .. Msglen)), 207 Next => No_Error_Msg, 208 Prev => No_Error_Msg, 209 Sfile => Get_Source_File_Index (Sptr), 210 Sptr => Sptr, 211 Optr => Optr, 212 Line => Get_Physical_Line_Number (Sptr), 213 Col => Get_Column_Number (Sptr), 214 Warn => Is_Warning_Msg, 215 Info => Is_Info_Msg, 216 Check => Is_Check_Msg, 217 Warn_Err => Warning_Mode = Treat_As_Error, 218 Warn_Chr => Warning_Msg_Char, 219 Style => Is_Style_Msg, 220 Serious => Is_Serious_Error, 221 Uncond => Is_Unconditional_Msg, 222 Msg_Cont => Continuation, 223 Deleted => False)); 224 225 Cur_Msg := Errors.Last; 226 Prev_Msg := No_Error_Msg; 227 Next_Msg := First_Error_Msg; 228 229 while Next_Msg /= No_Error_Msg loop 230 exit when 231 Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile; 232 233 if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile then 234 exit when Sptr < Errors.Table (Next_Msg).Sptr; 235 end if; 236 237 Prev_Msg := Next_Msg; 238 Next_Msg := Errors.Table (Next_Msg).Next; 239 end loop; 240 241 -- Now we insert the new message in the error chain. The insertion 242 -- point for the message is after Prev_Msg and before Next_Msg. 243 244 -- The possible insertion point for the new message is after Prev_Msg 245 -- and before Next_Msg. However, this is where we do a special check 246 -- for redundant parsing messages, defined as messages posted on the 247 -- same line. The idea here is that probably such messages are junk 248 -- from the parser recovering. In full errors mode, we don't do this 249 -- deletion, but otherwise such messages are discarded at this stage. 250 251 if Prev_Msg /= No_Error_Msg 252 and then Errors.Table (Prev_Msg).Line = 253 Errors.Table (Cur_Msg).Line 254 and then Errors.Table (Prev_Msg).Sfile = 255 Errors.Table (Cur_Msg).Sfile 256 then 257 -- Don't delete unconditional messages and at this stage, don't 258 -- delete continuation lines (we attempted to delete those earlier 259 -- if the parent message was deleted. 260 261 if not Errors.Table (Cur_Msg).Uncond 262 and then not Continuation 263 then 264 265 -- Don't delete if prev msg is warning and new msg is an error. 266 -- This is because we don't want a real error masked by a warning. 267 -- In all other cases (that is parse errors for the same line that 268 -- are not unconditional) we do delete the message. This helps to 269 -- avoid junk extra messages from cascaded parsing errors 270 271 if not (Errors.Table (Prev_Msg).Warn 272 or else 273 Errors.Table (Prev_Msg).Style) 274 or else 275 (Errors.Table (Cur_Msg).Warn 276 or else 277 Errors.Table (Cur_Msg).Style) 278 then 279 -- All tests passed, delete the message by simply returning 280 -- without any further processing. 281 282 if not Continuation then 283 Last_Killed := True; 284 end if; 285 286 return; 287 end if; 288 end if; 289 end if; 290 291 -- Come here if message is to be inserted in the error chain 292 293 if not Continuation then 294 Last_Killed := False; 295 end if; 296 297 if Prev_Msg = No_Error_Msg then 298 First_Error_Msg := Cur_Msg; 299 else 300 Errors.Table (Prev_Msg).Next := Cur_Msg; 301 end if; 302 303 Errors.Table (Cur_Msg).Next := Next_Msg; 304 305 -- Bump appropriate statistics count 306 307 if Errors.Table (Cur_Msg).Warn 308 or else 309 Errors.Table (Cur_Msg).Style 310 then 311 Warnings_Detected := Warnings_Detected + 1; 312 313 if Errors.Table (Cur_Msg).Info then 314 Info_Messages := Info_Messages + 1; 315 end if; 316 317 elsif Errors.Table (Cur_Msg).Check then 318 Check_Messages := Check_Messages + 1; 319 320 else 321 Total_Errors_Detected := Total_Errors_Detected + 1; 322 323 if Errors.Table (Cur_Msg).Serious then 324 Serious_Errors_Detected := Serious_Errors_Detected + 1; 325 end if; 326 end if; 327 328 end Error_Msg; 329 330 ----------------- 331 -- Error_Msg_S -- 332 ----------------- 333 334 procedure Error_Msg_S (Msg : String) is 335 begin 336 Error_Msg (Msg, Scan_Ptr); 337 end Error_Msg_S; 338 339 ------------------ 340 -- Error_Msg_SC -- 341 ------------------ 342 343 procedure Error_Msg_SC (Msg : String) is 344 begin 345 -- If we are at end of file, post the flag after the previous token 346 347 if Token = Tok_EOF then 348 Error_Msg_AP (Msg); 349 350 -- For all other cases the message is posted at the current token 351 -- pointer position 352 353 else 354 Error_Msg (Msg, Token_Ptr); 355 end if; 356 end Error_Msg_SC; 357 358 ------------------ 359 -- Error_Msg_SP -- 360 ------------------ 361 362 procedure Error_Msg_SP (Msg : String) is 363 begin 364 -- Note: in the case where there is no previous token, Prev_Token_Ptr 365 -- is set to Source_First, which is a reasonable position for the 366 -- error flag in this situation 367 368 Error_Msg (Msg, Prev_Token_Ptr); 369 end Error_Msg_SP; 370 371 -------------- 372 -- Finalize -- 373 -------------- 374 375 procedure Finalize (Source_Type : String := "project") is 376 Cur : Error_Msg_Id; 377 Nxt : Error_Msg_Id; 378 E, F : Error_Msg_Id; 379 Err_Flag : Boolean; 380 381 begin 382 -- Eliminate any duplicated error messages from the list. This is 383 -- done after the fact to avoid problems with Change_Error_Text. 384 385 Cur := First_Error_Msg; 386 while Cur /= No_Error_Msg loop 387 Nxt := Errors.Table (Cur).Next; 388 389 F := Nxt; 390 while F /= No_Error_Msg 391 and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr 392 loop 393 Check_Duplicate_Message (Cur, F); 394 F := Errors.Table (F).Next; 395 end loop; 396 397 Cur := Nxt; 398 end loop; 399 400 -- Brief Error mode 401 402 if Brief_Output or (not Full_List and not Verbose_Mode) then 403 E := First_Error_Msg; 404 Set_Standard_Error; 405 406 while E /= No_Error_Msg loop 407 if not Errors.Table (E).Deleted then 408 if Full_Path_Name_For_Brief_Errors then 409 Write_Name (Full_Ref_Name (Errors.Table (E).Sfile)); 410 else 411 Write_Name (Reference_Name (Errors.Table (E).Sfile)); 412 end if; 413 414 Write_Char (':'); 415 Write_Int (Int (Physical_To_Logical 416 (Errors.Table (E).Line, 417 Errors.Table (E).Sfile))); 418 Write_Char (':'); 419 420 if Errors.Table (E).Col < 10 then 421 Write_Char ('0'); 422 end if; 423 424 Write_Int (Int (Errors.Table (E).Col)); 425 Write_Str (": "); 426 Output_Msg_Text (E); 427 Write_Eol; 428 end if; 429 430 E := Errors.Table (E).Next; 431 end loop; 432 433 Set_Standard_Output; 434 end if; 435 436 -- Full source listing case 437 438 if Full_List then 439 List_Pragmas_Index := 1; 440 List_Pragmas_Mode := True; 441 E := First_Error_Msg; 442 Write_Eol; 443 444 -- First list initial main source file with its error messages 445 446 for N in 1 .. Last_Source_Line (Main_Source_File) loop 447 Err_Flag := 448 E /= No_Error_Msg 449 and then Errors.Table (E).Line = N 450 and then Errors.Table (E).Sfile = Main_Source_File; 451 452 Output_Source_Line (N, Main_Source_File, Err_Flag, Source_Type); 453 454 if Err_Flag then 455 Output_Error_Msgs (E); 456 457 Write_Eol; 458 end if; 459 end loop; 460 461 -- Then output errors, if any, for subsidiary units 462 463 while E /= No_Error_Msg 464 and then Errors.Table (E).Sfile /= Main_Source_File 465 loop 466 Write_Eol; 467 Output_Source_Line 468 (Errors.Table (E).Line, 469 Errors.Table (E).Sfile, 470 True, 471 Source_Type); 472 Output_Error_Msgs (E); 473 end loop; 474 end if; 475 476 -- Verbose mode (error lines only with error flags) 477 478 if Verbose_Mode then 479 E := First_Error_Msg; 480 481 -- Loop through error lines 482 483 while E /= No_Error_Msg loop 484 Write_Eol; 485 Output_Source_Line 486 (Errors.Table (E).Line, 487 Errors.Table (E).Sfile, 488 True, 489 Source_Type); 490 Output_Error_Msgs (E); 491 end loop; 492 end if; 493 494 -- Output error summary if verbose or full list mode 495 496 if Verbose_Mode or else Full_List then 497 498 -- Extra blank line if error messages or source listing were output 499 500 if Total_Errors_Detected + Warnings_Detected > 0 501 or else Full_List 502 then 503 Write_Eol; 504 end if; 505 506 -- Message giving number of lines read and number of errors detected. 507 -- This normally goes to Standard_Output. The exception is when brief 508 -- mode is not set, verbose mode (or full list mode) is set, and 509 -- there are errors. In this case we send the message to standard 510 -- error to make sure that *something* appears on standard error in 511 -- an error situation. 512 513 -- Historical note: Formerly, only the "# errors" suffix was sent 514 -- to stderr, whereas "# lines:" appeared on stdout. This caused 515 -- some problems on now-obsolete ports, but there seems to be no 516 -- reason to revert this page since it would be incompatible. 517 518 if Total_Errors_Detected + Warnings_Detected /= 0 519 and then not Brief_Output 520 and then (Verbose_Mode or Full_List) 521 then 522 Set_Standard_Error; 523 end if; 524 525 -- Message giving total number of lines 526 527 Write_Str (" "); 528 Write_Int (Num_Source_Lines (Main_Source_File)); 529 530 if Num_Source_Lines (Main_Source_File) = 1 then 531 Write_Str (" line: "); 532 else 533 Write_Str (" lines: "); 534 end if; 535 536 if Total_Errors_Detected = 0 then 537 Write_Str ("No errors"); 538 539 elsif Total_Errors_Detected = 1 then 540 Write_Str ("1 error"); 541 542 else 543 Write_Int (Total_Errors_Detected); 544 Write_Str (" errors"); 545 end if; 546 547 if Warnings_Detected - Info_Messages /= 0 then 548 Write_Str (", "); 549 Write_Int (Warnings_Detected - Info_Messages); 550 Write_Str (" warning"); 551 552 if Warnings_Detected - Info_Messages /= 1 then 553 Write_Char ('s'); 554 end if; 555 556 if Warning_Mode = Treat_As_Error then 557 Write_Str (" (treated as error"); 558 559 if Warnings_Detected - Info_Messages /= 1 then 560 Write_Char ('s'); 561 end if; 562 563 Write_Char (')'); 564 end if; 565 end if; 566 567 Write_Eol; 568 Set_Standard_Output; 569 end if; 570 571 if Maximum_Messages /= 0 then 572 if Warnings_Detected >= Maximum_Messages then 573 Set_Standard_Error; 574 Write_Line ("maximum number of warnings detected"); 575 Warning_Mode := Suppress; 576 end if; 577 578 if Total_Errors_Detected >= Maximum_Messages then 579 Set_Standard_Error; 580 Write_Line ("fatal error: maximum errors reached"); 581 Set_Standard_Output; 582 end if; 583 end if; 584 585 if Warning_Mode = Treat_As_Error then 586 Total_Errors_Detected := 587 Total_Errors_Detected + Warnings_Detected - Info_Messages; 588 Warnings_Detected := Info_Messages; 589 end if; 590 591 -- Prevent displaying the same messages again in the future 592 593 First_Error_Msg := No_Error_Msg; 594 end Finalize; 595 596 ---------------- 597 -- Initialize -- 598 ---------------- 599 600 procedure Initialize is 601 begin 602 Errors.Init; 603 First_Error_Msg := No_Error_Msg; 604 Last_Error_Msg := No_Error_Msg; 605 Serious_Errors_Detected := 0; 606 Total_Errors_Detected := 0; 607 Warnings_Detected := 0; 608 Info_Messages := 0; 609 Cur_Msg := No_Error_Msg; 610 611 -- Initialize warnings table, if all warnings are suppressed, supply 612 -- an initial dummy entry covering all possible source locations. 613 614 Warnings.Init; 615 616 if Warning_Mode = Suppress then 617 Warnings.Append 618 (New_Val => 619 (Start => Source_Ptr'First, 620 Stop => Source_Ptr'Last, 621 Reason => Null_String_Id)); 622 end if; 623 end Initialize; 624 625 ------------------------ 626 -- Output_Source_Line -- 627 ------------------------ 628 629 procedure Output_Source_Line 630 (L : Physical_Line_Number; 631 Sfile : Source_File_Index; 632 Errs : Boolean; 633 Source_Type : String) 634 is 635 S : Source_Ptr; 636 C : Character; 637 638 Line_Number_Output : Boolean := False; 639 -- Set True once line number is output 640 641 begin 642 if Sfile /= Current_Error_Source_File then 643 Write_Str ("==============Error messages for "); 644 Write_Str (Source_Type); 645 Write_Str (" file: "); 646 Write_Name (Full_File_Name (Sfile)); 647 Write_Eol; 648 Current_Error_Source_File := Sfile; 649 end if; 650 651 if Errs then 652 Output_Line_Number (Physical_To_Logical (L, Sfile)); 653 Line_Number_Output := True; 654 end if; 655 656 S := Line_Start (L, Sfile); 657 658 loop 659 C := Source_Text (Sfile) (S); 660 exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF; 661 662 if Errs then 663 Write_Char (C); 664 end if; 665 666 S := S + 1; 667 end loop; 668 669 if Line_Number_Output then 670 Write_Eol; 671 end if; 672 end Output_Source_Line; 673 674 ----------------------- 675 -- Set_Ignore_Errors -- 676 ----------------------- 677 678 procedure Set_Ignore_Errors (To : Boolean) is 679 begin 680 Errors_Must_Be_Ignored := To; 681 end Set_Ignore_Errors; 682 683 ------------------------------ 684 -- Set_Msg_Insertion_Column -- 685 ------------------------------ 686 687 procedure Set_Msg_Insertion_Column is 688 begin 689 if RM_Column_Check then 690 Set_Msg_Str (" in column "); 691 Set_Msg_Int (Int (Error_Msg_Col) + 1); 692 end if; 693 end Set_Msg_Insertion_Column; 694 695 ------------------ 696 -- Set_Msg_Text -- 697 ------------------ 698 699 procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is 700 C : Character; -- Current character 701 P : Natural; -- Current index; 702 703 begin 704 Manual_Quote_Mode := False; 705 Msglen := 0; 706 Flag_Source := Get_Source_File_Index (Flag); 707 P := Text'First; 708 709 while P <= Text'Last loop 710 C := Text (P); 711 P := P + 1; 712 713 -- Check for insertion character 714 715 if C = '%' then 716 if P <= Text'Last and then Text (P) = '%' then 717 P := P + 1; 718 Set_Msg_Insertion_Name_Literal; 719 else 720 Set_Msg_Insertion_Name; 721 end if; 722 723 elsif C = '$' then 724 725 -- '$' is ignored 726 727 null; 728 729 elsif C = '{' then 730 Set_Msg_Insertion_File_Name; 731 732 elsif C = '}' then 733 734 -- '}' is ignored 735 736 null; 737 738 elsif C = '*' then 739 Set_Msg_Insertion_Reserved_Name; 740 741 elsif C = '&' then 742 743 -- '&' is ignored 744 745 null; 746 747 elsif C = '#' then 748 Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag); 749 750 elsif C = '\' then 751 Continuation := True; 752 753 elsif C = '@' then 754 Set_Msg_Insertion_Column; 755 756 elsif C = '^' then 757 Set_Msg_Insertion_Uint; 758 759 elsif C = '`' then 760 Manual_Quote_Mode := not Manual_Quote_Mode; 761 Set_Msg_Char ('"'); 762 763 elsif C = '!' then 764 null; 765 766 elsif C = '?' then 767 null; 768 769 elsif C = '<' then 770 null; 771 772 elsif C = '|' then 773 null; 774 775 elsif C = ''' then 776 Set_Msg_Char (Text (P)); 777 P := P + 1; 778 779 -- Upper case letter (start of reserved word if 2 or more) 780 781 elsif C in 'A' .. 'Z' 782 and then P <= Text'Last 783 and then Text (P) in 'A' .. 'Z' 784 then 785 P := P - 1; 786 Set_Msg_Insertion_Reserved_Word (Text, P); 787 788 elsif C = '~' then 789 Set_Msg_Str (Error_Msg_String (1 .. Error_Msg_Strlen)); 790 791 -- Normal character with no special treatment 792 793 else 794 Set_Msg_Char (C); 795 end if; 796 797 end loop; 798 end Set_Msg_Text; 799 800end Errutil; 801