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