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