gcc/ada/erroutc.adb

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