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