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