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-2006, 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_Name_1 = No_Name then
 677          null;
 678
 679       elsif Error_Msg_Name_1 = Error_Name then
 680          Set_Msg_Blank;
 681          Set_Msg_Str ("<error>");
 682
 683       else
 684          Set_Msg_Blank;
 685          Get_Name_String (Error_Msg_Name_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 percent
 692       --  insertion characters will correspond to the Error_Msg_Name_2 and
 693       --  Error_Msg_Name_3 as required. We suppress possible validity checks in
 694       --  case operating in -gnatVa mode, and Error_Msg_Name_2/3 is not needed
 695       --  and has not been set.
 696
 697       declare
 698          pragma Suppress (Range_Check);
 699       begin
 700          Error_Msg_Name_1 := Error_Msg_Name_2;
 701          Error_Msg_Name_2 := Error_Msg_Name_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_Reserved_Name --
 862    -------------------------------------
 863
 864    procedure Set_Msg_Insertion_Reserved_Name is
 865    begin
 866       Set_Msg_Blank_Conditional;
 867       Get_Name_String (Error_Msg_Name_1);
 868       Set_Msg_Quote;
 869       Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
 870       Set_Msg_Name_Buffer;
 871       Set_Msg_Quote;
 872    end Set_Msg_Insertion_Reserved_Name;
 873
 874    -------------------------------------
 875    -- Set_Msg_Insertion_Reserved_Word --
 876    -------------------------------------
 877
 878    procedure Set_Msg_Insertion_Reserved_Word
 879      (Text : String;
 880       J    : in out Integer)
 881    is
 882    begin
 883       Set_Msg_Blank_Conditional;
 884       Name_Len := 0;
 885
 886       while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
 887          Name_Len := Name_Len + 1;
 888          Name_Buffer (Name_Len) := Text (J);
 889          J := J + 1;
 890       end loop;
 891
 892       Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
 893       Set_Msg_Quote;
 894       Set_Msg_Name_Buffer;
 895       Set_Msg_Quote;
 896    end Set_Msg_Insertion_Reserved_Word;
 897
 898    -------------------------------------
 899    -- Set_Msg_Insertion_Run_Time_Name --
 900    -------------------------------------
 901
 902    procedure Set_Msg_Insertion_Run_Time_Name is
 903    begin
 904       if Targparm.Run_Time_Name_On_Target /= No_Name then
 905          Set_Msg_Blank_Conditional;
 906          Set_Msg_Char ('(');
 907          Get_Name_String (Targparm.Run_Time_Name_On_Target);
 908          Set_Casing (Mixed_Case);
 909          Set_Msg_Str (Name_Buffer (1 .. Name_Len));
 910          Set_Msg_Char (')');
 911       end if;
 912    end Set_Msg_Insertion_Run_Time_Name;
 913
 914    ----------------------------
 915    -- Set_Msg_Insertion_Uint --
 916    ----------------------------
 917
 918    procedure Set_Msg_Insertion_Uint is
 919    begin
 920       Set_Msg_Blank;
 921       UI_Image (Error_Msg_Uint_1);
 922
 923       for J in 1 .. UI_Image_Length loop
 924          Set_Msg_Char (UI_Image_Buffer (J));
 925       end loop;
 926
 927       --  The following assignment ensures that a second carret insertion
 928       --  character will correspond to the Error_Msg_Uint_2 parameter. We
 929       --  suppress possible validity checks in case operating in -gnatVa mode,
 930       --  and Error_Msg_Uint_2 is not needed and has not been set.
 931
 932       declare
 933          pragma Suppress (Range_Check);
 934       begin
 935          Error_Msg_Uint_1 := Error_Msg_Uint_2;
 936       end;
 937    end Set_Msg_Insertion_Uint;
 938
 939    -----------------
 940    -- Set_Msg_Int --
 941    -----------------
 942
 943    procedure Set_Msg_Int (Line : Int) is
 944    begin
 945       if Line > 9 then
 946          Set_Msg_Int (Line / 10);
 947       end if;
 948
 949       Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
 950    end Set_Msg_Int;
 951
 952    -------------------------
 953    -- Set_Msg_Name_Buffer --
 954    -------------------------
 955
 956    procedure Set_Msg_Name_Buffer is
 957    begin
 958       for J in 1 .. Name_Len loop
 959          Set_Msg_Char (Name_Buffer (J));
 960       end loop;
 961    end Set_Msg_Name_Buffer;
 962
 963    -------------------
 964    -- Set_Msg_Quote --
 965    -------------------
 966
 967    procedure Set_Msg_Quote is
 968    begin
 969       if not Manual_Quote_Mode then
 970          Set_Msg_Char ('"');
 971       end if;
 972    end Set_Msg_Quote;
 973
 974    -----------------
 975    -- Set_Msg_Str --
 976    -----------------
 977
 978    procedure Set_Msg_Str (Text : String) is
 979    begin
 980       for J in Text'Range loop
 981          Set_Msg_Char (Text (J));
 982       end loop;
 983    end Set_Msg_Str;
 984
 985    ------------------------------
 986    -- Set_Next_Non_Deleted_Msg --
 987    ------------------------------
 988
 989    procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
 990    begin
 991       if E = No_Error_Msg then
 992          return;
 993
 994       else
 995          loop
 996             E := Errors.Table (E).Next;
 997             exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
 998          end loop;
 999       end if;
1000    end Set_Next_Non_Deleted_Msg;
1001
1002    ------------------------------
1003    -- Set_Specific_Warning_Off --
1004    ------------------------------
1005
1006    procedure Set_Specific_Warning_Off (Loc : Source_Ptr; Msg : String) is
1007       pragma Assert (Msg'First = 1);
1008
1009       Pattern : String  := Msg;
1010       Patlen  : Natural := Msg'Length;
1011
1012       Star_Start : Boolean;
1013       Star_End   : Boolean;
1014
1015    begin
1016       if Pattern (1) = '*' then
1017          Star_Start := True;
1018          Pattern (1 .. Patlen - 1) := Pattern (2 .. Patlen);
1019          Patlen := Patlen - 1;
1020       else
1021          Star_Start := False;
1022       end if;
1023
1024       if Pattern (Patlen) = '*' then
1025          Star_End := True;
1026          Patlen := Patlen - 1;
1027       else
1028          Star_End := False;
1029       end if;
1030
1031       Specific_Warnings.Increment_Last;
1032       Specific_Warnings.Table (Specific_Warnings.Last) :=
1033         (Start      => Loc,
1034          Msg        => new String'(Msg),
1035          Pattern    => new String'(Pattern (1 .. Patlen)),
1036          Patlen     => Patlen,
1037          Stop       => Source_Last (Current_Source_File),
1038          Open       => True,
1039          Used       => False,
1040          Star_Start => Star_Start,
1041          Star_End   => Star_End);
1042    end Set_Specific_Warning_Off;
1043
1044    -----------------------------
1045    -- Set_Specific_Warning_On --
1046    -----------------------------
1047
1048    procedure Set_Specific_Warning_On
1049      (Loc : Source_Ptr;
1050       Msg : String;
1051       Err : out Boolean)
1052    is
1053    begin
1054       for J in 1 .. Specific_Warnings.Last loop
1055          declare
1056             SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1057          begin
1058             if Msg = SWE.Msg.all
1059               and then Loc > SWE.Start
1060               and then SWE.Open
1061               and then Get_Source_File_Index (SWE.Start) =
1062                        Get_Source_File_Index (Loc)
1063             then
1064                SWE.Stop := Loc;
1065                SWE.Open := False;
1066                Err := False;
1067                return;
1068             end if;
1069          end;
1070       end loop;
1071
1072       Err := True;
1073    end Set_Specific_Warning_On;
1074
1075    ---------------------------
1076    -- Set_Warnings_Mode_Off --
1077    ---------------------------
1078
1079    procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is
1080    begin
1081       --  Don't bother with entries from instantiation copies, since we
1082       --  will already have a copy in the template, which is what matters
1083
1084       if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1085          return;
1086       end if;
1087
1088       --  If last entry in table already covers us, this is a redundant
1089       --  pragma Warnings (Off) and can be ignored. This also handles the
1090       --  case where all warnings are suppressed by command line switch.
1091
1092       if Warnings.Last >= Warnings.First
1093         and then Warnings.Table (Warnings.Last).Start <= Loc
1094         and then Loc <= Warnings.Table (Warnings.Last).Stop
1095       then
1096          return;
1097
1098       --  Otherwise establish a new entry, extending from the location of
1099       --  the pragma to the end of the current source file. This ending
1100       --  point will be adjusted by a subsequent pragma Warnings (On).
1101
1102       else
1103          Warnings.Increment_Last;
1104          Warnings.Table (Warnings.Last).Start := Loc;
1105          Warnings.Table (Warnings.Last).Stop :=
1106            Source_Last (Current_Source_File);
1107       end if;
1108    end Set_Warnings_Mode_Off;
1109
1110    --------------------------
1111    -- Set_Warnings_Mode_On --
1112    --------------------------
1113
1114    procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
1115    begin
1116       --  Don't bother with entries from instantiation copies, since we
1117       --  will already have a copy in the template, which is what matters
1118
1119       if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1120          return;
1121       end if;
1122
1123       --  Nothing to do unless command line switch to suppress all warnings
1124       --  is off, and the last entry in the warnings table covers this
1125       --  pragma Warnings (On), in which case adjust the end point.
1126
1127       if (Warnings.Last >= Warnings.First
1128            and then Warnings.Table (Warnings.Last).Start <= Loc
1129            and then Loc <= Warnings.Table (Warnings.Last).Stop)
1130         and then Warning_Mode /= Suppress
1131       then
1132          Warnings.Table (Warnings.Last).Stop := Loc;
1133       end if;
1134    end Set_Warnings_Mode_On;
1135
1136    ------------------------------------
1137    -- Test_Style_Warning_Serious_Msg --
1138    ------------------------------------
1139
1140    procedure Test_Style_Warning_Serious_Msg (Msg : String) is
1141    begin
1142       if Msg (Msg'First) = '\' then
1143          return;
1144       end if;
1145
1146       Is_Serious_Error := True;
1147       Is_Warning_Msg   := False;
1148
1149       Is_Style_Msg :=
1150         (Msg'Length > 7
1151            and then Msg (Msg'First .. Msg'First + 6) = "(style)");
1152
1153       for J in Msg'Range loop
1154          if Msg (J) = '?'
1155            and then (J = Msg'First or else Msg (J - 1) /= ''')
1156          then
1157             Is_Warning_Msg := True;
1158
1159          elsif Msg (J) = '<'
1160            and then (J = Msg'First or else Msg (J - 1) /= ''')
1161          then
1162             Is_Warning_Msg := Error_Msg_Warn;
1163
1164          elsif Msg (J) = '|'
1165            and then (J = Msg'First or else Msg (J - 1) /= ''')
1166          then
1167             Is_Serious_Error := False;
1168          end if;
1169       end loop;
1170
1171       if Is_Warning_Msg or else Is_Style_Msg then
1172          Is_Serious_Error := False;
1173       end if;
1174    end Test_Style_Warning_Serious_Msg;
1175
1176    --------------------------------
1177    -- Validate_Specific_Warnings --
1178    --------------------------------
1179
1180    procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
1181    begin
1182       for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1183          declare
1184             SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1185          begin
1186             if SWE.Start /= No_Location then
1187                if SWE.Open then
1188                   Eproc.all
1189                     ("?pragma Warnings Off with no matching Warnings On",
1190                      SWE.Start);
1191                elsif not SWE.Used then
1192                   Eproc.all
1193                     ("?no warning suppressed by this pragma", SWE.Start);
1194                end if;
1195             end if;
1196          end;
1197       end loop;
1198    end Validate_Specific_Warnings;
1199
1200    -------------------------------------
1201    -- Warning_Specifically_Suppressed --
1202    -------------------------------------
1203
1204    function Warning_Specifically_Suppressed
1205      (Loc : Source_Ptr;
1206       Msg : String_Ptr) return Boolean
1207    is
1208       pragma Assert (Msg'First = 1);
1209
1210       Msglen : constant Natural := Msg'Length;
1211       Patlen : Natural;
1212       --  Length of message
1213
1214       Pattern : String_Ptr;
1215       --  Pattern itself, excluding initial and final *
1216
1217       Star_Start : Boolean;
1218       Star_End   : Boolean;
1219       --  Indications of * at start and end of original pattern
1220
1221       Msgp : Natural;
1222       Patp : Natural;
1223       --  Scan pointers for message and pattern
1224
1225    begin
1226       --  Loop through specific warning suppression entries
1227
1228       for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1229          declare
1230             SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1231
1232          begin
1233             --  See if location is in range
1234
1235             if SWE.Start = No_Location
1236               or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
1237             then
1238                Patlen     := SWE.Patlen;
1239                Pattern    := SWE.Pattern;
1240                Star_Start := SWE.Star_Start;
1241                Star_End   := SWE.Star_End;
1242
1243                --  Loop through possible starting positions in Msg
1244
1245                Outer : for M in 1 .. 1 + (Msglen - Patlen) loop
1246
1247                   --  See if pattern matches string starting at Msg (J)
1248
1249                   Msgp := M;
1250                   Patp := 1;
1251                   Inner : loop
1252
1253                      --  If pattern exhausted, then match if we are at end
1254                      --  of message, or if pattern ended with an asterisk,
1255                      --  otherwise match failure at this position.
1256
1257                      if Patp > Patlen then
1258                         if Msgp > Msglen or else Star_End then
1259                            SWE.Used := True;
1260                            return True;
1261                         else
1262                            exit Inner;
1263                         end if;
1264
1265                         --  Otherwise if message exhausted (and we still have
1266                         --  pattern characters left), then match failure here.
1267
1268                      elsif Msgp > Msglen then
1269                         exit Inner;
1270                      end if;
1271
1272                      --  Here we have pattern and message characters left
1273
1274                      --  Handle "*" pattern match
1275
1276                      if Patp < Patlen - 1 and then
1277                        Pattern (Patp .. Patp + 2) = """*"""
1278                      then
1279                         Patp := Patp + 3;
1280
1281                         --  Must have " and at least three chars in msg or we
1282                         --  have no match at this position.
1283
1284                         exit Inner when Msg (Msgp) /= '"';
1285                         Msgp := Msgp + 1;
1286
1287                         --  Scan out " string " in message
1288
1289                         Scan : loop
1290                            exit Inner when Msgp = Msglen;
1291                            Msgp := Msgp + 1;
1292                            exit Scan when Msg (Msgp - 1) = '"';
1293                         end loop Scan;
1294
1295                      --  If not "*" case, just compare character
1296
1297                      else
1298                         exit Inner when Pattern (Patp) /= Msg (Msgp);
1299                         Patp := Patp + 1;
1300                         Msgp := Msgp + 1;
1301                      end if;
1302                   end loop Inner;
1303
1304                   --  Advance to next position if star at end of original
1305                   --  pattern, otherwise no more match attempts are possible
1306
1307                   exit Outer when not Star_Start;
1308                end loop Outer;
1309             end if;
1310          end;
1311       end loop;
1312
1313       return False;
1314    end Warning_Specifically_Suppressed;
1315
1316    -------------------------
1317    -- Warnings_Suppressed --
1318    -------------------------
1319
1320    function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
1321    begin
1322       --  Loop through table of ON/OFF warnings
1323
1324       for J in Warnings.First .. Warnings.Last loop
1325          if Warnings.Table (J).Start <= Loc
1326            and then Loc <= Warnings.Table (J).Stop
1327          then
1328             return True;
1329          end if;
1330       end loop;
1331
1332       return False;
1333    end Warnings_Suppressed;
1334
1335 end Erroutc;