gcc/ada/erroutc.adb

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