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