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