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