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