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