1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E R R O U T C -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-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 26-- Warning: Error messages can be generated during Gigi processing by direct 27-- calls to error message routines, so it is essential that the processing 28-- in this body be consistent with the requirements for the Gigi processing 29-- environment, and that in particular, no disallowed table expansion is 30-- allowed to occur. 31 32with Atree; use Atree; 33with Casing; use Casing; 34with Csets; use Csets; 35with Debug; use Debug; 36with Err_Vars; use Err_Vars; 37with Namet; use Namet; 38with Opt; use Opt; 39with Output; use Output; 40with Sinput; use Sinput; 41with Snames; use Snames; 42with Stringt; use Stringt; 43with Targparm; use Targparm; 44with Uintp; use Uintp; 45 46package body Erroutc is 47 48 ----------------------- 49 -- Local Subprograms -- 50 ----------------------- 51 52 function Matches (S : String; P : String) return Boolean; 53 -- Returns true if the String S patches the pattern P, which can contain 54 -- wild card chars (*). The entire pattern must match the entire string. 55 -- Case is ignored in the comparison (so X matches x). 56 57 --------------- 58 -- Add_Class -- 59 --------------- 60 61 procedure Add_Class is 62 begin 63 if Class_Flag then 64 Class_Flag := False; 65 Set_Msg_Char ('''); 66 Get_Name_String (Name_Class); 67 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); 68 Set_Msg_Name_Buffer; 69 end if; 70 end Add_Class; 71 72 ---------------------- 73 -- Buffer_Ends_With -- 74 ---------------------- 75 76 function Buffer_Ends_With (C : Character) return Boolean is 77 begin 78 return Msglen > 0 and then Msg_Buffer (Msglen) = C; 79 end Buffer_Ends_With; 80 81 function Buffer_Ends_With (S : String) return Boolean is 82 Len : constant Natural := S'Length; 83 begin 84 return Msglen > Len 85 and then Msg_Buffer (Msglen - Len) = ' ' 86 and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S; 87 end Buffer_Ends_With; 88 89 ------------------- 90 -- Buffer_Remove -- 91 ------------------- 92 93 procedure Buffer_Remove (C : Character) is 94 begin 95 if Buffer_Ends_With (C) then 96 Msglen := Msglen - 1; 97 end if; 98 end Buffer_Remove; 99 100 procedure Buffer_Remove (S : String) is 101 begin 102 if Buffer_Ends_With (S) then 103 Msglen := Msglen - S'Length; 104 end if; 105 end Buffer_Remove; 106 107 ----------------------------- 108 -- Check_Duplicate_Message -- 109 ----------------------------- 110 111 procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is 112 L1, L2 : Error_Msg_Id; 113 N1, N2 : Error_Msg_Id; 114 115 procedure Delete_Msg (Delete, Keep : Error_Msg_Id); 116 -- Called to delete message Delete, keeping message Keep. Marks all 117 -- messages of Delete with deleted flag set to True, and also makes sure 118 -- that for the error messages that are retained the preferred message 119 -- is the one retained (we prefer the shorter one in the case where one 120 -- has an Instance tag). Note that we always know that Keep has at least 121 -- as many continuations as Delete (since we always delete the shorter 122 -- sequence). 123 124 ---------------- 125 -- Delete_Msg -- 126 ---------------- 127 128 procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is 129 D, K : Error_Msg_Id; 130 131 begin 132 D := Delete; 133 K := Keep; 134 135 loop 136 Errors.Table (D).Deleted := True; 137 138 -- Adjust error message count 139 140 if Errors.Table (D).Warn or else Errors.Table (D).Style then 141 Warnings_Detected := Warnings_Detected - 1; 142 143 else 144 Total_Errors_Detected := Total_Errors_Detected - 1; 145 146 if Errors.Table (D).Serious then 147 Serious_Errors_Detected := Serious_Errors_Detected - 1; 148 end if; 149 end if; 150 151 -- Substitute shorter of the two error messages 152 153 if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then 154 Errors.Table (K).Text := Errors.Table (D).Text; 155 end if; 156 157 D := Errors.Table (D).Next; 158 K := Errors.Table (K).Next; 159 160 if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then 161 return; 162 end if; 163 end loop; 164 end Delete_Msg; 165 166 -- Start of processing for Check_Duplicate_Message 167 168 begin 169 -- Both messages must be non-continuation messages and not deleted 170 171 if Errors.Table (M1).Msg_Cont 172 or else Errors.Table (M2).Msg_Cont 173 or else Errors.Table (M1).Deleted 174 or else Errors.Table (M2).Deleted 175 then 176 return; 177 end if; 178 179 -- Definitely not equal if message text does not match 180 181 if not Same_Error (M1, M2) then 182 return; 183 end if; 184 185 -- Same text. See if all continuations are also identical 186 187 L1 := M1; 188 L2 := M2; 189 190 loop 191 N1 := Errors.Table (L1).Next; 192 N2 := Errors.Table (L2).Next; 193 194 -- If M1 continuations have run out, we delete M1, either the 195 -- messages have the same number of continuations, or M2 has 196 -- more and we prefer the one with more anyway. 197 198 if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then 199 Delete_Msg (M1, M2); 200 return; 201 202 -- If M2 continuations have run out, we delete M2 203 204 elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then 205 Delete_Msg (M2, M1); 206 return; 207 208 -- Otherwise see if continuations are the same, if not, keep both 209 -- sequences, a curious case, but better to keep everything. 210 211 elsif not Same_Error (N1, N2) then 212 return; 213 214 -- If continuations are the same, continue scan 215 216 else 217 L1 := N1; 218 L2 := N2; 219 end if; 220 end loop; 221 end Check_Duplicate_Message; 222 223 ------------------------ 224 -- Compilation_Errors -- 225 ------------------------ 226 227 function Compilation_Errors return Boolean is 228 begin 229 return Total_Errors_Detected /= 0 230 or else (Warnings_Detected /= 0 231 and then Warning_Mode = Treat_As_Error) 232 or else Warnings_Treated_As_Errors /= 0; 233 end Compilation_Errors; 234 235 ------------------ 236 -- Debug_Output -- 237 ------------------ 238 239 procedure Debug_Output (N : Node_Id) is 240 begin 241 if Debug_Flag_1 then 242 Write_Str ("*** following error message posted on node id = #"); 243 Write_Int (Int (N)); 244 Write_Str (" ***"); 245 Write_Eol; 246 end if; 247 end Debug_Output; 248 249 ---------- 250 -- dmsg -- 251 ---------- 252 253 procedure dmsg (Id : Error_Msg_Id) is 254 E : Error_Msg_Object renames Errors.Table (Id); 255 256 begin 257 w ("Dumping error message, Id = ", Int (Id)); 258 w (" Text = ", E.Text.all); 259 w (" Next = ", Int (E.Next)); 260 w (" Sfile = ", Int (E.Sfile)); 261 262 Write_Str 263 (" Sptr = "); 264 Write_Location (E.Sptr); 265 Write_Eol; 266 267 Write_Str 268 (" Optr = "); 269 Write_Location (E.Optr); 270 Write_Eol; 271 272 w (" Line = ", Int (E.Line)); 273 w (" Col = ", Int (E.Col)); 274 w (" Warn = ", E.Warn); 275 w (" Style = ", E.Style); 276 w (" Serious = ", E.Serious); 277 w (" Uncond = ", E.Uncond); 278 w (" Msg_Cont = ", E.Msg_Cont); 279 w (" Deleted = ", E.Deleted); 280 281 Write_Eol; 282 end dmsg; 283 284 ------------------ 285 -- Get_Location -- 286 ------------------ 287 288 function Get_Location (E : Error_Msg_Id) return Source_Ptr is 289 begin 290 return Errors.Table (E).Sptr; 291 end Get_Location; 292 293 ---------------- 294 -- Get_Msg_Id -- 295 ---------------- 296 297 function Get_Msg_Id return Error_Msg_Id is 298 begin 299 return Cur_Msg; 300 end Get_Msg_Id; 301 302 --------------------- 303 -- Get_Warning_Tag -- 304 --------------------- 305 306 function Get_Warning_Tag (Id : Error_Msg_Id) return String is 307 Warn : constant Boolean := Errors.Table (Id).Warn; 308 Warn_Chr : constant Character := Errors.Table (Id).Warn_Chr; 309 begin 310 if Warn and then Warn_Chr /= ' ' then 311 if Warn_Chr = '?' then 312 return "[enabled by default]"; 313 elsif Warn_Chr in 'a' .. 'z' then 314 return "[-gnatw" & Warn_Chr & ']'; 315 else pragma Assert (Warn_Chr in 'A' .. 'Z'); 316 return "[-gnatw." & Fold_Lower (Warn_Chr) & ']'; 317 end if; 318 else 319 return ""; 320 end if; 321 end Get_Warning_Tag; 322 323 ------------- 324 -- Matches -- 325 ------------- 326 327 function Matches (S : String; P : String) return Boolean is 328 Slast : constant Natural := S'Last; 329 PLast : constant Natural := P'Last; 330 331 SPtr : Natural := S'First; 332 PPtr : Natural := P'First; 333 334 begin 335 -- Loop advancing through characters of string and pattern 336 337 SPtr := S'First; 338 PPtr := P'First; 339 loop 340 -- Return True if pattern is a single asterisk 341 342 if PPtr = PLast and then P (PPtr) = '*' then 343 return True; 344 345 -- Return True if both pattern and string exhausted 346 347 elsif PPtr > PLast and then SPtr > Slast then 348 return True; 349 350 -- Return False, if one exhausted and not the other 351 352 elsif PPtr > PLast or else SPtr > Slast then 353 return False; 354 355 -- Case where pattern starts with asterisk 356 357 elsif P (PPtr) = '*' then 358 359 -- Try all possible starting positions in S for match with the 360 -- remaining characters of the pattern. This is the recursive 361 -- call that implements the scanner backup. 362 363 for J in SPtr .. Slast loop 364 if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then 365 return True; 366 end if; 367 end loop; 368 369 return False; 370 371 -- Dealt with end of string and *, advance if we have a match 372 373 elsif Fold_Lower (S (SPtr)) = Fold_Lower (P (PPtr)) then 374 SPtr := SPtr + 1; 375 PPtr := PPtr + 1; 376 377 -- If first characters do not match, that's decisive 378 379 else 380 return False; 381 end if; 382 end loop; 383 end Matches; 384 385 ----------------------- 386 -- Output_Error_Msgs -- 387 ----------------------- 388 389 procedure Output_Error_Msgs (E : in out Error_Msg_Id) is 390 P : Source_Ptr; 391 T : Error_Msg_Id; 392 S : Error_Msg_Id; 393 394 Flag_Num : Pos; 395 Mult_Flags : Boolean := False; 396 397 begin 398 S := E; 399 400 -- Skip deleted messages at start 401 402 if Errors.Table (S).Deleted then 403 Set_Next_Non_Deleted_Msg (S); 404 end if; 405 406 -- Figure out if we will place more than one error flag on this line 407 408 T := S; 409 while T /= No_Error_Msg 410 and then Errors.Table (T).Line = Errors.Table (E).Line 411 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile 412 loop 413 if Errors.Table (T).Sptr > Errors.Table (E).Sptr then 414 Mult_Flags := True; 415 end if; 416 417 Set_Next_Non_Deleted_Msg (T); 418 end loop; 419 420 -- Output the error flags. The circuit here makes sure that the tab 421 -- characters in the original line are properly accounted for. The 422 -- eight blanks at the start are to match the line number. 423 424 if not Debug_Flag_2 then 425 Write_Str (" "); 426 P := Line_Start (Errors.Table (E).Sptr); 427 Flag_Num := 1; 428 429 -- Loop through error messages for this line to place flags 430 431 T := S; 432 while T /= No_Error_Msg 433 and then Errors.Table (T).Line = Errors.Table (E).Line 434 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile 435 loop 436 -- Loop to output blanks till current flag position 437 438 while P < Errors.Table (T).Sptr loop 439 if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then 440 Write_Char (ASCII.HT); 441 else 442 Write_Char (' '); 443 end if; 444 445 P := P + 1; 446 end loop; 447 448 -- Output flag (unless already output, this happens if more 449 -- than one error message occurs at the same flag position). 450 451 if P = Errors.Table (T).Sptr then 452 if (Flag_Num = 1 and then not Mult_Flags) 453 or else Flag_Num > 9 454 then 455 Write_Char ('|'); 456 else 457 Write_Char (Character'Val (Character'Pos ('0') + Flag_Num)); 458 end if; 459 460 P := P + 1; 461 end if; 462 463 Set_Next_Non_Deleted_Msg (T); 464 Flag_Num := Flag_Num + 1; 465 end loop; 466 467 Write_Eol; 468 end if; 469 470 -- Now output the error messages 471 472 T := S; 473 while T /= No_Error_Msg 474 and then Errors.Table (T).Line = Errors.Table (E).Line 475 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile 476 loop 477 Write_Str (" >>> "); 478 Output_Msg_Text (T); 479 480 if Debug_Flag_2 then 481 while Column < 74 loop 482 Write_Char (' '); 483 end loop; 484 485 Write_Str (" <<<"); 486 end if; 487 488 Write_Eol; 489 Set_Next_Non_Deleted_Msg (T); 490 end loop; 491 492 E := T; 493 end Output_Error_Msgs; 494 495 ------------------------ 496 -- Output_Line_Number -- 497 ------------------------ 498 499 procedure Output_Line_Number (L : Logical_Line_Number) is 500 D : Int; -- next digit 501 C : Character; -- next character 502 Z : Boolean; -- flag for zero suppress 503 N, M : Int; -- temporaries 504 505 begin 506 if L = No_Line_Number then 507 Write_Str (" "); 508 509 else 510 Z := False; 511 N := Int (L); 512 513 M := 100_000; 514 while M /= 0 loop 515 D := Int (N / M); 516 N := N rem M; 517 M := M / 10; 518 519 if D = 0 then 520 if Z then 521 C := '0'; 522 else 523 C := ' '; 524 end if; 525 else 526 Z := True; 527 C := Character'Val (D + 48); 528 end if; 529 530 Write_Char (C); 531 end loop; 532 533 Write_Str (". "); 534 end if; 535 end Output_Line_Number; 536 537 --------------------- 538 -- Output_Msg_Text -- 539 --------------------- 540 541 procedure Output_Msg_Text (E : Error_Msg_Id) is 542 Offs : constant Nat := Column - 1; 543 -- Offset to start of message, used for continuations 544 545 Max : Integer; 546 -- Maximum characters to output on next line 547 548 Length : Nat; 549 -- Maximum total length of lines 550 551 Text : constant String_Ptr := Errors.Table (E).Text; 552 Ptr : Natural; 553 Split : Natural; 554 Start : Natural; 555 556 begin 557 declare 558 Tag : constant String := Get_Warning_Tag (E); 559 Txt : String_Ptr; 560 Len : Natural; 561 562 begin 563 -- Postfix warning tag to message if needed 564 565 if Tag /= "" and then Warning_Doc_Switch then 566 Txt := new String'(Text.all & ' ' & Tag); 567 else 568 Txt := Text; 569 end if; 570 571 -- Deal with warning case 572 573 if Errors.Table (E).Warn then 574 575 -- Nothing to do with info messages, "info " already set 576 577 if Txt'Length >= 6 578 and then Txt (Txt'First .. Txt'First + 5) = "info: " 579 then 580 null; 581 582 -- Warning treated as error 583 584 elsif Errors.Table (E).Warn_Err then 585 586 -- We prefix the tag error: rather than warning: and postfix 587 -- [warning-as-error] at the end. 588 589 Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1; 590 Txt := new String'("error: " & Txt.all & " [warning-as-error]"); 591 592 -- Normal case, prefix 593 594 else 595 Txt := new String'("warning: " & Txt.all); 596 end if; 597 598 -- No prefix needed for style message, "(style)" is there already 599 600 elsif Errors.Table (E).Style then 601 null; 602 603 -- All other cases, add "error: " if unique error tag set 604 605 elsif Opt.Unique_Error_Tag then 606 Txt := new String'("error: " & Txt.all); 607 end if; 608 609 -- Set error message line length and length of message 610 611 if Error_Msg_Line_Length = 0 then 612 Length := Nat'Last; 613 else 614 Length := Error_Msg_Line_Length; 615 end if; 616 617 Max := Integer (Length - Column + 1); 618 Len := Txt'Length; 619 620 -- Here we have to split the message up into multiple lines 621 622 Ptr := 1; 623 loop 624 -- Make sure we do not have ludicrously small line 625 626 Max := Integer'Max (Max, 20); 627 628 -- If remaining text fits, output it respecting LF and we are done 629 630 if Len - Ptr < Max then 631 for J in Ptr .. Len loop 632 if Txt (J) = ASCII.LF then 633 Write_Eol; 634 Write_Spaces (Offs); 635 else 636 Write_Char (Txt (J)); 637 end if; 638 end loop; 639 640 return; 641 642 -- Line does not fit 643 644 else 645 Start := Ptr; 646 647 -- First scan forward looking for a hard end of line 648 649 for Scan in Ptr .. Ptr + Max - 1 loop 650 if Txt (Scan) = ASCII.LF then 651 Split := Scan - 1; 652 Ptr := Scan + 1; 653 goto Continue; 654 end if; 655 end loop; 656 657 -- Otherwise scan backwards looking for a space 658 659 for Scan in reverse Ptr .. Ptr + Max - 1 loop 660 if Txt (Scan) = ' ' then 661 Split := Scan - 1; 662 Ptr := Scan + 1; 663 goto Continue; 664 end if; 665 end loop; 666 667 -- If we fall through, no space, so split line arbitrarily 668 669 Split := Ptr + Max - 1; 670 Ptr := Split + 1; 671 end if; 672 673 <<Continue>> 674 if Start <= Split then 675 Write_Line (Txt (Start .. Split)); 676 Write_Spaces (Offs); 677 end if; 678 679 Max := Integer (Length - Column + 1); 680 end loop; 681 end; 682 end Output_Msg_Text; 683 684 -------------------- 685 -- Purge_Messages -- 686 -------------------- 687 688 procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is 689 E : Error_Msg_Id; 690 691 function To_Be_Purged (E : Error_Msg_Id) return Boolean; 692 -- Returns True for a message that is to be purged. Also adjusts 693 -- error counts appropriately. 694 695 ------------------ 696 -- To_Be_Purged -- 697 ------------------ 698 699 function To_Be_Purged (E : Error_Msg_Id) return Boolean is 700 begin 701 if E /= No_Error_Msg 702 and then Errors.Table (E).Sptr > From 703 and then Errors.Table (E).Sptr < To 704 then 705 if Errors.Table (E).Warn or else Errors.Table (E).Style then 706 Warnings_Detected := Warnings_Detected - 1; 707 708 else 709 Total_Errors_Detected := Total_Errors_Detected - 1; 710 711 if Errors.Table (E).Serious then 712 Serious_Errors_Detected := Serious_Errors_Detected - 1; 713 end if; 714 end if; 715 716 return True; 717 718 else 719 return False; 720 end if; 721 end To_Be_Purged; 722 723 -- Start of processing for Purge_Messages 724 725 begin 726 while To_Be_Purged (First_Error_Msg) loop 727 First_Error_Msg := Errors.Table (First_Error_Msg).Next; 728 end loop; 729 730 E := First_Error_Msg; 731 while E /= No_Error_Msg loop 732 while To_Be_Purged (Errors.Table (E).Next) loop 733 Errors.Table (E).Next := 734 Errors.Table (Errors.Table (E).Next).Next; 735 end loop; 736 737 E := Errors.Table (E).Next; 738 end loop; 739 end Purge_Messages; 740 741 ---------------- 742 -- Same_Error -- 743 ---------------- 744 745 function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is 746 Msg1 : constant String_Ptr := Errors.Table (M1).Text; 747 Msg2 : constant String_Ptr := Errors.Table (M2).Text; 748 749 Msg2_Len : constant Integer := Msg2'Length; 750 Msg1_Len : constant Integer := Msg1'Length; 751 752 begin 753 return 754 Msg1.all = Msg2.all 755 or else 756 (Msg1_Len - 10 > Msg2_Len 757 and then 758 Msg2.all = Msg1.all (1 .. Msg2_Len) 759 and then 760 Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance") 761 or else 762 (Msg2_Len - 10 > Msg1_Len 763 and then 764 Msg1.all = Msg2.all (1 .. Msg1_Len) 765 and then 766 Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance"); 767 end Same_Error; 768 769 ------------------- 770 -- Set_Msg_Blank -- 771 ------------------- 772 773 procedure Set_Msg_Blank is 774 begin 775 if Msglen > 0 776 and then Msg_Buffer (Msglen) /= ' ' 777 and then Msg_Buffer (Msglen) /= '(' 778 and then Msg_Buffer (Msglen) /= '-' 779 and then not Manual_Quote_Mode 780 then 781 Set_Msg_Char (' '); 782 end if; 783 end Set_Msg_Blank; 784 785 ------------------------------- 786 -- Set_Msg_Blank_Conditional -- 787 ------------------------------- 788 789 procedure Set_Msg_Blank_Conditional is 790 begin 791 if Msglen > 0 792 and then Msg_Buffer (Msglen) /= ' ' 793 and then Msg_Buffer (Msglen) /= '(' 794 and then Msg_Buffer (Msglen) /= '"' 795 and then not Manual_Quote_Mode 796 then 797 Set_Msg_Char (' '); 798 end if; 799 end Set_Msg_Blank_Conditional; 800 801 ------------------ 802 -- Set_Msg_Char -- 803 ------------------ 804 805 procedure Set_Msg_Char (C : Character) is 806 begin 807 808 -- The check for message buffer overflow is needed to deal with cases 809 -- where insertions get too long (in particular a child unit name can 810 -- be very long). 811 812 if Msglen < Max_Msg_Length then 813 Msglen := Msglen + 1; 814 Msg_Buffer (Msglen) := C; 815 end if; 816 end Set_Msg_Char; 817 818 --------------------------------- 819 -- Set_Msg_Insertion_File_Name -- 820 --------------------------------- 821 822 procedure Set_Msg_Insertion_File_Name is 823 begin 824 if Error_Msg_File_1 = No_File then 825 null; 826 827 elsif Error_Msg_File_1 = Error_File_Name then 828 Set_Msg_Blank; 829 Set_Msg_Str ("<error>"); 830 831 else 832 Set_Msg_Blank; 833 Get_Name_String (Error_Msg_File_1); 834 Set_Msg_Quote; 835 Set_Msg_Name_Buffer; 836 Set_Msg_Quote; 837 end if; 838 839 -- The following assignments ensure that the second and third { 840 -- insertion characters will correspond to the Error_Msg_File_2 and 841 -- Error_Msg_File_3 values and We suppress possible validity checks in 842 -- case operating in -gnatVa mode, and Error_Msg_File_2 or 843 -- Error_Msg_File_3 is not needed and has not been set. 844 845 declare 846 pragma Suppress (Range_Check); 847 begin 848 Error_Msg_File_1 := Error_Msg_File_2; 849 Error_Msg_File_2 := Error_Msg_File_3; 850 end; 851 end Set_Msg_Insertion_File_Name; 852 853 ----------------------------------- 854 -- Set_Msg_Insertion_Line_Number -- 855 ----------------------------------- 856 857 procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is 858 Sindex_Loc : Source_File_Index; 859 Sindex_Flag : Source_File_Index; 860 861 procedure Set_At; 862 -- Outputs "at " unless last characters in buffer are " from ". Certain 863 -- messages read better with from than at. 864 865 ------------ 866 -- Set_At -- 867 ------------ 868 869 procedure Set_At is 870 begin 871 if Msglen < 6 872 or else Msg_Buffer (Msglen - 5 .. Msglen) /= " from " 873 then 874 Set_Msg_Str ("at "); 875 end if; 876 end Set_At; 877 878 -- Start of processing for Set_Msg_Insertion_Line_Number 879 880 begin 881 Set_Msg_Blank; 882 883 if Loc = No_Location then 884 Set_At; 885 Set_Msg_Str ("unknown location"); 886 887 elsif Loc = System_Location then 888 Set_Msg_Str ("in package System"); 889 Set_Msg_Insertion_Run_Time_Name; 890 891 elsif Loc = Standard_Location then 892 Set_Msg_Str ("in package Standard"); 893 894 elsif Loc = Standard_ASCII_Location then 895 Set_Msg_Str ("in package Standard.ASCII"); 896 897 else 898 -- Add "at file-name:" if reference is to other than the source 899 -- file in which the error message is placed. Note that we check 900 -- full file names, rather than just the source indexes, to 901 -- deal with generic instantiations from the current file. 902 903 Sindex_Loc := Get_Source_File_Index (Loc); 904 Sindex_Flag := Get_Source_File_Index (Flag); 905 906 if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then 907 Set_At; 908 Get_Name_String 909 (Reference_Name (Get_Source_File_Index (Loc))); 910 Set_Msg_Name_Buffer; 911 Set_Msg_Char (':'); 912 913 -- If in current file, add text "at line " 914 915 else 916 Set_At; 917 Set_Msg_Str ("line "); 918 end if; 919 920 -- Output line number for reference 921 922 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc))); 923 924 -- Deal with the instantiation case. We may have a reference to, 925 -- e.g. a type, that is declared within a generic template, and 926 -- what we are really referring to is the occurrence in an instance. 927 -- In this case, the line number of the instantiation is also of 928 -- interest, and we add a notation: 929 930 -- , instance at xxx 931 932 -- where xxx is a line number output using this same routine (and 933 -- the recursion can go further if the instantiation is itself in 934 -- a generic template). 935 936 -- The flag location passed to us in this situation is indeed the 937 -- line number within the template, but as described in Sinput.L 938 -- (file sinput-l.ads, section "Handling Generic Instantiations") 939 -- we can retrieve the location of the instantiation itself from 940 -- this flag location value. 941 942 -- Note: this processing is suppressed if Suppress_Instance_Location 943 -- is set True. This is used to prevent redundant annotations of the 944 -- location of the instantiation in the case where we are placing 945 -- the messages on the instantiation in any case. 946 947 if Instantiation (Sindex_Loc) /= No_Location 948 and then not Suppress_Instance_Location 949 then 950 Set_Msg_Str (", instance "); 951 Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag); 952 end if; 953 end if; 954 end Set_Msg_Insertion_Line_Number; 955 956 ---------------------------- 957 -- Set_Msg_Insertion_Name -- 958 ---------------------------- 959 960 procedure Set_Msg_Insertion_Name is 961 begin 962 if Error_Msg_Name_1 = No_Name then 963 null; 964 965 elsif Error_Msg_Name_1 = Error_Name then 966 Set_Msg_Blank; 967 Set_Msg_Str ("<error>"); 968 969 else 970 Set_Msg_Blank_Conditional; 971 Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1); 972 973 -- Remove %s or %b at end. These come from unit names. If the 974 -- caller wanted the (unit) or (body), then they would have used 975 -- the $ insertion character. Certainly no error message should 976 -- ever have %b or %s explicitly occurring. 977 978 if Name_Len > 2 979 and then Name_Buffer (Name_Len - 1) = '%' 980 and then (Name_Buffer (Name_Len) = 'b' 981 or else 982 Name_Buffer (Name_Len) = 's') 983 then 984 Name_Len := Name_Len - 2; 985 end if; 986 987 -- Remove upper case letter at end, again, we should not be getting 988 -- such names, and what we hope is that the remainder makes sense. 989 990 if Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' then 991 Name_Len := Name_Len - 1; 992 end if; 993 994 -- If operator name or character literal name, just print it as is 995 -- Also print as is if it ends in a right paren (case of x'val(nnn)) 996 997 if Name_Buffer (1) = '"' 998 or else Name_Buffer (1) = ''' 999 or else Name_Buffer (Name_Len) = ')' 1000 then 1001 Set_Msg_Name_Buffer; 1002 1003 -- Else output with surrounding quotes in proper casing mode 1004 1005 else 1006 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); 1007 Set_Msg_Quote; 1008 Set_Msg_Name_Buffer; 1009 Set_Msg_Quote; 1010 end if; 1011 end if; 1012 1013 -- The following assignments ensure that the second and third percent 1014 -- insertion characters will correspond to the Error_Msg_Name_2 and 1015 -- Error_Msg_Name_3 as required. We suppress possible validity checks in 1016 -- case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed 1017 -- and has not been set. 1018 1019 declare 1020 pragma Suppress (Range_Check); 1021 begin 1022 Error_Msg_Name_1 := Error_Msg_Name_2; 1023 Error_Msg_Name_2 := Error_Msg_Name_3; 1024 end; 1025 end Set_Msg_Insertion_Name; 1026 1027 ------------------------------------ 1028 -- Set_Msg_Insertion_Name_Literal -- 1029 ------------------------------------ 1030 1031 procedure Set_Msg_Insertion_Name_Literal is 1032 begin 1033 if Error_Msg_Name_1 = No_Name then 1034 null; 1035 1036 elsif Error_Msg_Name_1 = Error_Name then 1037 Set_Msg_Blank; 1038 Set_Msg_Str ("<error>"); 1039 1040 else 1041 Set_Msg_Blank; 1042 Get_Name_String (Error_Msg_Name_1); 1043 Set_Msg_Quote; 1044 Set_Msg_Name_Buffer; 1045 Set_Msg_Quote; 1046 end if; 1047 1048 -- The following assignments ensure that the second and third % or %% 1049 -- insertion characters will correspond to the Error_Msg_Name_2 and 1050 -- Error_Msg_Name_3 values and We suppress possible validity checks in 1051 -- case operating in -gnatVa mode, and Error_Msg_Name_2 or 1052 -- Error_Msg_Name_3 is not needed and has not been set. 1053 1054 declare 1055 pragma Suppress (Range_Check); 1056 begin 1057 Error_Msg_Name_1 := Error_Msg_Name_2; 1058 Error_Msg_Name_2 := Error_Msg_Name_3; 1059 end; 1060 end Set_Msg_Insertion_Name_Literal; 1061 1062 ------------------------------------- 1063 -- Set_Msg_Insertion_Reserved_Name -- 1064 ------------------------------------- 1065 1066 procedure Set_Msg_Insertion_Reserved_Name is 1067 begin 1068 Set_Msg_Blank_Conditional; 1069 Get_Name_String (Error_Msg_Name_1); 1070 Set_Msg_Quote; 1071 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case); 1072 Set_Msg_Name_Buffer; 1073 Set_Msg_Quote; 1074 end Set_Msg_Insertion_Reserved_Name; 1075 1076 ------------------------------------- 1077 -- Set_Msg_Insertion_Reserved_Word -- 1078 ------------------------------------- 1079 1080 procedure Set_Msg_Insertion_Reserved_Word 1081 (Text : String; 1082 J : in out Integer) 1083 is 1084 begin 1085 Set_Msg_Blank_Conditional; 1086 Name_Len := 0; 1087 1088 while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop 1089 Add_Char_To_Name_Buffer (Text (J)); 1090 J := J + 1; 1091 end loop; 1092 1093 -- Here is where we make the special exception for RM 1094 1095 if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then 1096 Set_Msg_Name_Buffer; 1097 1098 -- We make a similar exception for SPARK 1099 1100 elsif Name_Len = 5 and then Name_Buffer (1 .. 5) = "SPARK" then 1101 Set_Msg_Name_Buffer; 1102 1103 -- Neither RM nor SPARK: case appropriately and add surrounding quotes 1104 1105 else 1106 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case); 1107 Set_Msg_Quote; 1108 Set_Msg_Name_Buffer; 1109 Set_Msg_Quote; 1110 end if; 1111 end Set_Msg_Insertion_Reserved_Word; 1112 1113 ------------------------------------- 1114 -- Set_Msg_Insertion_Run_Time_Name -- 1115 ------------------------------------- 1116 1117 procedure Set_Msg_Insertion_Run_Time_Name is 1118 begin 1119 if Targparm.Run_Time_Name_On_Target /= No_Name then 1120 Set_Msg_Blank_Conditional; 1121 Set_Msg_Char ('('); 1122 Get_Name_String (Targparm.Run_Time_Name_On_Target); 1123 Set_Casing (Mixed_Case); 1124 Set_Msg_Str (Name_Buffer (1 .. Name_Len)); 1125 Set_Msg_Char (')'); 1126 end if; 1127 end Set_Msg_Insertion_Run_Time_Name; 1128 1129 ---------------------------- 1130 -- Set_Msg_Insertion_Uint -- 1131 ---------------------------- 1132 1133 procedure Set_Msg_Insertion_Uint is 1134 begin 1135 Set_Msg_Blank; 1136 UI_Image (Error_Msg_Uint_1); 1137 1138 for J in 1 .. UI_Image_Length loop 1139 Set_Msg_Char (UI_Image_Buffer (J)); 1140 end loop; 1141 1142 -- The following assignment ensures that a second caret insertion 1143 -- character will correspond to the Error_Msg_Uint_2 parameter. We 1144 -- suppress possible validity checks in case operating in -gnatVa mode, 1145 -- and Error_Msg_Uint_2 is not needed and has not been set. 1146 1147 declare 1148 pragma Suppress (Range_Check); 1149 begin 1150 Error_Msg_Uint_1 := Error_Msg_Uint_2; 1151 end; 1152 end Set_Msg_Insertion_Uint; 1153 1154 ----------------- 1155 -- Set_Msg_Int -- 1156 ----------------- 1157 1158 procedure Set_Msg_Int (Line : Int) is 1159 begin 1160 if Line > 9 then 1161 Set_Msg_Int (Line / 10); 1162 end if; 1163 1164 Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10))); 1165 end Set_Msg_Int; 1166 1167 ------------------------- 1168 -- Set_Msg_Name_Buffer -- 1169 ------------------------- 1170 1171 procedure Set_Msg_Name_Buffer is 1172 begin 1173 for J in 1 .. Name_Len loop 1174 Set_Msg_Char (Name_Buffer (J)); 1175 end loop; 1176 end Set_Msg_Name_Buffer; 1177 1178 ------------------- 1179 -- Set_Msg_Quote -- 1180 ------------------- 1181 1182 procedure Set_Msg_Quote is 1183 begin 1184 if not Manual_Quote_Mode then 1185 Set_Msg_Char ('"'); 1186 end if; 1187 end Set_Msg_Quote; 1188 1189 ----------------- 1190 -- Set_Msg_Str -- 1191 ----------------- 1192 1193 procedure Set_Msg_Str (Text : String) is 1194 begin 1195 for J in Text'Range loop 1196 Set_Msg_Char (Text (J)); 1197 end loop; 1198 end Set_Msg_Str; 1199 1200 ------------------------------ 1201 -- Set_Next_Non_Deleted_Msg -- 1202 ------------------------------ 1203 1204 procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is 1205 begin 1206 if E = No_Error_Msg then 1207 return; 1208 1209 else 1210 loop 1211 E := Errors.Table (E).Next; 1212 exit when E = No_Error_Msg or else not Errors.Table (E).Deleted; 1213 end loop; 1214 end if; 1215 end Set_Next_Non_Deleted_Msg; 1216 1217 ------------------------------ 1218 -- Set_Specific_Warning_Off -- 1219 ------------------------------ 1220 1221 procedure Set_Specific_Warning_Off 1222 (Loc : Source_Ptr; 1223 Msg : String; 1224 Reason : String_Id; 1225 Config : Boolean; 1226 Used : Boolean := False) 1227 is 1228 begin 1229 Specific_Warnings.Append 1230 ((Start => Loc, 1231 Msg => new String'(Msg), 1232 Stop => Source_Last (Current_Source_File), 1233 Reason => Reason, 1234 Open => True, 1235 Used => Used, 1236 Config => Config)); 1237 end Set_Specific_Warning_Off; 1238 1239 ----------------------------- 1240 -- Set_Specific_Warning_On -- 1241 ----------------------------- 1242 1243 procedure Set_Specific_Warning_On 1244 (Loc : Source_Ptr; 1245 Msg : String; 1246 Err : out Boolean) 1247 is 1248 begin 1249 for J in 1 .. Specific_Warnings.Last loop 1250 declare 1251 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J); 1252 begin 1253 if Msg = SWE.Msg.all 1254 and then Loc > SWE.Start 1255 and then SWE.Open 1256 and then Get_Source_File_Index (SWE.Start) = 1257 Get_Source_File_Index (Loc) 1258 then 1259 SWE.Stop := Loc; 1260 SWE.Open := False; 1261 Err := False; 1262 1263 -- If a config pragma is specifically cancelled, consider 1264 -- that it is no longer active as a configuration pragma. 1265 1266 SWE.Config := False; 1267 return; 1268 end if; 1269 end; 1270 end loop; 1271 1272 Err := True; 1273 end Set_Specific_Warning_On; 1274 1275 --------------------------- 1276 -- Set_Warnings_Mode_Off -- 1277 --------------------------- 1278 1279 procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id) is 1280 begin 1281 -- Don't bother with entries from instantiation copies, since we will 1282 -- already have a copy in the template, which is what matters. 1283 1284 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then 1285 return; 1286 end if; 1287 1288 -- If all warnings are suppressed by command line switch, this can 1289 -- be ignored, unless we are in GNATprove_Mode which requires pragma 1290 -- Warnings to be stored for the formal verification backend. 1291 1292 if Warning_Mode = Suppress 1293 and then not GNATprove_Mode 1294 then 1295 return; 1296 end if; 1297 1298 -- If last entry in table already covers us, this is a redundant pragma 1299 -- Warnings (Off) and can be ignored. 1300 1301 if Warnings.Last >= Warnings.First 1302 and then Warnings.Table (Warnings.Last).Start <= Loc 1303 and then Loc <= Warnings.Table (Warnings.Last).Stop 1304 then 1305 return; 1306 end if; 1307 1308 -- If none of those special conditions holds, establish a new entry, 1309 -- extending from the location of the pragma to the end of the current 1310 -- source file. This ending point will be adjusted by a subsequent 1311 -- corresponding pragma Warnings (On). 1312 1313 Warnings.Append 1314 ((Start => Loc, 1315 Stop => Source_Last (Current_Source_File), 1316 Reason => Reason)); 1317 end Set_Warnings_Mode_Off; 1318 1319 -------------------------- 1320 -- Set_Warnings_Mode_On -- 1321 -------------------------- 1322 1323 procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is 1324 begin 1325 -- Don't bother with entries from instantiation copies, since we will 1326 -- already have a copy in the template, which is what matters. 1327 1328 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then 1329 return; 1330 end if; 1331 1332 -- If all warnings are suppressed by command line switch, this can 1333 -- be ignored, unless we are in GNATprove_Mode which requires pragma 1334 -- Warnings to be stored for the formal verification backend. 1335 1336 if Warning_Mode = Suppress 1337 and then not GNATprove_Mode 1338 then 1339 return; 1340 end if; 1341 1342 -- If the last entry in the warnings table covers this pragma, then 1343 -- we adjust the end point appropriately. 1344 1345 if Warnings.Last >= Warnings.First 1346 and then Warnings.Table (Warnings.Last).Start <= Loc 1347 and then Loc <= Warnings.Table (Warnings.Last).Stop 1348 then 1349 Warnings.Table (Warnings.Last).Stop := Loc; 1350 end if; 1351 end Set_Warnings_Mode_On; 1352 1353 ------------------------------------ 1354 -- Test_Style_Warning_Serious_Msg -- 1355 ------------------------------------ 1356 1357 procedure Test_Style_Warning_Serious_Unconditional_Msg (Msg : String) is 1358 begin 1359 -- Nothing to do for continuation line 1360 1361 if Msg (Msg'First) = '\' then 1362 return; 1363 end if; 1364 1365 -- Set initial values of globals (may be changed during scan) 1366 1367 Is_Serious_Error := True; 1368 Is_Unconditional_Msg := False; 1369 Is_Warning_Msg := False; 1370 Has_Double_Exclam := False; 1371 1372 Is_Style_Msg := 1373 (Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)"); 1374 1375 for J in Msg'Range loop 1376 if Msg (J) = '?' 1377 and then (J = Msg'First or else Msg (J - 1) /= ''') 1378 then 1379 Is_Warning_Msg := True; 1380 Warning_Msg_Char := ' '; 1381 1382 elsif Msg (J) = '!' 1383 and then (J = Msg'First or else Msg (J - 1) /= ''') 1384 then 1385 Is_Unconditional_Msg := True; 1386 Warning_Msg_Char := ' '; 1387 1388 if J < Msg'Last and then Msg (J + 1) = '!' then 1389 Has_Double_Exclam := True; 1390 end if; 1391 1392 elsif Msg (J) = '<' 1393 and then (J = Msg'First or else Msg (J - 1) /= ''') 1394 then 1395 Is_Warning_Msg := Error_Msg_Warn; 1396 Warning_Msg_Char := ' '; 1397 1398 elsif Msg (J) = '|' 1399 and then (J = Msg'First or else Msg (J - 1) /= ''') 1400 then 1401 Is_Serious_Error := False; 1402 end if; 1403 end loop; 1404 1405 if Is_Warning_Msg or Is_Style_Msg then 1406 Is_Serious_Error := False; 1407 end if; 1408 end Test_Style_Warning_Serious_Unconditional_Msg; 1409 1410 -------------------------------- 1411 -- Validate_Specific_Warnings -- 1412 -------------------------------- 1413 1414 procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is 1415 begin 1416 if not Warn_On_Warnings_Off then 1417 return; 1418 end if; 1419 1420 for J in Specific_Warnings.First .. Specific_Warnings.Last loop 1421 declare 1422 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J); 1423 1424 begin 1425 if not SWE.Config then 1426 1427 -- Warn for unmatched Warnings (Off, ...) 1428 1429 if SWE.Open then 1430 Eproc.all 1431 ("?W?pragma Warnings Off with no matching Warnings On", 1432 SWE.Start); 1433 1434 -- Warn for ineffective Warnings (Off, ..) 1435 1436 elsif not SWE.Used 1437 1438 -- Do not issue this warning for -Wxxx messages since the 1439 -- back-end doesn't report the information. 1440 1441 and then not 1442 (SWE.Msg'Length > 2 and then SWE.Msg (1 .. 2) = "-W") 1443 then 1444 Eproc.all 1445 ("?W?no warning suppressed by this pragma", SWE.Start); 1446 end if; 1447 end if; 1448 end; 1449 end loop; 1450 end Validate_Specific_Warnings; 1451 1452 ------------------------------------- 1453 -- Warning_Specifically_Suppressed -- 1454 ------------------------------------- 1455 1456 function Warning_Specifically_Suppressed 1457 (Loc : Source_Ptr; 1458 Msg : String_Ptr) return String_Id 1459 is 1460 begin 1461 -- Loop through specific warning suppression entries 1462 1463 for J in Specific_Warnings.First .. Specific_Warnings.Last loop 1464 declare 1465 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J); 1466 1467 begin 1468 -- Pragma applies if it is a configuration pragma, or if the 1469 -- location is in range of a specific non-configuration pragma. 1470 1471 if SWE.Config 1472 or else (SWE.Start <= Loc and then Loc <= SWE.Stop) 1473 then 1474 if Matches (Msg.all, SWE.Msg.all) then 1475 SWE.Used := True; 1476 return SWE.Reason; 1477 end if; 1478 end if; 1479 end; 1480 end loop; 1481 1482 return No_String; 1483 end Warning_Specifically_Suppressed; 1484 1485 ------------------------------ 1486 -- Warning_Treated_As_Error -- 1487 ------------------------------ 1488 1489 function Warning_Treated_As_Error (Msg : String) return Boolean is 1490 begin 1491 for J in 1 .. Warnings_As_Errors_Count loop 1492 if Matches (Msg, Warnings_As_Errors (J).all) then 1493 return True; 1494 end if; 1495 end loop; 1496 1497 return False; 1498 end Warning_Treated_As_Error; 1499 1500 ------------------------- 1501 -- Warnings_Suppressed -- 1502 ------------------------- 1503 1504 function Warnings_Suppressed (Loc : Source_Ptr) return String_Id is 1505 begin 1506 -- Loop through table of ON/OFF warnings 1507 1508 for J in Warnings.First .. Warnings.Last loop 1509 if Warnings.Table (J).Start <= Loc 1510 and then Loc <= Warnings.Table (J).Stop 1511 then 1512 return Warnings.Table (J).Reason; 1513 end if; 1514 end loop; 1515 1516 if Warning_Mode = Suppress then 1517 return Null_String_Id; 1518 else 1519 return No_String; 1520 end if; 1521 end Warnings_Suppressed; 1522 1523end Erroutc; 1524