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