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