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