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