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