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