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