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-2007, 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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 --  Warning! Error messages can be generated during Gigi processing by direct
  28 --  calls to error message routines, so it is essential that the processing
  29 --  in this body be consistent with the requirements for the Gigi processing
  30 --  environment, and that in particular, no disallowed table expansion is
  31 --  allowed to occur.
  32
  33 with Casing;   use Casing;
  34 with Debug;    use Debug;
  35 with Err_Vars; use Err_Vars;
  36 with Namet;    use Namet;
  37 with Opt;      use Opt;
  38 with Output;   use Output;
  39 with Sinput;   use Sinput;
  40 with Snames;   use Snames;
  41 with Targparm; use Targparm;
  42 with Uintp;    use Uintp;
  43
  44 package body Erroutc is
  45
  46    ---------------
  47    -- Add_Class --
  48    ---------------
  49
  50    procedure Add_Class is
  51    begin
  52       if Class_Flag then
  53          Class_Flag := False;
  54          Set_Msg_Char (''');
  55          Get_Name_String (Name_Class);
  56          Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
  57          Set_Msg_Name_Buffer;
  58       end if;
  59    end Add_Class;
  60
  61    ----------------------
  62    -- Buffer_Ends_With --
  63    ----------------------
  64
  65    function Buffer_Ends_With (S : String) return Boolean is
  66       Len : constant Natural := S'Length;
  67    begin
  68       return
  69         Msglen > Len
  70           and then Msg_Buffer (Msglen - Len) = ' '
  71           and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S;
  72    end Buffer_Ends_With;
  73
  74    -------------------
  75    -- Buffer_Remove --
  76    -------------------
  77
  78    procedure Buffer_Remove (S : String) is
  79    begin
  80       if Buffer_Ends_With (S) then
  81          Msglen := Msglen - S'Length;
  82       end if;
  83    end Buffer_Remove;
  84
  85    -----------------------------
  86    -- Check_Duplicate_Message --
  87    -----------------------------
  88
  89    procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
  90       L1, L2 : Error_Msg_Id;
  91       N1, N2 : Error_Msg_Id;
  92
  93       procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
  94       --  Called to delete message Delete, keeping message Keep. Marks
  95       --  all messages of Delete with deleted flag set to True, and also
  96       --  makes sure that for the error messages that are retained the
  97       --  preferred message is the one retained (we prefer the shorter
  98       --  one in the case where one has an Instance tag). Note that we
  99       --  always know that Keep has at least as many continuations as
 100       --  Delete (since we always delete the shorter sequence).
 101
 102       ----------------
 103       -- Delete_Msg --
 104       ----------------
 105
 106       procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
 107          D, K : Error_Msg_Id;
 108
 109       begin
 110          D := Delete;
 111          K := Keep;
 112
 113          loop
 114             Errors.Table (D).Deleted := True;
 115
 116             --  Adjust error message count
 117
 118             if Errors.Table (D).Warn or Errors.Table (D).Style then
 119                Warnings_Detected := Warnings_Detected - 1;
 120             else
 121                Total_Errors_Detected := Total_Errors_Detected - 1;
 122
 123                if Errors.Table (D).Serious then
 124                   Serious_Errors_Detected := Serious_Errors_Detected - 1;
 125                end if;
 126             end if;
 127
 128             --  Substitute shorter of the two error messages
 129
 130             if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
 131                Errors.Table (K).Text := Errors.Table (D).Text;
 132             end if;
 133
 134             D := Errors.Table (D).Next;
 135             K := Errors.Table (K).Next;
 136
 137             if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
 138                return;
 139             end if;
 140          end loop;
 141       end Delete_Msg;
 142
 143    --  Start of processing for Check_Duplicate_Message
 144
 145    begin
 146       --  Both messages must be non-continuation messages and not deleted
 147
 148       if Errors.Table (M1).Msg_Cont
 149         or else Errors.Table (M2).Msg_Cont
 150         or else Errors.Table (M1).Deleted
 151         or else Errors.Table (M2).Deleted
 152       then
 153          return;
 154       end if;
 155
 156       --  Definitely not equal if message text does not match
 157
 158       if not Same_Error (M1, M2) then
 159          return;
 160       end if;
 161
 162       --  Same text. See if all continuations are also identical
 163
 164       L1 := M1;
 165       L2 := M2;
 166
 167       loop
 168          N1 := Errors.Table (L1).Next;
 169          N2 := Errors.Table (L2).Next;
 170
 171          --  If M1 continuations have run out, we delete M1, either the
 172          --  messages have the same number of continuations, or M2 has
 173          --  more and we prefer the one with more anyway.
 174
 175          if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
 176             Delete_Msg (M1, M2);
 177             return;
 178
 179          --  If M2 continuatins have run out, we delete M2
 180
 181          elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
 182             Delete_Msg (M2, M1);
 183             return;
 184
 185          --  Otherwise see if continuations are the same, if not, keep both
 186          --  sequences, a curious case, but better to keep everything!
 187
 188          elsif not Same_Error (N1, N2) then
 189             return;
 190
 191          --  If continuations are the same, continue scan
 192
 193          else
 194             L1 := N1;
 195             L2 := N2;
 196          end if;
 197       end loop;
 198    end Check_Duplicate_Message;
 199
 200    ------------------------
 201    -- Compilation_Errors --
 202    ------------------------
 203
 204    function Compilation_Errors return Boolean is
 205    begin
 206       return Total_Errors_Detected /= 0
 207         or else (Warnings_Detected /= 0
 208                   and then Warning_Mode = Treat_As_Error);
 209    end Compilation_Errors;
 210
 211    ------------------
 212    -- Debug_Output --
 213    ------------------
 214
 215    procedure Debug_Output (N : Node_Id) is
 216    begin
 217       if Debug_Flag_1 then
 218          Write_Str ("*** following error message posted on node id = #");
 219          Write_Int (Int (N));
 220          Write_Str (" ***");
 221          Write_Eol;
 222       end if;
 223    end Debug_Output;
 224
 225    ----------
 226    -- dmsg --
 227    ----------
 228
 229    procedure dmsg (Id : Error_Msg_Id) is
 230       E : Error_Msg_Object renames Errors.Table (Id);
 231
 232    begin
 233       w ("Dumping error message, Id = ", Int (Id));
 234       w ("  Text     = ", E.Text.all);
 235       w ("  Next     = ", Int (E.Next));
 236       w ("  Sfile    = ", Int (E.Sfile));
 237
 238       Write_Str
 239         ("  Sptr     = ");
 240       Write_Location (E.Sptr);
 241       Write_Eol;
 242
 243       Write_Str
 244         ("  Optr     = ");
 245       Write_Location (E.Optr);
 246       Write_Eol;
 247
 248       w ("  Line     = ", Int (E.Line));
 249       w ("  Col      = ", Int (E.Col));
 250       w ("  Warn     = ", E.Warn);
 251       w ("  Style    = ", E.Style);
 252       w ("  Serious  = ", E.Serious);
 253       w ("  Uncond   = ", E.Uncond);
 254       w ("  Msg_Cont = ", E.Msg_Cont);
 255       w ("  Deleted  = ", E.Deleted);
 256
 257       Write_Eol;
 258    end dmsg;
 259
 260    ------------------
 261    -- Get_Location --
 262    ------------------
 263
 264    function Get_Location (E : Error_Msg_Id) return Source_Ptr is
 265    begin
 266       return Errors.Table (E).Sptr;
 267    end Get_Location;
 268
 269    ----------------
 270    -- Get_Msg_Id --
 271    ----------------
 272
 273    function Get_Msg_Id return Error_Msg_Id is
 274    begin
 275       return Cur_Msg;
 276    end Get_Msg_Id;
 277
 278    -----------------------
 279    -- Output_Error_Msgs --
 280    -----------------------
 281
 282    procedure Output_Error_Msgs (E : in out Error_Msg_Id) is
 283       P : Source_Ptr;
 284       T : Error_Msg_Id;
 285       S : Error_Msg_Id;
 286
 287       Flag_Num   : Pos;
 288       Mult_Flags : Boolean := False;
 289
 290    begin
 291       S := E;
 292
 293       --  Skip deleted messages at start
 294
 295       if Errors.Table (S).Deleted then
 296          Set_Next_Non_Deleted_Msg (S);
 297       end if;
 298
 299       --  Figure out if we will place more than one error flag on this line
 300
 301       T := S;
 302       while T /= No_Error_Msg
 303         and then Errors.Table (T).Line = Errors.Table (E).Line
 304         and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
 305       loop
 306          if Errors.Table (T).Sptr > Errors.Table (E).Sptr then
 307             Mult_Flags := True;
 308          end if;
 309
 310          Set_Next_Non_Deleted_Msg (T);
 311       end loop;
 312
 313       --  Output the error flags. The circuit here makes sure that the tab
 314       --  characters in the original line are properly accounted for. The
 315       --  eight blanks at the start are to match the line number.
 316
 317       if not Debug_Flag_2 then
 318          Write_Str ("        ");
 319          P := Line_Start (Errors.Table (E).Sptr);
 320          Flag_Num := 1;
 321
 322          --  Loop through error messages for this line to place flags
 323
 324          T := S;
 325          while T /= No_Error_Msg
 326            and then Errors.Table (T).Line = Errors.Table (E).Line
 327            and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
 328          loop
 329             --  Loop to output blanks till current flag position
 330
 331             while P < Errors.Table (T).Sptr loop
 332                if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then
 333                   Write_Char (ASCII.HT);
 334                else
 335                   Write_Char (' ');
 336                end if;
 337
 338                P := P + 1;
 339             end loop;
 340
 341             --  Output flag (unless already output, this happens if more
 342             --  than one error message occurs at the same flag position).
 343
 344             if P = Errors.Table (T).Sptr then
 345                if (Flag_Num = 1 and then not Mult_Flags)
 346                  or else Flag_Num > 9
 347                then
 348                   Write_Char ('|');
 349                else
 350                   Write_Char (Character'Val (Character'Pos ('0') + Flag_Num));
 351                end if;
 352
 353                P := P + 1;
 354             end if;
 355
 356             Set_Next_Non_Deleted_Msg (T);
 357             Flag_Num := Flag_Num + 1;
 358          end loop;
 359
 360          Write_Eol;
 361       end if;
 362
 363       --  Now output the error messages
 364
 365       T := S;
 366       while T /= No_Error_Msg
 367         and then Errors.Table (T).Line = Errors.Table (E).Line
 368         and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
 369       loop
 370          Write_Str ("        >>> ");
 371          Output_Msg_Text (T);
 372
 373          if Debug_Flag_2 then
 374             while Column < 74 loop
 375                Write_Char (' ');
 376             end loop;
 377
 378             Write_Str (" <<<");
 379          end if;
 380
 381          Write_Eol;
 382          Set_Next_Non_Deleted_Msg (T);
 383       end loop;
 384
 385       E := T;
 386    end Output_Error_Msgs;
 387
 388    ------------------------
 389    -- Output_Line_Number --
 390    ------------------------
 391
 392    procedure Output_Line_Number (L : Logical_Line_Number) is
 393       D     : Int;       -- next digit
 394       C     : Character; -- next character
 395       Z     : Boolean;   -- flag for zero suppress
 396       N, M  : Int;       -- temporaries
 397
 398    begin
 399       if L = No_Line_Number then
 400          Write_Str ("        ");
 401
 402       else
 403          Z := False;
 404          N := Int (L);
 405
 406          M := 100_000;
 407          while M /= 0 loop
 408             D := Int (N / M);
 409             N := N rem M;
 410             M := M / 10;
 411
 412             if D = 0 then
 413                if Z then
 414                   C := '0';
 415                else
 416                   C := ' ';
 417                end if;
 418             else
 419                Z := True;
 420                C := Character'Val (D + 48);
 421             end if;
 422
 423             Write_Char (C);
 424          end loop;
 425
 426          Write_Str (". ");
 427       end if;
 428    end Output_Line_Number;
 429
 430    ---------------------
 431    -- Output_Msg_Text --
 432    ---------------------
 433
 434    procedure Output_Msg_Text (E : Error_Msg_Id) is
 435       Offs : constant Nat := Column - 1;
 436       --  Offset to start of message, used for continuations
 437
 438       Max : Integer;
 439       --  Maximum characters to output on next line
 440
 441       Length : Nat;
 442       --  Maximum total length of lines
 443
 444    begin
 445       if Error_Msg_Line_Length = 0 then
 446          Length := Nat'Last;
 447       else
 448          Length := Error_Msg_Line_Length;
 449       end if;
 450
 451       Max := Integer (Length - Column + 1);
 452
 453       if Errors.Table (E).Warn then
 454          Write_Str ("warning: ");
 455          Max := Max - 9;
 456
 457       elsif Errors.Table (E).Style then
 458          null;
 459
 460       elsif Opt.Unique_Error_Tag then
 461          Write_Str ("error: ");
 462          Max := Max - 7;
 463       end if;
 464
 465       --  Here we have to split the message up into multiple lines
 466
 467       declare
 468          Txt   : constant String_Ptr := Errors.Table (E).Text;
 469          Len   : constant Natural    := Txt'Length;
 470          Ptr   : Natural;
 471          Split : Natural;
 472          Start : Natural;
 473
 474       begin
 475          Ptr := 1;
 476          loop
 477             --  Make sure we do not have ludicrously small line
 478
 479             Max := Integer'Max (Max, 20);
 480
 481             --  If remaining text fits, output it respecting LF and we are done
 482
 483             if Len - Ptr < Max then
 484                for J in Ptr .. Len loop
 485                   if Txt (J) = ASCII.LF then
 486                      Write_Eol;
 487                      Write_Spaces (Offs);
 488                   else
 489                      Write_Char (Txt (J));
 490                   end if;
 491                end loop;
 492
 493                return;
 494
 495             --  Line does not fit
 496
 497             else
 498                Start := Ptr;
 499
 500                --  First scan forward looing for a hard end of line
 501
 502                for Scan in Ptr .. Ptr + Max - 1 loop
 503                   if Txt (Scan) = ASCII.LF then
 504                      Split := Scan - 1;
 505                      Ptr := Scan + 1;
 506                      goto Continue;
 507                   end if;
 508                end loop;
 509
 510                --  Otherwise scan backwards looking for a space
 511
 512                for Scan in reverse Ptr .. Ptr + Max - 1 loop
 513                   if Txt (Scan) = ' ' then
 514                      Split := Scan - 1;
 515                      Ptr := Scan + 1;
 516                      goto Continue;
 517                   end if;
 518                end loop;
 519
 520                --  If we fall through, no space, so split line arbitrarily
 521
 522                Split := Ptr + Max - 1;
 523                Ptr := Split + 1;
 524             end if;
 525
 526          <<Continue>>
 527             if Start <= Split then
 528                Write_Line (Txt (Start .. Split));
 529                Write_Spaces (Offs);
 530             end if;
 531
 532             Max := Integer (Length - Column + 1);
 533          end loop;
 534       end;
 535    end Output_Msg_Text;
 536
 537    --------------------
 538    -- Purge_Messages --
 539    --------------------
 540
 541    procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
 542       E : Error_Msg_Id;
 543
 544       function To_Be_Purged (E : Error_Msg_Id) return Boolean;
 545       --  Returns True for a message that is to be purged. Also adjusts
 546       --  error counts appropriately.
 547
 548       ------------------
 549       -- To_Be_Purged --
 550       ------------------
 551
 552       function To_Be_Purged (E : Error_Msg_Id) return Boolean is
 553       begin
 554          if E /= No_Error_Msg
 555            and then Errors.Table (E).Sptr > From
 556            and then Errors.Table (E).Sptr < To
 557          then
 558             if Errors.Table (E).Warn or Errors.Table (E).Style then
 559                Warnings_Detected := Warnings_Detected - 1;
 560             else
 561                Total_Errors_Detected := Total_Errors_Detected - 1;
 562
 563                if Errors.Table (E).Serious then
 564                   Serious_Errors_Detected := Serious_Errors_Detected - 1;
 565                end if;
 566             end if;
 567
 568             return True;
 569
 570          else
 571             return False;
 572          end if;
 573       end To_Be_Purged;
 574
 575    --  Start of processing for Purge_Messages
 576
 577    begin
 578       while To_Be_Purged (First_Error_Msg) loop
 579          First_Error_Msg := Errors.Table (First_Error_Msg).Next;
 580       end loop;
 581
 582       E := First_Error_Msg;
 583       while E /= No_Error_Msg loop
 584          while To_Be_Purged (Errors.Table (E).Next) loop
 585             Errors.Table (E).Next :=
 586               Errors.Table (Errors.Table (E).Next).Next;
 587          end loop;
 588
 589          E := Errors.Table (E).Next;
 590       end loop;
 591    end Purge_Messages;
 592
 593    ----------------
 594    -- Same_Error --
 595    ----------------
 596
 597    function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
 598       Msg1 : constant String_Ptr := Errors.Table (M1).Text;
 599       Msg2 : constant String_Ptr := Errors.Table (M2).Text;
 600
 601       Msg2_Len : constant Integer := Msg2'Length;
 602       Msg1_Len : constant Integer := Msg1'Length;
 603
 604    begin
 605       return
 606         Msg1.all = Msg2.all
 607           or else
 608             (Msg1_Len - 10 > Msg2_Len
 609                and then
 610              Msg2.all = Msg1.all (1 .. Msg2_Len)
 611                and then
 612              Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
 613           or else
 614             (Msg2_Len - 10 > Msg1_Len
 615                and then
 616              Msg1.all = Msg2.all (1 .. Msg1_Len)
 617                and then
 618              Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
 619    end Same_Error;
 620
 621    -------------------
 622    -- Set_Msg_Blank --
 623    -------------------
 624
 625    procedure Set_Msg_Blank is
 626    begin
 627       if Msglen > 0
 628         and then Msg_Buffer (Msglen) /= ' '
 629         and then Msg_Buffer (Msglen) /= '('
 630         and then Msg_Buffer (Msglen) /= '-'
 631         and then not Manual_Quote_Mode
 632       then
 633          Set_Msg_Char (' ');
 634       end if;
 635    end Set_Msg_Blank;
 636
 637    -------------------------------
 638    -- Set_Msg_Blank_Conditional --
 639    -------------------------------
 640
 641    procedure Set_Msg_Blank_Conditional is
 642    begin
 643       if Msglen > 0
 644         and then Msg_Buffer (Msglen) /= ' '
 645         and then Msg_Buffer (Msglen) /= '('
 646         and then Msg_Buffer (Msglen) /= '"'
 647         and then not Manual_Quote_Mode
 648       then
 649          Set_Msg_Char (' ');
 650       end if;
 651    end Set_Msg_Blank_Conditional;
 652
 653    ------------------
 654    -- Set_Msg_Char --
 655    ------------------
 656
 657    procedure Set_Msg_Char (C : Character) is
 658    begin
 659
 660       --  The check for message buffer overflow is needed to deal with cases
 661       --  where insertions get too long (in particular a child unit name can
 662       --  be very long).
 663
 664       if Msglen < Max_Msg_Length then
 665          Msglen := Msglen + 1;
 666          Msg_Buffer (Msglen) := C;
 667       end if;
 668    end Set_Msg_Char;
 669
 670    ---------------------------------
 671    -- Set_Msg_Insertion_File_Name --
 672    ---------------------------------
 673
 674    procedure Set_Msg_Insertion_File_Name is
 675    begin
 676       if Error_Msg_File_1 = No_File then
 677          null;
 678
 679       elsif Error_Msg_File_1 = Error_File_Name then
 680          Set_Msg_Blank;
 681          Set_Msg_Str ("<error>");
 682
 683       else
 684          Set_Msg_Blank;
 685          Get_Name_String (Error_Msg_File_1);
 686          Set_Msg_Quote;
 687          Set_Msg_Name_Buffer;
 688          Set_Msg_Quote;
 689       end if;
 690
 691       --  The following assignments ensure that the second and third {
 692       --  insertion characters will correspond to the Error_Msg_File_2 and
 693       --  Error_Msg_File_3 values and We suppress possible validity checks in
 694       --  case operating in -gnatVa mode, and Error_Msg_File_2 or
 695       --  Error_Msg_File_3 is not needed and has not been set.
 696
 697       declare
 698          pragma Suppress (Range_Check);
 699       begin
 700          Error_Msg_File_1 := Error_Msg_File_2;
 701          Error_Msg_File_2 := Error_Msg_File_3;
 702       end;
 703    end Set_Msg_Insertion_File_Name;
 704
 705    -----------------------------------
 706    -- Set_Msg_Insertion_Line_Number --
 707    -----------------------------------
 708
 709    procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
 710       Sindex_Loc  : Source_File_Index;
 711       Sindex_Flag : Source_File_Index;
 712
 713    begin
 714       Set_Msg_Blank;
 715
 716       if Loc = No_Location then
 717          Set_Msg_Str ("at unknown location");
 718
 719       elsif Loc = System_Location then
 720          Set_Msg_Str ("in package System");
 721          Set_Msg_Insertion_Run_Time_Name;
 722
 723       elsif Loc = Standard_Location then
 724          Set_Msg_Str ("in package Standard");
 725
 726       elsif Loc = Standard_ASCII_Location then
 727          Set_Msg_Str ("in package Standard.ASCII");
 728
 729       else
 730          --  Add "at file-name:" if reference is to other than the source
 731          --  file in which the error message is placed. Note that we check
 732          --  full file names, rather than just the source indexes, to
 733          --  deal with generic instantiations from the current file.
 734
 735          Sindex_Loc  := Get_Source_File_Index (Loc);
 736          Sindex_Flag := Get_Source_File_Index (Flag);
 737
 738          if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
 739             Set_Msg_Str ("at ");
 740             Get_Name_String
 741               (Reference_Name (Get_Source_File_Index (Loc)));
 742             Set_Msg_Name_Buffer;
 743             Set_Msg_Char (':');
 744
 745          --  If in current file, add text "at line "
 746
 747          else
 748             Set_Msg_Str ("at line ");
 749          end if;
 750
 751          --  Output line number for reference
 752
 753          Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
 754
 755          --  Deal with the instantiation case. We may have a reference to,
 756          --  e.g. a type, that is declared within a generic template, and
 757          --  what we are really referring to is the occurrence in an instance.
 758          --  In this case, the line number of the instantiation is also of
 759          --  interest, and we add a notation:
 760
 761          --    , instance at xxx
 762
 763          --  where xxx is a line number output using this same routine (and
 764          --  the recursion can go further if the instantiation is itself in
 765          --  a generic template).
 766
 767          --  The flag location passed to us in this situation is indeed the
 768          --  line number within the template, but as described in Sinput.L
 769          --  (file sinput-l.ads, section "Handling Generic Instantiations")
 770          --  we can retrieve the location of the instantiation itself from
 771          --  this flag location value.
 772
 773          --  Note: this processing is suppressed if Suppress_Instance_Location
 774          --  is set True. This is used to prevent redundant annotations of the
 775          --  location of the instantiation in the case where we are placing
 776          --  the messages on the instantiation in any case.
 777
 778          if Instantiation (Sindex_Loc) /= No_Location
 779            and then not Suppress_Instance_Location
 780          then
 781             Set_Msg_Str (", instance ");
 782             Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
 783          end if;
 784       end if;
 785    end Set_Msg_Insertion_Line_Number;
 786
 787    ----------------------------
 788    -- Set_Msg_Insertion_Name --
 789    ----------------------------
 790
 791    procedure Set_Msg_Insertion_Name is
 792    begin
 793       if Error_Msg_Name_1 = No_Name then
 794          null;
 795
 796       elsif Error_Msg_Name_1 = Error_Name then
 797          Set_Msg_Blank;
 798          Set_Msg_Str ("<error>");
 799
 800       else
 801          Set_Msg_Blank_Conditional;
 802          Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
 803
 804          --  Remove %s or %b at end. These come from unit names. If the
 805          --  caller wanted the (unit) or (body), then they would have used
 806          --  the $ insertion character. Certainly no error message should
 807          --  ever have %b or %s explicitly occurring.
 808
 809          if Name_Len > 2
 810            and then Name_Buffer (Name_Len - 1) = '%'
 811            and then (Name_Buffer (Name_Len) = 'b'
 812                        or else
 813                      Name_Buffer (Name_Len) = 's')
 814          then
 815             Name_Len := Name_Len - 2;
 816          end if;
 817
 818          --  Remove upper case letter at end, again, we should not be getting
 819          --  such names, and what we hope is that the remainder makes sense.
 820
 821          if Name_Len > 1
 822            and then Name_Buffer (Name_Len) in 'A' .. 'Z'
 823          then
 824             Name_Len := Name_Len - 1;
 825          end if;
 826
 827          --  If operator name or character literal name, just print it as is
 828          --  Also print as is if it ends in a right paren (case of x'val(nnn))
 829
 830          if Name_Buffer (1) = '"'
 831            or else Name_Buffer (1) = '''
 832            or else Name_Buffer (Name_Len) = ')'
 833          then
 834             Set_Msg_Name_Buffer;
 835
 836          --  Else output with surrounding quotes in proper casing mode
 837
 838          else
 839             Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
 840             Set_Msg_Quote;
 841             Set_Msg_Name_Buffer;
 842             Set_Msg_Quote;
 843          end if;
 844       end if;
 845
 846       --  The following assignments ensure that the second and third percent
 847       --  insertion characters will correspond to the Error_Msg_Name_2 and
 848       --  Error_Msg_Name_3 as required. We suppress possible validity checks in
 849       --  case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed
 850       --  and has not been set.
 851
 852       declare
 853          pragma Suppress (Range_Check);
 854       begin
 855          Error_Msg_Name_1 := Error_Msg_Name_2;
 856          Error_Msg_Name_2 := Error_Msg_Name_3;
 857       end;
 858    end Set_Msg_Insertion_Name;
 859
 860    ------------------------------------
 861    -- Set_Msg_Insertion_Name_Literal --
 862    ------------------------------------
 863
 864    procedure Set_Msg_Insertion_Name_Literal is
 865    begin
 866       if Error_Msg_Name_1 = No_Name then
 867          null;
 868
 869       elsif Error_Msg_Name_1 = Error_Name then
 870          Set_Msg_Blank;
 871          Set_Msg_Str ("<error>");
 872
 873       else
 874          Set_Msg_Blank;
 875          Get_Name_String (Error_Msg_Name_1);
 876          Set_Msg_Quote;
 877          Set_Msg_Name_Buffer;
 878          Set_Msg_Quote;
 879       end if;
 880
 881       --  The following assignments ensure that the second and third % or %%
 882       --  insertion characters will correspond to the Error_Msg_Name_2 and
 883       --  Error_Msg_Name_3 values and We suppress possible validity checks in
 884       --  case operating in -gnatVa mode, and Error_Msg_Name_2 or
 885       --  Error_Msg_Name_3 is not needed and has not been set.
 886
 887       declare
 888          pragma Suppress (Range_Check);
 889       begin
 890          Error_Msg_Name_1 := Error_Msg_Name_2;
 891          Error_Msg_Name_2 := Error_Msg_Name_3;
 892       end;
 893    end Set_Msg_Insertion_Name_Literal;
 894
 895    -------------------------------------
 896    -- Set_Msg_Insertion_Reserved_Name --
 897    -------------------------------------
 898
 899    procedure Set_Msg_Insertion_Reserved_Name is
 900    begin
 901       Set_Msg_Blank_Conditional;
 902       Get_Name_String (Error_Msg_Name_1);
 903       Set_Msg_Quote;
 904       Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
 905       Set_Msg_Name_Buffer;
 906       Set_Msg_Quote;
 907    end Set_Msg_Insertion_Reserved_Name;
 908
 909    -------------------------------------
 910    -- Set_Msg_Insertion_Reserved_Word --
 911    -------------------------------------
 912
 913    procedure Set_Msg_Insertion_Reserved_Word
 914      (Text : String;
 915       J    : in out Integer)
 916    is
 917    begin
 918       Set_Msg_Blank_Conditional;
 919       Name_Len := 0;
 920
 921       while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
 922          Name_Len := Name_Len + 1;
 923          Name_Buffer (Name_Len) := Text (J);
 924          J := J + 1;
 925       end loop;
 926
 927       --  Here is where we make the special exception for RM
 928
 929       if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
 930          Set_Msg_Name_Buffer;
 931
 932       --  Not RM: case appropriately and add surrounding quotes
 933
 934       else
 935          Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
 936          Set_Msg_Quote;
 937          Set_Msg_Name_Buffer;
 938          Set_Msg_Quote;
 939       end if;
 940    end Set_Msg_Insertion_Reserved_Word;
 941
 942    -------------------------------------
 943    -- Set_Msg_Insertion_Run_Time_Name --
 944    -------------------------------------
 945
 946    procedure Set_Msg_Insertion_Run_Time_Name is
 947    begin
 948       if Targparm.Run_Time_Name_On_Target /= No_Name then
 949          Set_Msg_Blank_Conditional;
 950          Set_Msg_Char ('(');
 951          Get_Name_String (Targparm.Run_Time_Name_On_Target);
 952          Set_Casing (Mixed_Case);
 953          Set_Msg_Str (Name_Buffer (1 .. Name_Len));
 954          Set_Msg_Char (')');
 955       end if;
 956    end Set_Msg_Insertion_Run_Time_Name;
 957
 958    ----------------------------
 959    -- Set_Msg_Insertion_Uint --
 960    ----------------------------
 961
 962    procedure Set_Msg_Insertion_Uint is
 963    begin
 964       Set_Msg_Blank;
 965       UI_Image (Error_Msg_Uint_1);
 966
 967       for J in 1 .. UI_Image_Length loop
 968          Set_Msg_Char (UI_Image_Buffer (J));
 969       end loop;
 970
 971       --  The following assignment ensures that a second carret insertion
 972       --  character will correspond to the Error_Msg_Uint_2 parameter. We
 973       --  suppress possible validity checks in case operating in -gnatVa mode,
 974       --  and Error_Msg_Uint_2 is not needed and has not been set.
 975
 976       declare
 977          pragma Suppress (Range_Check);
 978       begin
 979          Error_Msg_Uint_1 := Error_Msg_Uint_2;
 980       end;
 981    end Set_Msg_Insertion_Uint;
 982
 983    -----------------
 984    -- Set_Msg_Int --
 985    -----------------
 986
 987    procedure Set_Msg_Int (Line : Int) is
 988    begin
 989       if Line > 9 then
 990          Set_Msg_Int (Line / 10);
 991       end if;
 992
 993       Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
 994    end Set_Msg_Int;
 995
 996    -------------------------
 997    -- Set_Msg_Name_Buffer --
 998    -------------------------
 999
1000    procedure Set_Msg_Name_Buffer is
1001    begin
1002       for J in 1 .. Name_Len loop
1003          Set_Msg_Char (Name_Buffer (J));
1004       end loop;
1005    end Set_Msg_Name_Buffer;
1006
1007    -------------------
1008    -- Set_Msg_Quote --
1009    -------------------
1010
1011    procedure Set_Msg_Quote is
1012    begin
1013       if not Manual_Quote_Mode then
1014          Set_Msg_Char ('"');
1015       end if;
1016    end Set_Msg_Quote;
1017
1018    -----------------
1019    -- Set_Msg_Str --
1020    -----------------
1021
1022    procedure Set_Msg_Str (Text : String) is
1023    begin
1024       for J in Text'Range loop
1025          Set_Msg_Char (Text (J));
1026       end loop;
1027    end Set_Msg_Str;
1028
1029    ------------------------------
1030    -- Set_Next_Non_Deleted_Msg --
1031    ------------------------------
1032
1033    procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
1034    begin
1035       if E = No_Error_Msg then
1036          return;
1037
1038       else
1039          loop
1040             E := Errors.Table (E).Next;
1041             exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
1042          end loop;
1043       end if;
1044    end Set_Next_Non_Deleted_Msg;
1045
1046    ------------------------------
1047    -- Set_Specific_Warning_Off --
1048    ------------------------------
1049
1050    procedure Set_Specific_Warning_Off
1051      (Loc    : Source_Ptr;
1052       Msg    : String;
1053       Config : Boolean)
1054    is
1055       pragma Assert (Msg'First = 1);
1056
1057       Pattern : String  := Msg;
1058       Patlen  : Natural := Msg'Length;
1059
1060       Star_Start : Boolean;
1061       Star_End   : Boolean;
1062
1063    begin
1064       if Pattern (1) = '*' then
1065          Star_Start := True;
1066          Pattern (1 .. Patlen - 1) := Pattern (2 .. Patlen);
1067          Patlen := Patlen - 1;
1068       else
1069          Star_Start := False;
1070       end if;
1071
1072       if Pattern (Patlen) = '*' then
1073          Star_End := True;
1074          Patlen := Patlen - 1;
1075       else
1076          Star_End := False;
1077       end if;
1078
1079       Specific_Warnings.Append
1080         ((Start      => Loc,
1081           Msg        => new String'(Msg),
1082           Pattern    => new String'(Pattern (1 .. Patlen)),
1083           Patlen     => Patlen,
1084           Stop       => Source_Last (Current_Source_File),
1085           Open       => True,
1086           Used       => False,
1087           Star_Start => Star_Start,
1088           Star_End   => Star_End,
1089           Config     => Config));
1090    end Set_Specific_Warning_Off;
1091
1092    -----------------------------
1093    -- Set_Specific_Warning_On --
1094    -----------------------------
1095
1096    procedure Set_Specific_Warning_On
1097      (Loc : Source_Ptr;
1098       Msg : String;
1099       Err : out Boolean)
1100    is
1101    begin
1102       for J in 1 .. Specific_Warnings.Last loop
1103          declare
1104             SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1105          begin
1106             if Msg = SWE.Msg.all
1107               and then Loc > SWE.Start
1108               and then SWE.Open
1109               and then Get_Source_File_Index (SWE.Start) =
1110                        Get_Source_File_Index (Loc)
1111             then
1112                SWE.Stop := Loc;
1113                SWE.Open := False;
1114                Err := False;
1115
1116                --  If a config pragma is specifically cancelled, consider
1117                --  that it is no longer active as a configuration pragma.
1118
1119                SWE.Config := False;
1120                return;
1121             end if;
1122          end;
1123       end loop;
1124
1125       Err := True;
1126    end Set_Specific_Warning_On;
1127
1128    ---------------------------
1129    -- Set_Warnings_Mode_Off --
1130    ---------------------------
1131
1132    procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is
1133    begin
1134       --  Don't bother with entries from instantiation copies, since we
1135       --  will already have a copy in the template, which is what matters
1136
1137       if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1138          return;
1139       end if;
1140
1141       --  If last entry in table already covers us, this is a redundant
1142       --  pragma Warnings (Off) and can be ignored. This also handles the
1143       --  case where all warnings are suppressed by command line switch.
1144
1145       if Warnings.Last >= Warnings.First
1146         and then Warnings.Table (Warnings.Last).Start <= Loc
1147         and then Loc <= Warnings.Table (Warnings.Last).Stop
1148       then
1149          return;
1150
1151       --  Otherwise establish a new entry, extending from the location of
1152       --  the pragma to the end of the current source file. This ending
1153       --  point will be adjusted by a subsequent pragma Warnings (On).
1154
1155       else
1156          Warnings.Increment_Last;
1157          Warnings.Table (Warnings.Last).Start := Loc;
1158          Warnings.Table (Warnings.Last).Stop :=
1159            Source_Last (Current_Source_File);
1160       end if;
1161    end Set_Warnings_Mode_Off;
1162
1163    --------------------------
1164    -- Set_Warnings_Mode_On --
1165    --------------------------
1166
1167    procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
1168    begin
1169       --  Don't bother with entries from instantiation copies, since we
1170       --  will already have a copy in the template, which is what matters
1171
1172       if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1173          return;
1174       end if;
1175
1176       --  Nothing to do unless command line switch to suppress all warnings
1177       --  is off, and the last entry in the warnings table covers this
1178       --  pragma Warnings (On), in which case adjust the end point.
1179
1180       if (Warnings.Last >= Warnings.First
1181            and then Warnings.Table (Warnings.Last).Start <= Loc
1182            and then Loc <= Warnings.Table (Warnings.Last).Stop)
1183         and then Warning_Mode /= Suppress
1184       then
1185          Warnings.Table (Warnings.Last).Stop := Loc;
1186       end if;
1187    end Set_Warnings_Mode_On;
1188
1189    ------------------------------------
1190    -- Test_Style_Warning_Serious_Msg --
1191    ------------------------------------
1192
1193    procedure Test_Style_Warning_Serious_Msg (Msg : String) is
1194    begin
1195       if Msg (Msg'First) = '\' then
1196          return;
1197       end if;
1198
1199       Is_Serious_Error := True;
1200       Is_Warning_Msg   := False;
1201
1202       Is_Style_Msg :=
1203         (Msg'Length > 7
1204            and then Msg (Msg'First .. Msg'First + 6) = "(style)");
1205
1206       for J in Msg'Range loop
1207          if Msg (J) = '?'
1208            and then (J = Msg'First or else Msg (J - 1) /= ''')
1209          then
1210             Is_Warning_Msg := True;
1211
1212          elsif Msg (J) = '<'
1213            and then (J = Msg'First or else Msg (J - 1) /= ''')
1214          then
1215             Is_Warning_Msg := Error_Msg_Warn;
1216
1217          elsif Msg (J) = '|'
1218            and then (J = Msg'First or else Msg (J - 1) /= ''')
1219          then
1220             Is_Serious_Error := False;
1221          end if;
1222       end loop;
1223
1224       if Is_Warning_Msg or else Is_Style_Msg then
1225          Is_Serious_Error := False;
1226       end if;
1227    end Test_Style_Warning_Serious_Msg;
1228
1229    --------------------------------
1230    -- Validate_Specific_Warnings --
1231    --------------------------------
1232
1233    procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
1234    begin
1235       for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1236          declare
1237             SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1238          begin
1239             if not SWE.Config then
1240                if SWE.Open then
1241                   Eproc.all
1242                     ("?pragma Warnings Off with no matching Warnings On",
1243                      SWE.Start);
1244                elsif not SWE.Used then
1245                   Eproc.all
1246                     ("?no warning suppressed by this pragma", SWE.Start);
1247                end if;
1248             end if;
1249          end;
1250       end loop;
1251    end Validate_Specific_Warnings;
1252
1253    -------------------------------------
1254    -- Warning_Specifically_Suppressed --
1255    -------------------------------------
1256
1257    function Warning_Specifically_Suppressed
1258      (Loc : Source_Ptr;
1259       Msg : String_Ptr) return Boolean
1260    is
1261       pragma Assert (Msg'First = 1);
1262
1263       Msglen : constant Natural := Msg'Length;
1264       Patlen : Natural;
1265       --  Length of message
1266
1267       Pattern : String_Ptr;
1268       --  Pattern itself, excluding initial and final *
1269
1270       Star_Start : Boolean;
1271       Star_End   : Boolean;
1272       --  Indications of * at start and end of original pattern
1273
1274       Msgp : Natural;
1275       Patp : Natural;
1276       --  Scan pointers for message and pattern
1277
1278    begin
1279       --  Loop through specific warning suppression entries
1280
1281       for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1282          declare
1283             SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1284
1285          begin
1286             --  Pragma applies if it is a configuration pragma, or if the
1287             --  location is in range of a specific non-configuration pragma.
1288
1289             if SWE.Config
1290               or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
1291             then
1292                --  Check if message matches, dealing with * patterns
1293
1294                Patlen     := SWE.Patlen;
1295                Pattern    := SWE.Pattern;
1296                Star_Start := SWE.Star_Start;
1297                Star_End   := SWE.Star_End;
1298
1299                --  Loop through possible starting positions in Msg
1300
1301                Outer : for M in 1 .. 1 + (Msglen - Patlen) loop
1302
1303                   --  See if pattern matches string starting at Msg (J)
1304
1305                   Msgp := M;
1306                   Patp := 1;
1307                   Inner : loop
1308
1309                      --  If pattern exhausted, then match if we are at end
1310                      --  of message, or if pattern ended with an asterisk,
1311                      --  otherwise match failure at this position.
1312
1313                      if Patp > Patlen then
1314                         if Msgp > Msglen or else Star_End then
1315                            SWE.Used := True;
1316                            return True;
1317                         else
1318                            exit Inner;
1319                         end if;
1320
1321                         --  Otherwise if message exhausted (and we still have
1322                         --  pattern characters left), then match failure here.
1323
1324                      elsif Msgp > Msglen then
1325                         exit Inner;
1326                      end if;
1327
1328                      --  Here we have pattern and message characters left
1329
1330                      --  Handle "*" pattern match
1331
1332                      if Patp < Patlen - 1 and then
1333                        Pattern (Patp .. Patp + 2) = """*"""
1334                      then
1335                         Patp := Patp + 3;
1336
1337                         --  Must have " and at least three chars in msg or we
1338                         --  have no match at this position.
1339
1340                         exit Inner when Msg (Msgp) /= '"';
1341                         Msgp := Msgp + 1;
1342
1343                         --  Scan out " string " in message
1344
1345                         Scan : loop
1346                            exit Inner when Msgp = Msglen;
1347                            Msgp := Msgp + 1;
1348                            exit Scan when Msg (Msgp - 1) = '"';
1349                         end loop Scan;
1350
1351                      --  If not "*" case, just compare character
1352
1353                      else
1354                         exit Inner when Pattern (Patp) /= Msg (Msgp);
1355                         Patp := Patp + 1;
1356                         Msgp := Msgp + 1;
1357                      end if;
1358                   end loop Inner;
1359
1360                   --  Advance to next position if star at end of original
1361                   --  pattern, otherwise no more match attempts are possible
1362
1363                   exit Outer when not Star_Start;
1364                end loop Outer;
1365             end if;
1366          end;
1367       end loop;
1368
1369       return False;
1370    end Warning_Specifically_Suppressed;
1371
1372    -------------------------
1373    -- Warnings_Suppressed --
1374    -------------------------
1375
1376    function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
1377    begin
1378       --  Loop through table of ON/OFF warnings
1379
1380       for J in Warnings.First .. Warnings.Last loop
1381          if Warnings.Table (J).Start <= Loc
1382            and then Loc <= Warnings.Table (J).Stop
1383          then
1384             return True;
1385          end if;
1386       end loop;
1387
1388       return False;
1389    end Warnings_Suppressed;
1390
1391 end Erroutc;