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