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-2011, 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 Casing;   use Casing;
  33 with Debug;    use Debug;
  34 with Err_Vars; use Err_Vars;
  35 with Namet;    use Namet;
  36 with Opt;      use Opt;
  37 with Output;   use Output;
  38 with Sinput;   use Sinput;
  39 with Snames;   use Snames;
  40 with Targparm; use Targparm;
  41 with Uintp;    use Uintp;
  42
  43 package body Erroutc is
  44
  45    ---------------
  46    -- Add_Class --
  47    ---------------
  48
  49    procedure Add_Class is
  50    begin
  51       if Class_Flag then
  52          Class_Flag := False;
  53          Set_Msg_Char (''');
  54          Get_Name_String (Name_Class);
  55          Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
  56          Set_Msg_Name_Buffer;
  57       end if;
  58    end Add_Class;
  59
  60    ----------------------
  61    -- Buffer_Ends_With --
  62    ----------------------
  63
  64    function Buffer_Ends_With (S : String) return Boolean is
  65       Len : constant Natural := S'Length;
  66    begin
  67       return
  68         Msglen > Len
  69           and then Msg_Buffer (Msglen - Len) = ' '
  70           and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S;
  71    end Buffer_Ends_With;
  72
  73    -------------------
  74    -- Buffer_Remove --
  75    -------------------
  76
  77    procedure Buffer_Remove (S : String) is
  78    begin
  79       if Buffer_Ends_With (S) then
  80          Msglen := Msglen - S'Length;
  81       end if;
  82    end Buffer_Remove;
  83
  84    -----------------------------
  85    -- Check_Duplicate_Message --
  86    -----------------------------
  87
  88    procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
  89       L1, L2 : Error_Msg_Id;
  90       N1, N2 : Error_Msg_Id;
  91
  92       procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
  93       --  Called to delete message Delete, keeping message Keep. Marks
  94       --  all messages of Delete with deleted flag set to True, and also
  95       --  makes sure that for the error messages that are retained the
  96       --  preferred message is the one retained (we prefer the shorter
  97       --  one in the case where one has an Instance tag). Note that we
  98       --  always know that Keep has at least as many continuations as
  99       --  Delete (since we always delete the shorter sequence).
 100
 101       ----------------
 102       -- Delete_Msg --
 103       ----------------
 104
 105       procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
 106          D, K : Error_Msg_Id;
 107
 108       begin
 109          D := Delete;
 110          K := Keep;
 111
 112          loop
 113             Errors.Table (D).Deleted := True;
 114
 115             --  Adjust error message count
 116
 117             if Errors.Table (D).Warn or else Errors.Table (D).Style then
 118                Warnings_Detected := Warnings_Detected - 1;
 119
 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 continuations 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       Txt   : constant String_Ptr := Errors.Table (E).Text;
 445       Len   : constant Natural    := Txt'Length;
 446       Ptr   : Natural;
 447       Split : Natural;
 448       Start : Natural;
 449
 450    begin
 451       if Error_Msg_Line_Length = 0 then
 452          Length := Nat'Last;
 453       else
 454          Length := Error_Msg_Line_Length;
 455       end if;
 456
 457       Max := Integer (Length - Column + 1);
 458
 459       --  For warning message, add "warning: " unless msg starts with "info: "
 460
 461       if Errors.Table (E).Warn then
 462          if Len < 6 or else Txt (Txt'First .. Txt'First + 5) /= "info: " then
 463             Write_Str ("warning: ");
 464             Max := Max - 9;
 465          end if;
 466
 467       --  No prefix needed for style message, since "(style)" is there already
 468
 469       elsif Errors.Table (E).Style then
 470          null;
 471
 472       --  All other cases, add "error: "
 473
 474       elsif Opt.Unique_Error_Tag then
 475          Write_Str ("error: ");
 476          Max := Max - 7;
 477       end if;
 478
 479       --  Here we have to split the message up into multiple lines
 480
 481       Ptr := 1;
 482       loop
 483          --  Make sure we do not have ludicrously small line
 484
 485          Max := Integer'Max (Max, 20);
 486
 487          --  If remaining text fits, output it respecting LF and we are done
 488
 489          if Len - Ptr < Max then
 490             for J in Ptr .. Len loop
 491                if Txt (J) = ASCII.LF then
 492                   Write_Eol;
 493                   Write_Spaces (Offs);
 494                else
 495                   Write_Char (Txt (J));
 496                end if;
 497             end loop;
 498
 499             return;
 500
 501             --  Line does not fit
 502
 503          else
 504             Start := Ptr;
 505
 506             --  First scan forward looking for a hard end of line
 507
 508             for Scan in Ptr .. Ptr + Max - 1 loop
 509                if Txt (Scan) = ASCII.LF then
 510                   Split := Scan - 1;
 511                   Ptr := Scan + 1;
 512                   goto Continue;
 513                end if;
 514             end loop;
 515
 516             --  Otherwise scan backwards looking for a space
 517
 518             for Scan in reverse Ptr .. Ptr + Max - 1 loop
 519                if Txt (Scan) = ' ' then
 520                   Split := Scan - 1;
 521                   Ptr := Scan + 1;
 522                   goto Continue;
 523                end if;
 524             end loop;
 525
 526             --  If we fall through, no space, so split line arbitrarily
 527
 528             Split := Ptr + Max - 1;
 529             Ptr := Split + 1;
 530          end if;
 531
 532          <<Continue>>
 533          if Start <= Split then
 534             Write_Line (Txt (Start .. Split));
 535             Write_Spaces (Offs);
 536          end if;
 537
 538          Max := Integer (Length - Column + 1);
 539       end loop;
 540    end Output_Msg_Text;
 541
 542    --------------------
 543    -- Purge_Messages --
 544    --------------------
 545
 546    procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
 547       E : Error_Msg_Id;
 548
 549       function To_Be_Purged (E : Error_Msg_Id) return Boolean;
 550       --  Returns True for a message that is to be purged. Also adjusts
 551       --  error counts appropriately.
 552
 553       ------------------
 554       -- To_Be_Purged --
 555       ------------------
 556
 557       function To_Be_Purged (E : Error_Msg_Id) return Boolean is
 558       begin
 559          if E /= No_Error_Msg
 560            and then Errors.Table (E).Sptr > From
 561            and then Errors.Table (E).Sptr < To
 562          then
 563             if Errors.Table (E).Warn or else Errors.Table (E).Style then
 564                Warnings_Detected := Warnings_Detected - 1;
 565
 566             else
 567                Total_Errors_Detected := Total_Errors_Detected - 1;
 568
 569                if Errors.Table (E).Serious then
 570                   Serious_Errors_Detected := Serious_Errors_Detected - 1;
 571                end if;
 572             end if;
 573
 574             return True;
 575
 576          else
 577             return False;
 578          end if;
 579       end To_Be_Purged;
 580
 581    --  Start of processing for Purge_Messages
 582
 583    begin
 584       while To_Be_Purged (First_Error_Msg) loop
 585          First_Error_Msg := Errors.Table (First_Error_Msg).Next;
 586       end loop;
 587
 588       E := First_Error_Msg;
 589       while E /= No_Error_Msg loop
 590          while To_Be_Purged (Errors.Table (E).Next) loop
 591             Errors.Table (E).Next :=
 592               Errors.Table (Errors.Table (E).Next).Next;
 593          end loop;
 594
 595          E := Errors.Table (E).Next;
 596       end loop;
 597    end Purge_Messages;
 598
 599    ----------------
 600    -- Same_Error --
 601    ----------------
 602
 603    function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
 604       Msg1 : constant String_Ptr := Errors.Table (M1).Text;
 605       Msg2 : constant String_Ptr := Errors.Table (M2).Text;
 606
 607       Msg2_Len : constant Integer := Msg2'Length;
 608       Msg1_Len : constant Integer := Msg1'Length;
 609
 610    begin
 611       return
 612         Msg1.all = Msg2.all
 613           or else
 614             (Msg1_Len - 10 > Msg2_Len
 615                and then
 616              Msg2.all = Msg1.all (1 .. Msg2_Len)
 617                and then
 618              Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
 619           or else
 620             (Msg2_Len - 10 > Msg1_Len
 621                and then
 622              Msg1.all = Msg2.all (1 .. Msg1_Len)
 623                and then
 624              Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
 625    end Same_Error;
 626
 627    -------------------
 628    -- Set_Msg_Blank --
 629    -------------------
 630
 631    procedure Set_Msg_Blank is
 632    begin
 633       if Msglen > 0
 634         and then Msg_Buffer (Msglen) /= ' '
 635         and then Msg_Buffer (Msglen) /= '('
 636         and then Msg_Buffer (Msglen) /= '-'
 637         and then not Manual_Quote_Mode
 638       then
 639          Set_Msg_Char (' ');
 640       end if;
 641    end Set_Msg_Blank;
 642
 643    -------------------------------
 644    -- Set_Msg_Blank_Conditional --
 645    -------------------------------
 646
 647    procedure Set_Msg_Blank_Conditional is
 648    begin
 649       if Msglen > 0
 650         and then Msg_Buffer (Msglen) /= ' '
 651         and then Msg_Buffer (Msglen) /= '('
 652         and then Msg_Buffer (Msglen) /= '"'
 653         and then not Manual_Quote_Mode
 654       then
 655          Set_Msg_Char (' ');
 656       end if;
 657    end Set_Msg_Blank_Conditional;
 658
 659    ------------------
 660    -- Set_Msg_Char --
 661    ------------------
 662
 663    procedure Set_Msg_Char (C : Character) is
 664    begin
 665
 666       --  The check for message buffer overflow is needed to deal with cases
 667       --  where insertions get too long (in particular a child unit name can
 668       --  be very long).
 669
 670       if Msglen < Max_Msg_Length then
 671          Msglen := Msglen + 1;
 672          Msg_Buffer (Msglen) := C;
 673       end if;
 674    end Set_Msg_Char;
 675
 676    ---------------------------------
 677    -- Set_Msg_Insertion_File_Name --
 678    ---------------------------------
 679
 680    procedure Set_Msg_Insertion_File_Name is
 681    begin
 682       if Error_Msg_File_1 = No_File then
 683          null;
 684
 685       elsif Error_Msg_File_1 = Error_File_Name then
 686          Set_Msg_Blank;
 687          Set_Msg_Str ("<error>");
 688
 689       else
 690          Set_Msg_Blank;
 691          Get_Name_String (Error_Msg_File_1);
 692          Set_Msg_Quote;
 693          Set_Msg_Name_Buffer;
 694          Set_Msg_Quote;
 695       end if;
 696
 697       --  The following assignments ensure that the second and third {
 698       --  insertion characters will correspond to the Error_Msg_File_2 and
 699       --  Error_Msg_File_3 values and We suppress possible validity checks in
 700       --  case operating in -gnatVa mode, and Error_Msg_File_2 or
 701       --  Error_Msg_File_3 is not needed and has not been set.
 702
 703       declare
 704          pragma Suppress (Range_Check);
 705       begin
 706          Error_Msg_File_1 := Error_Msg_File_2;
 707          Error_Msg_File_2 := Error_Msg_File_3;
 708       end;
 709    end Set_Msg_Insertion_File_Name;
 710
 711    -----------------------------------
 712    -- Set_Msg_Insertion_Line_Number --
 713    -----------------------------------
 714
 715    procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
 716       Sindex_Loc  : Source_File_Index;
 717       Sindex_Flag : Source_File_Index;
 718
 719       procedure Set_At;
 720       --  Outputs "at " unless last characters in buffer are " from ". Certain
 721       --  messages read better with from than at.
 722
 723       ------------
 724       -- Set_At --
 725       ------------
 726
 727       procedure Set_At is
 728       begin
 729          if Msglen < 6
 730            or else Msg_Buffer (Msglen - 5 .. Msglen) /= " from "
 731          then
 732             Set_Msg_Str ("at ");
 733          end if;
 734       end Set_At;
 735
 736    --  Start of processing for Set_Msg_Insertion_Line_Number
 737
 738    begin
 739       Set_Msg_Blank;
 740
 741       if Loc = No_Location then
 742          Set_At;
 743          Set_Msg_Str ("unknown location");
 744
 745       elsif Loc = System_Location then
 746          Set_Msg_Str ("in package System");
 747          Set_Msg_Insertion_Run_Time_Name;
 748
 749       elsif Loc = Standard_Location then
 750          Set_Msg_Str ("in package Standard");
 751
 752       elsif Loc = Standard_ASCII_Location then
 753          Set_Msg_Str ("in package Standard.ASCII");
 754
 755       else
 756          --  Add "at file-name:" if reference is to other than the source
 757          --  file in which the error message is placed. Note that we check
 758          --  full file names, rather than just the source indexes, to
 759          --  deal with generic instantiations from the current file.
 760
 761          Sindex_Loc  := Get_Source_File_Index (Loc);
 762          Sindex_Flag := Get_Source_File_Index (Flag);
 763
 764          if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
 765             Set_At;
 766             Get_Name_String
 767               (Reference_Name (Get_Source_File_Index (Loc)));
 768             Set_Msg_Name_Buffer;
 769             Set_Msg_Char (':');
 770
 771          --  If in current file, add text "at line "
 772
 773          else
 774             Set_At;
 775             Set_Msg_Str ("line ");
 776          end if;
 777
 778          --  Output line number for reference
 779
 780          Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
 781
 782          --  Deal with the instantiation case. We may have a reference to,
 783          --  e.g. a type, that is declared within a generic template, and
 784          --  what we are really referring to is the occurrence in an instance.
 785          --  In this case, the line number of the instantiation is also of
 786          --  interest, and we add a notation:
 787
 788          --    , instance at xxx
 789
 790          --  where xxx is a line number output using this same routine (and
 791          --  the recursion can go further if the instantiation is itself in
 792          --  a generic template).
 793
 794          --  The flag location passed to us in this situation is indeed the
 795          --  line number within the template, but as described in Sinput.L
 796          --  (file sinput-l.ads, section "Handling Generic Instantiations")
 797          --  we can retrieve the location of the instantiation itself from
 798          --  this flag location value.
 799
 800          --  Note: this processing is suppressed if Suppress_Instance_Location
 801          --  is set True. This is used to prevent redundant annotations of the
 802          --  location of the instantiation in the case where we are placing
 803          --  the messages on the instantiation in any case.
 804
 805          if Instantiation (Sindex_Loc) /= No_Location
 806            and then not Suppress_Instance_Location
 807          then
 808             Set_Msg_Str (", instance ");
 809             Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
 810          end if;
 811       end if;
 812    end Set_Msg_Insertion_Line_Number;
 813
 814    ----------------------------
 815    -- Set_Msg_Insertion_Name --
 816    ----------------------------
 817
 818    procedure Set_Msg_Insertion_Name is
 819    begin
 820       if Error_Msg_Name_1 = No_Name then
 821          null;
 822
 823       elsif Error_Msg_Name_1 = Error_Name then
 824          Set_Msg_Blank;
 825          Set_Msg_Str ("<error>");
 826
 827       else
 828          Set_Msg_Blank_Conditional;
 829          Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
 830
 831          --  Remove %s or %b at end. These come from unit names. If the
 832          --  caller wanted the (unit) or (body), then they would have used
 833          --  the $ insertion character. Certainly no error message should
 834          --  ever have %b or %s explicitly occurring.
 835
 836          if Name_Len > 2
 837            and then Name_Buffer (Name_Len - 1) = '%'
 838            and then (Name_Buffer (Name_Len) = 'b'
 839                        or else
 840                      Name_Buffer (Name_Len) = 's')
 841          then
 842             Name_Len := Name_Len - 2;
 843          end if;
 844
 845          --  Remove upper case letter at end, again, we should not be getting
 846          --  such names, and what we hope is that the remainder makes sense.
 847
 848          if Name_Len > 1
 849            and then Name_Buffer (Name_Len) in 'A' .. 'Z'
 850          then
 851             Name_Len := Name_Len - 1;
 852          end if;
 853
 854          --  If operator name or character literal name, just print it as is
 855          --  Also print as is if it ends in a right paren (case of x'val(nnn))
 856
 857          if Name_Buffer (1) = '"'
 858            or else Name_Buffer (1) = '''
 859            or else Name_Buffer (Name_Len) = ')'
 860          then
 861             Set_Msg_Name_Buffer;
 862
 863          --  Else output with surrounding quotes in proper casing mode
 864
 865          else
 866             Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
 867             Set_Msg_Quote;
 868             Set_Msg_Name_Buffer;
 869             Set_Msg_Quote;
 870          end if;
 871       end if;
 872
 873       --  The following assignments ensure that the second and third percent
 874       --  insertion characters will correspond to the Error_Msg_Name_2 and
 875       --  Error_Msg_Name_3 as required. We suppress possible validity checks in
 876       --  case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed
 877       --  and has not been set.
 878
 879       declare
 880          pragma Suppress (Range_Check);
 881       begin
 882          Error_Msg_Name_1 := Error_Msg_Name_2;
 883          Error_Msg_Name_2 := Error_Msg_Name_3;
 884       end;
 885    end Set_Msg_Insertion_Name;
 886
 887    ------------------------------------
 888    -- Set_Msg_Insertion_Name_Literal --
 889    ------------------------------------
 890
 891    procedure Set_Msg_Insertion_Name_Literal is
 892    begin
 893       if Error_Msg_Name_1 = No_Name then
 894          null;
 895
 896       elsif Error_Msg_Name_1 = Error_Name then
 897          Set_Msg_Blank;
 898          Set_Msg_Str ("<error>");
 899
 900       else
 901          Set_Msg_Blank;
 902          Get_Name_String (Error_Msg_Name_1);
 903          Set_Msg_Quote;
 904          Set_Msg_Name_Buffer;
 905          Set_Msg_Quote;
 906       end if;
 907
 908       --  The following assignments ensure that the second and third % or %%
 909       --  insertion characters will correspond to the Error_Msg_Name_2 and
 910       --  Error_Msg_Name_3 values and We suppress possible validity checks in
 911       --  case operating in -gnatVa mode, and Error_Msg_Name_2 or
 912       --  Error_Msg_Name_3 is not needed and has not been set.
 913
 914       declare
 915          pragma Suppress (Range_Check);
 916       begin
 917          Error_Msg_Name_1 := Error_Msg_Name_2;
 918          Error_Msg_Name_2 := Error_Msg_Name_3;
 919       end;
 920    end Set_Msg_Insertion_Name_Literal;
 921
 922    -------------------------------------
 923    -- Set_Msg_Insertion_Reserved_Name --
 924    -------------------------------------
 925
 926    procedure Set_Msg_Insertion_Reserved_Name is
 927    begin
 928       Set_Msg_Blank_Conditional;
 929       Get_Name_String (Error_Msg_Name_1);
 930       Set_Msg_Quote;
 931       Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
 932       Set_Msg_Name_Buffer;
 933       Set_Msg_Quote;
 934    end Set_Msg_Insertion_Reserved_Name;
 935
 936    -------------------------------------
 937    -- Set_Msg_Insertion_Reserved_Word --
 938    -------------------------------------
 939
 940    procedure Set_Msg_Insertion_Reserved_Word
 941      (Text : String;
 942       J    : in out Integer)
 943    is
 944    begin
 945       Set_Msg_Blank_Conditional;
 946       Name_Len := 0;
 947
 948       while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
 949          Add_Char_To_Name_Buffer (Text (J));
 950          J := J + 1;
 951       end loop;
 952
 953       --  Here is where we make the special exception for RM
 954
 955       if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
 956          Set_Msg_Name_Buffer;
 957
 958       --  We make a similar exception for ALFA
 959
 960       elsif Name_Len = 4 and then Name_Buffer (1 .. 4) = "ALFA" then
 961          Set_Msg_Name_Buffer;
 962
 963       --  Neither RM nor ALFA: case appropriately and add surrounding quotes
 964
 965       else
 966          Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
 967          Set_Msg_Quote;
 968          Set_Msg_Name_Buffer;
 969          Set_Msg_Quote;
 970       end if;
 971    end Set_Msg_Insertion_Reserved_Word;
 972
 973    -------------------------------------
 974    -- Set_Msg_Insertion_Run_Time_Name --
 975    -------------------------------------
 976
 977    procedure Set_Msg_Insertion_Run_Time_Name is
 978    begin
 979       if Targparm.Run_Time_Name_On_Target /= No_Name then
 980          Set_Msg_Blank_Conditional;
 981          Set_Msg_Char ('(');
 982          Get_Name_String (Targparm.Run_Time_Name_On_Target);
 983          Set_Casing (Mixed_Case);
 984          Set_Msg_Str (Name_Buffer (1 .. Name_Len));
 985          Set_Msg_Char (')');
 986       end if;
 987    end Set_Msg_Insertion_Run_Time_Name;
 988
 989    ----------------------------
 990    -- Set_Msg_Insertion_Uint --
 991    ----------------------------
 992
 993    procedure Set_Msg_Insertion_Uint is
 994    begin
 995       Set_Msg_Blank;
 996       UI_Image (Error_Msg_Uint_1);
 997
 998       for J in 1 .. UI_Image_Length loop
 999          Set_Msg_Char (UI_Image_Buffer (J));
1000       end loop;
1001
1002       --  The following assignment ensures that a second caret insertion
1003       --  character will correspond to the Error_Msg_Uint_2 parameter. We
1004       --  suppress possible validity checks in case operating in -gnatVa mode,
1005       --  and Error_Msg_Uint_2 is not needed and has not been set.
1006
1007       declare
1008          pragma Suppress (Range_Check);
1009       begin
1010          Error_Msg_Uint_1 := Error_Msg_Uint_2;
1011       end;
1012    end Set_Msg_Insertion_Uint;
1013
1014    -----------------
1015    -- Set_Msg_Int --
1016    -----------------
1017
1018    procedure Set_Msg_Int (Line : Int) is
1019    begin
1020       if Line > 9 then
1021          Set_Msg_Int (Line / 10);
1022       end if;
1023
1024       Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
1025    end Set_Msg_Int;
1026
1027    -------------------------
1028    -- Set_Msg_Name_Buffer --
1029    -------------------------
1030
1031    procedure Set_Msg_Name_Buffer is
1032    begin
1033       for J in 1 .. Name_Len loop
1034          Set_Msg_Char (Name_Buffer (J));
1035       end loop;
1036    end Set_Msg_Name_Buffer;
1037
1038    -------------------
1039    -- Set_Msg_Quote --
1040    -------------------
1041
1042    procedure Set_Msg_Quote is
1043    begin
1044       if not Manual_Quote_Mode then
1045          Set_Msg_Char ('"');
1046       end if;
1047    end Set_Msg_Quote;
1048
1049    -----------------
1050    -- Set_Msg_Str --
1051    -----------------
1052
1053    procedure Set_Msg_Str (Text : String) is
1054    begin
1055       for J in Text'Range loop
1056          Set_Msg_Char (Text (J));
1057       end loop;
1058    end Set_Msg_Str;
1059
1060    ------------------------------
1061    -- Set_Next_Non_Deleted_Msg --
1062    ------------------------------
1063
1064    procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
1065    begin
1066       if E = No_Error_Msg then
1067          return;
1068
1069       else
1070          loop
1071             E := Errors.Table (E).Next;
1072             exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
1073          end loop;
1074       end if;
1075    end Set_Next_Non_Deleted_Msg;
1076
1077    ------------------------------
1078    -- Set_Specific_Warning_Off --
1079    ------------------------------
1080
1081    procedure Set_Specific_Warning_Off
1082      (Loc    : Source_Ptr;
1083       Msg    : String;
1084       Config : Boolean)
1085    is
1086    begin
1087       Specific_Warnings.Append
1088         ((Start      => Loc,
1089           Msg        => new String'(Msg),
1090           Stop       => Source_Last (Current_Source_File),
1091           Open       => True,
1092           Used       => False,
1093           Config     => Config));
1094    end Set_Specific_Warning_Off;
1095
1096    -----------------------------
1097    -- Set_Specific_Warning_On --
1098    -----------------------------
1099
1100    procedure Set_Specific_Warning_On
1101      (Loc : Source_Ptr;
1102       Msg : String;
1103       Err : out Boolean)
1104    is
1105    begin
1106       for J in 1 .. Specific_Warnings.Last loop
1107          declare
1108             SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1109          begin
1110             if Msg = SWE.Msg.all
1111               and then Loc > SWE.Start
1112               and then SWE.Open
1113               and then Get_Source_File_Index (SWE.Start) =
1114                        Get_Source_File_Index (Loc)
1115             then
1116                SWE.Stop := Loc;
1117                SWE.Open := False;
1118                Err := False;
1119
1120                --  If a config pragma is specifically cancelled, consider
1121                --  that it is no longer active as a configuration pragma.
1122
1123                SWE.Config := False;
1124                return;
1125             end if;
1126          end;
1127       end loop;
1128
1129       Err := True;
1130    end Set_Specific_Warning_On;
1131
1132    ---------------------------
1133    -- Set_Warnings_Mode_Off --
1134    ---------------------------
1135
1136    procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is
1137    begin
1138       --  Don't bother with entries from instantiation copies, since we
1139       --  will already have a copy in the template, which is what matters
1140
1141       if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1142          return;
1143       end if;
1144
1145       --  If last entry in table already covers us, this is a redundant
1146       --  pragma Warnings (Off) and can be ignored. This also handles the
1147       --  case where all warnings are suppressed by command line switch.
1148
1149       if Warnings.Last >= Warnings.First
1150         and then Warnings.Table (Warnings.Last).Start <= Loc
1151         and then Loc <= Warnings.Table (Warnings.Last).Stop
1152       then
1153          return;
1154
1155       --  Otherwise establish a new entry, extending from the location of
1156       --  the pragma to the end of the current source file. This ending
1157       --  point will be adjusted by a subsequent pragma Warnings (On).
1158
1159       else
1160          Warnings.Increment_Last;
1161          Warnings.Table (Warnings.Last).Start := Loc;
1162          Warnings.Table (Warnings.Last).Stop :=
1163            Source_Last (Current_Source_File);
1164       end if;
1165    end Set_Warnings_Mode_Off;
1166
1167    --------------------------
1168    -- Set_Warnings_Mode_On --
1169    --------------------------
1170
1171    procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
1172    begin
1173       --  Don't bother with entries from instantiation copies, since we
1174       --  will already have a copy in the template, which is what matters
1175
1176       if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1177          return;
1178       end if;
1179
1180       --  Nothing to do unless command line switch to suppress all warnings
1181       --  is off, and the last entry in the warnings table covers this
1182       --  pragma Warnings (On), in which case adjust the end point.
1183
1184       if (Warnings.Last >= Warnings.First
1185            and then Warnings.Table (Warnings.Last).Start <= Loc
1186            and then Loc <= Warnings.Table (Warnings.Last).Stop)
1187         and then Warning_Mode /= Suppress
1188       then
1189          Warnings.Table (Warnings.Last).Stop := Loc;
1190       end if;
1191    end Set_Warnings_Mode_On;
1192
1193    ------------------------------------
1194    -- Test_Style_Warning_Serious_Msg --
1195    ------------------------------------
1196
1197    procedure Test_Style_Warning_Serious_Msg (Msg : String) is
1198    begin
1199       if Msg (Msg'First) = '\' then
1200          return;
1201       end if;
1202
1203       Is_Serious_Error := True;
1204       Is_Warning_Msg   := False;
1205
1206       Is_Style_Msg :=
1207         (Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)");
1208
1209       if Is_Style_Msg then
1210          Is_Serious_Error := False;
1211       end if;
1212
1213       for J in Msg'Range loop
1214          if Msg (J) = '?'
1215            and then (J = Msg'First or else Msg (J - 1) /= ''')
1216          then
1217             Is_Warning_Msg := True;
1218
1219          elsif Msg (J) = '<'
1220            and then (J = Msg'First or else Msg (J - 1) /= ''')
1221          then
1222             Is_Warning_Msg := Error_Msg_Warn;
1223
1224          elsif Msg (J) = '|'
1225            and then (J = Msg'First or else Msg (J - 1) /= ''')
1226          then
1227             Is_Serious_Error := False;
1228          end if;
1229       end loop;
1230
1231       if Is_Warning_Msg or Is_Style_Msg then
1232          Is_Serious_Error := False;
1233       end if;
1234    end Test_Style_Warning_Serious_Msg;
1235
1236    --------------------------------
1237    -- Validate_Specific_Warnings --
1238    --------------------------------
1239
1240    procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
1241    begin
1242       for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1243          declare
1244             SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1245          begin
1246             if not SWE.Config then
1247                if SWE.Open then
1248                   Eproc.all
1249                     ("?pragma Warnings Off with no matching Warnings On",
1250                      SWE.Start);
1251                elsif not SWE.Used then
1252                   Eproc.all
1253                     ("?no warning suppressed by this pragma", SWE.Start);
1254                end if;
1255             end if;
1256          end;
1257       end loop;
1258    end Validate_Specific_Warnings;
1259
1260    -------------------------------------
1261    -- Warning_Specifically_Suppressed --
1262    -------------------------------------
1263
1264    function Warning_Specifically_Suppressed
1265      (Loc : Source_Ptr;
1266       Msg : String_Ptr) return Boolean
1267    is
1268       function Matches (S : String; P : String) return Boolean;
1269       --  Returns true if the String S patches the pattern P, which can contain
1270       --  wild card chars (*). The entire pattern must match the entire string.
1271
1272       -------------
1273       -- Matches --
1274       -------------
1275
1276       function Matches (S : String; P : String) return Boolean is
1277          Slast : constant Natural := S'Last;
1278          PLast : constant Natural := P'Last;
1279
1280          SPtr : Natural := S'First;
1281          PPtr : Natural := P'First;
1282
1283       begin
1284          --  Loop advancing through characters of string and pattern
1285
1286          SPtr := S'First;
1287          PPtr := P'First;
1288          loop
1289             --  Return True if pattern is a single asterisk
1290
1291             if PPtr = PLast and then P (PPtr) = '*' then
1292                return True;
1293
1294             --  Return True if both pattern and string exhausted
1295
1296             elsif PPtr > PLast and then SPtr > Slast then
1297                return True;
1298
1299             --  Return False, if one exhausted and not the other
1300
1301             elsif PPtr > PLast or else SPtr > Slast then
1302                return False;
1303
1304             --  Case where pattern starts with asterisk
1305
1306             elsif P (PPtr) = '*' then
1307
1308                --  Try all possible starting positions in S for match with
1309                --  the remaining characters of the pattern. This is the
1310                --  recursive call that implements the scanner backup.
1311
1312                for J in SPtr .. Slast loop
1313                   if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then
1314                      return True;
1315                   end if;
1316                end loop;
1317
1318                return False;
1319
1320             --  Dealt with end of string and *, advance if we have a match
1321
1322             elsif S (SPtr) = P (PPtr) then
1323                SPtr := SPtr + 1;
1324                PPtr := PPtr + 1;
1325
1326             --  If first characters do not match, that's decisive
1327
1328             else
1329                return False;
1330             end if;
1331          end loop;
1332       end Matches;
1333
1334    --  Start of processing for Warning_Specifically_Suppressed
1335
1336    begin
1337       --  Loop through specific warning suppression entries
1338
1339       for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1340          declare
1341             SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1342
1343          begin
1344             --  Pragma applies if it is a configuration pragma, or if the
1345             --  location is in range of a specific non-configuration pragma.
1346
1347             if SWE.Config
1348               or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
1349             then
1350                if Matches (Msg.all, SWE.Msg.all) then
1351                   SWE.Used := True;
1352                   return True;
1353                end if;
1354             end if;
1355          end;
1356       end loop;
1357
1358       return False;
1359    end Warning_Specifically_Suppressed;
1360
1361    -------------------------
1362    -- Warnings_Suppressed --
1363    -------------------------
1364
1365    function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
1366    begin
1367       if Warning_Mode = Suppress then
1368          return True;
1369       end if;
1370
1371       --  Loop through table of ON/OFF warnings
1372
1373       for J in Warnings.First .. Warnings.Last loop
1374          if Warnings.Table (J).Start <= Loc
1375            and then Loc <= Warnings.Table (J).Stop
1376          then
1377             return True;
1378          end if;
1379       end loop;
1380
1381       return False;
1382    end Warnings_Suppressed;
1383
1384 end Erroutc;