gcc/ada/erroutc.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              E R R O U T C                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 --  Warning! Error messages can be generated during Gigi processing by direct
  28 --  calls to error message routines, so it is essential that the processing
  29 --  in this body be consistent with the requirements for the Gigi processing
  30 --  environment, and that in particular, no disallowed table expansion is
  31 --  allowed to occur.
  32
  33 with Casing;   use Casing;
  34 with Debug;    use Debug;
  35 with Err_Vars; use Err_Vars;
  36 with Namet;    use Namet;
  37 with Opt;      use Opt;
  38 with Output;   use Output;
  39 with Sinput;   use Sinput;
  40 with Snames;   use Snames;
  41 with Targparm; use Targparm;
  42 with Uintp;    use Uintp;
  43
  44 package body Erroutc is
  45
  46    -----------------------
  47    -- Local Subprograms --
  48    -----------------------
  49
  50    ---------------
  51    -- Add_Class --
  52    ---------------
  53
  54    procedure Add_Class is
  55    begin
  56       if Class_Flag then
  57          Class_Flag := False;
  58          Set_Msg_Char (''');
  59          Get_Name_String (Name_Class);
  60          Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
  61          Set_Msg_Name_Buffer;
  62       end if;
  63    end Add_Class;
  64
  65    ----------------------
  66    -- Buffer_Ends_With --
  67    ----------------------
  68
  69    function Buffer_Ends_With (S : String) return Boolean is
  70       Len : constant Natural := S'Length;
  71    begin
  72       return
  73         Msglen > Len
  74           and then Msg_Buffer (Msglen - Len) = ' '
  75           and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S;
  76    end Buffer_Ends_With;
  77
  78    -------------------
  79    -- Buffer_Remove --
  80    -------------------
  81
  82    procedure Buffer_Remove (S : String) is
  83    begin
  84       if Buffer_Ends_With (S) then
  85          Msglen := Msglen - S'Length;
  86       end if;
  87    end Buffer_Remove;
  88
  89    -----------------------------
  90    -- Check_Duplicate_Message --
  91    -----------------------------
  92
  93    procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
  94       L1, L2 : Error_Msg_Id;
  95       N1, N2 : Error_Msg_Id;
  96
  97       procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
  98       --  Called to delete message Delete, keeping message Keep. Marks
  99       --  all messages of Delete with deleted flag set to True, and also
 100       --  makes sure that for the error messages that are retained the
 101       --  preferred message is the one retained (we prefer the shorter
 102       --  one in the case where one has an Instance tag). Note that we
 103       --  always know that Keep has at least as many continuations as
 104       --  Delete (since we always delete the shorter sequence).
 105
 106       ----------------
 107       -- Delete_Msg --
 108       ----------------
 109
 110       procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
 111          D, K : Error_Msg_Id;
 112
 113       begin
 114          D := Delete;
 115          K := Keep;
 116
 117          loop
 118             Errors.Table (D).Deleted := True;
 119
 120             --  Adjust error message count
 121
 122             if Errors.Table (D).Warn or Errors.Table (D).Style then
 123                Warnings_Detected := Warnings_Detected - 1;
 124             else
 125                Total_Errors_Detected := Total_Errors_Detected - 1;
 126
 127                if Errors.Table (D).Serious then
 128                   Serious_Errors_Detected := Serious_Errors_Detected - 1;
 129                end if;
 130             end if;
 131
 132             --  Substitute shorter of the two error messages
 133
 134             if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
 135                Errors.Table (K).Text := Errors.Table (D).Text;
 136             end if;
 137
 138             D := Errors.Table (D).Next;
 139             K := Errors.Table (K).Next;
 140
 141             if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
 142                return;
 143             end if;
 144          end loop;
 145       end Delete_Msg;
 146
 147    --  Start of processing for Check_Duplicate_Message
 148
 149    begin
 150       --  Both messages must be non-continuation messages and not deleted
 151
 152       if Errors.Table (M1).Msg_Cont
 153         or else Errors.Table (M2).Msg_Cont
 154         or else Errors.Table (M1).Deleted
 155         or else Errors.Table (M2).Deleted
 156       then
 157          return;
 158       end if;
 159
 160       --  Definitely not equal if message text does not match
 161
 162       if not Same_Error (M1, M2) then
 163          return;
 164       end if;
 165
 166       --  Same text. See if all continuations are also identical
 167
 168       L1 := M1;
 169       L2 := M2;
 170
 171       loop
 172          N1 := Errors.Table (L1).Next;
 173          N2 := Errors.Table (L2).Next;
 174
 175          --  If M1 continuations have run out, we delete M1, either the
 176          --  messages have the same number of continuations, or M2 has
 177          --  more and we prefer the one with more anyway.
 178
 179          if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
 180             Delete_Msg (M1, M2);
 181             return;
 182
 183          --  If M2 continuatins have run out, we delete M2
 184
 185          elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
 186             Delete_Msg (M2, M1);
 187             return;
 188
 189          --  Otherwise see if continuations are the same, if not, keep both
 190          --  sequences, a curious case, but better to keep everything!
 191
 192          elsif not Same_Error (N1, N2) then
 193             return;
 194
 195          --  If continuations are the same, continue scan
 196
 197          else
 198             L1 := N1;
 199             L2 := N2;
 200          end if;
 201       end loop;
 202    end Check_Duplicate_Message;
 203
 204    ------------------------
 205    -- Compilation_Errors --
 206    ------------------------
 207
 208    function Compilation_Errors return Boolean is
 209    begin
 210       return Total_Errors_Detected /= 0
 211         or else (Warnings_Detected /= 0
 212                   and then Warning_Mode = Treat_As_Error);
 213    end Compilation_Errors;
 214
 215    ------------------
 216    -- Debug_Output --
 217    ------------------
 218
 219    procedure Debug_Output (N : Node_Id) is
 220    begin
 221       if Debug_Flag_1 then
 222          Write_Str ("*** following error message posted on node id = #");
 223          Write_Int (Int (N));
 224          Write_Str (" ***");
 225          Write_Eol;
 226       end if;
 227    end Debug_Output;
 228
 229    ----------
 230    -- dmsg --
 231    ----------
 232
 233    procedure dmsg (Id : Error_Msg_Id) is
 234       E : Error_Msg_Object renames Errors.Table (Id);
 235
 236    begin
 237       w ("Dumping error message, Id = ", Int (Id));
 238       w ("  Text     = ", E.Text.all);
 239       w ("  Next     = ", Int (E.Next));
 240       w ("  Sfile    = ", Int (E.Sfile));
 241
 242       Write_Str
 243         ("  Sptr     = ");
 244       Write_Location (E.Sptr);
 245       Write_Eol;
 246
 247       Write_Str
 248         ("  Optr     = ");
 249       Write_Location (E.Optr);
 250       Write_Eol;
 251
 252       w ("  Line     = ", Int (E.Line));
 253       w ("  Col      = ", Int (E.Col));
 254       w ("  Warn     = ", E.Warn);
 255       w ("  Style    = ", E.Style);
 256       w ("  Serious  = ", E.Serious);
 257       w ("  Uncond   = ", E.Uncond);
 258       w ("  Msg_Cont = ", E.Msg_Cont);
 259       w ("  Deleted  = ", E.Deleted);
 260
 261       Write_Eol;
 262    end dmsg;
 263
 264    ------------------
 265    -- Get_Location --
 266    ------------------
 267
 268    function Get_Location (E : Error_Msg_Id) return Source_Ptr is
 269    begin
 270       return Errors.Table (E).Sptr;
 271    end Get_Location;
 272
 273    ----------------
 274    -- Get_Msg_Id --
 275    ----------------
 276
 277    function Get_Msg_Id return Error_Msg_Id is
 278    begin
 279       return Cur_Msg;
 280    end Get_Msg_Id;
 281
 282    -----------------------
 283    -- Output_Error_Msgs --
 284    -----------------------
 285
 286    procedure Output_Error_Msgs (E : in out Error_Msg_Id) is
 287       P : Source_Ptr;
 288       T : Error_Msg_Id;
 289       S : Error_Msg_Id;
 290
 291       Flag_Num   : Pos;
 292       Mult_Flags : Boolean := False;
 293
 294    begin
 295       S := E;
 296
 297       --  Skip deleted messages at start
 298
 299       if Errors.Table (S).Deleted then
 300          Set_Next_Non_Deleted_Msg (S);
 301       end if;
 302
 303       --  Figure out if we will place more than one error flag on this line
 304
 305       T := S;
 306       while T /= No_Error_Msg
 307         and then Errors.Table (T).Line = Errors.Table (E).Line
 308         and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
 309       loop
 310          if Errors.Table (T).Sptr > Errors.Table (E).Sptr then
 311             Mult_Flags := True;
 312          end if;
 313
 314          Set_Next_Non_Deleted_Msg (T);
 315       end loop;
 316
 317       --  Output the error flags. The circuit here makes sure that the tab
 318       --  characters in the original line are properly accounted for. The
 319       --  eight blanks at the start are to match the line number.
 320
 321       if not Debug_Flag_2 then
 322          Write_Str ("        ");
 323          P := Line_Start (Errors.Table (E).Sptr);
 324          Flag_Num := 1;
 325
 326          --  Loop through error messages for this line to place flags
 327
 328          T := S;
 329          while T /= No_Error_Msg
 330            and then Errors.Table (T).Line = Errors.Table (E).Line
 331            and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
 332          loop
 333             --  Loop to output blanks till current flag position
 334
 335             while P < Errors.Table (T).Sptr loop
 336                if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then
 337                   Write_Char (ASCII.HT);
 338                else
 339                   Write_Char (' ');
 340                end if;
 341
 342                P := P + 1;
 343             end loop;
 344
 345             --  Output flag (unless already output, this happens if more
 346             --  than one error message occurs at the same flag position).
 347
 348             if P = Errors.Table (T).Sptr then
 349                if (Flag_Num = 1 and then not Mult_Flags)
 350                  or else Flag_Num > 9
 351                then
 352                   Write_Char ('|');
 353                else
 354                   Write_Char (Character'Val (Character'Pos ('0') + Flag_Num));
 355                end if;
 356
 357                P := P + 1;
 358             end if;
 359
 360             Set_Next_Non_Deleted_Msg (T);
 361             Flag_Num := Flag_Num + 1;
 362          end loop;
 363
 364          Write_Eol;
 365       end if;
 366
 367       --  Now output the error messages
 368
 369       T := S;
 370       while T /= No_Error_Msg
 371         and then Errors.Table (T).Line = Errors.Table (E).Line
 372         and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
 373
 374       loop
 375          Write_Str ("        >>> ");
 376          Output_Msg_Text (T);
 377
 378          if Debug_Flag_2 then
 379             while Column < 74 loop
 380                Write_Char (' ');
 381             end loop;
 382
 383             Write_Str (" <<<");
 384          end if;
 385
 386          Write_Eol;
 387          Set_Next_Non_Deleted_Msg (T);
 388       end loop;
 389
 390       E := T;
 391    end Output_Error_Msgs;
 392
 393    ------------------------
 394    -- Output_Line_Number --
 395    ------------------------
 396
 397    procedure Output_Line_Number (L : Logical_Line_Number) is
 398       D     : Int;       -- next digit
 399       C     : Character; -- next character
 400       Z     : Boolean;   -- flag for zero suppress
 401       N, M  : Int;       -- temporaries
 402
 403    begin
 404       if L = No_Line_Number then
 405          Write_Str ("        ");
 406
 407       else
 408          Z := False;
 409          N := Int (L);
 410
 411          M := 100_000;
 412          while M /= 0 loop
 413             D := Int (N / M);
 414             N := N rem M;
 415             M := M / 10;
 416
 417             if D = 0 then
 418                if Z then
 419                   C := '0';
 420                else
 421                   C := ' ';
 422                end if;
 423             else
 424                Z := True;
 425                C := Character'Val (D + 48);
 426             end if;
 427
 428             Write_Char (C);
 429          end loop;
 430
 431          Write_Str (". ");
 432       end if;
 433    end Output_Line_Number;
 434
 435    ---------------------
 436    -- Output_Msg_Text --
 437    ---------------------
 438
 439    procedure Output_Msg_Text (E : Error_Msg_Id) is
 440    begin
 441       if Errors.Table (E).Warn then
 442          Write_Str ("warning: ");
 443
 444       elsif Errors.Table (E).Style then
 445          null;
 446
 447       elsif Opt.Unique_Error_Tag then
 448          Write_Str ("error: ");
 449       end if;
 450
 451       Write_Str (Errors.Table (E).Text.all);
 452    end Output_Msg_Text;
 453
 454    --------------------
 455    -- Purge_Messages --
 456    --------------------
 457
 458    procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
 459       E : Error_Msg_Id;
 460
 461       function To_Be_Purged (E : Error_Msg_Id) return Boolean;
 462       --  Returns True for a message that is to be purged. Also adjusts
 463       --  error counts appropriately.
 464
 465       ------------------
 466       -- To_Be_Purged --
 467       ------------------
 468
 469       function To_Be_Purged (E : Error_Msg_Id) return Boolean is
 470       begin
 471          if E /= No_Error_Msg
 472            and then Errors.Table (E).Sptr > From
 473            and then Errors.Table (E).Sptr < To
 474          then
 475             if Errors.Table (E).Warn or Errors.Table (E).Style then
 476                Warnings_Detected := Warnings_Detected - 1;
 477             else
 478                Total_Errors_Detected := Total_Errors_Detected - 1;
 479
 480                if Errors.Table (E).Serious then
 481                   Serious_Errors_Detected := Serious_Errors_Detected - 1;
 482                end if;
 483             end if;
 484
 485             return True;
 486
 487          else
 488             return False;
 489          end if;
 490       end To_Be_Purged;
 491
 492    --  Start of processing for Purge_Messages
 493
 494    begin
 495       while To_Be_Purged (First_Error_Msg) loop
 496          First_Error_Msg := Errors.Table (First_Error_Msg).Next;
 497       end loop;
 498
 499       E := First_Error_Msg;
 500       while E /= No_Error_Msg loop
 501          while To_Be_Purged (Errors.Table (E).Next) loop
 502             Errors.Table (E).Next :=
 503               Errors.Table (Errors.Table (E).Next).Next;
 504          end loop;
 505
 506          E := Errors.Table (E).Next;
 507       end loop;
 508    end Purge_Messages;
 509
 510    ----------------
 511    -- Same_Error --
 512    ----------------
 513
 514    function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
 515       Msg1 : constant String_Ptr := Errors.Table (M1).Text;
 516       Msg2 : constant String_Ptr := Errors.Table (M2).Text;
 517
 518       Msg2_Len : constant Integer := Msg2'Length;
 519       Msg1_Len : constant Integer := Msg1'Length;
 520
 521    begin
 522       return
 523         Msg1.all = Msg2.all
 524           or else
 525             (Msg1_Len - 10 > Msg2_Len
 526                and then
 527              Msg2.all = Msg1.all (1 .. Msg2_Len)
 528                and then
 529              Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
 530           or else
 531             (Msg2_Len - 10 > Msg1_Len
 532                and then
 533              Msg1.all = Msg2.all (1 .. Msg1_Len)
 534                and then
 535              Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
 536    end Same_Error;
 537
 538    -------------------
 539    -- Set_Msg_Blank --
 540    -------------------
 541
 542    procedure Set_Msg_Blank is
 543    begin
 544       if Msglen > 0
 545         and then Msg_Buffer (Msglen) /= ' '
 546         and then Msg_Buffer (Msglen) /= '('
 547         and then Msg_Buffer (Msglen) /= '-'
 548         and then not Manual_Quote_Mode
 549       then
 550          Set_Msg_Char (' ');
 551       end if;
 552    end Set_Msg_Blank;
 553
 554    -------------------------------
 555    -- Set_Msg_Blank_Conditional --
 556    -------------------------------
 557
 558    procedure Set_Msg_Blank_Conditional is
 559    begin
 560       if Msglen > 0
 561         and then Msg_Buffer (Msglen) /= ' '
 562         and then Msg_Buffer (Msglen) /= '('
 563         and then Msg_Buffer (Msglen) /= '"'
 564         and then not Manual_Quote_Mode
 565       then
 566          Set_Msg_Char (' ');
 567       end if;
 568    end Set_Msg_Blank_Conditional;
 569
 570    ------------------
 571    -- Set_Msg_Char --
 572    ------------------
 573
 574    procedure Set_Msg_Char (C : Character) is
 575    begin
 576
 577       --  The check for message buffer overflow is needed to deal with cases
 578       --  where insertions get too long (in particular a child unit name can
 579       --  be very long).
 580
 581       if Msglen < Max_Msg_Length then
 582          Msglen := Msglen + 1;
 583          Msg_Buffer (Msglen) := C;
 584       end if;
 585    end Set_Msg_Char;
 586
 587    ---------------------------------
 588    -- Set_Msg_Insertion_File_Name --
 589    ---------------------------------
 590
 591    procedure Set_Msg_Insertion_File_Name is
 592    begin
 593       if Error_Msg_Name_1 = No_Name then
 594          null;
 595
 596       elsif Error_Msg_Name_1 = Error_Name then
 597          Set_Msg_Blank;
 598          Set_Msg_Str ("<error>");
 599
 600       else
 601          Set_Msg_Blank;
 602          Get_Name_String (Error_Msg_Name_1);
 603          Set_Msg_Quote;
 604          Set_Msg_Name_Buffer;
 605          Set_Msg_Quote;
 606       end if;
 607
 608       --  The following assignments ensure that the second and third percent
 609       --  insertion characters will correspond to the Error_Msg_Name_2 and
 610       --  Error_Msg_Name_3 as required. We suppress possible validity checks in
 611       --  case operating in -gnatVa mode, and Error_Msg_Name_2/3 is not needed
 612       --  and has not been set.
 613
 614       declare
 615          pragma Suppress (Range_Check);
 616       begin
 617          Error_Msg_Name_1 := Error_Msg_Name_2;
 618          Error_Msg_Name_2 := Error_Msg_Name_3;
 619       end;
 620    end Set_Msg_Insertion_File_Name;
 621
 622    -----------------------------------
 623    -- Set_Msg_Insertion_Line_Number --
 624    -----------------------------------
 625
 626    procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
 627       Sindex_Loc  : Source_File_Index;
 628       Sindex_Flag : Source_File_Index;
 629
 630    begin
 631       Set_Msg_Blank;
 632
 633       if Loc = No_Location then
 634          Set_Msg_Str ("at unknown location");
 635
 636       elsif Loc = System_Location then
 637          Set_Msg_Str ("in package System");
 638          Set_Msg_Insertion_Run_Time_Name;
 639
 640       elsif Loc = Standard_Location then
 641          Set_Msg_Str ("in package Standard");
 642
 643       elsif Loc = Standard_ASCII_Location then
 644          Set_Msg_Str ("in package Standard.ASCII");
 645
 646       else
 647          --  Add "at file-name:" if reference is to other than the source
 648          --  file in which the error message is placed. Note that we check
 649          --  full file names, rather than just the source indexes, to
 650          --  deal with generic instantiations from the current file.
 651
 652          Sindex_Loc  := Get_Source_File_Index (Loc);
 653          Sindex_Flag := Get_Source_File_Index (Flag);
 654
 655          if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
 656             Set_Msg_Str ("at ");
 657             Get_Name_String
 658               (Reference_Name (Get_Source_File_Index (Loc)));
 659             Set_Msg_Name_Buffer;
 660             Set_Msg_Char (':');
 661
 662          --  If in current file, add text "at line "
 663
 664          else
 665             Set_Msg_Str ("at line ");
 666          end if;
 667
 668          --  Output line number for reference
 669
 670          Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
 671
 672          --  Deal with the instantiation case. We may have a reference to,
 673          --  e.g. a type, that is declared within a generic template, and
 674          --  what we are really referring to is the occurrence in an instance.
 675          --  In this case, the line number of the instantiation is also of
 676          --  interest, and we add a notation:
 677
 678          --    , instance at xxx
 679
 680          --  where xxx is a line number output using this same routine (and
 681          --  the recursion can go further if the instantiation is itself in
 682          --  a generic template).
 683
 684          --  The flag location passed to us in this situation is indeed the
 685          --  line number within the template, but as described in Sinput.L
 686          --  (file sinput-l.ads, section "Handling Generic Instantiations")
 687          --  we can retrieve the location of the instantiation itself from
 688          --  this flag location value.
 689
 690          --  Note: this processing is suppressed if Suppress_Instance_Location
 691          --  is set True. This is used to prevent redundant annotations of the
 692          --  location of the instantiation in the case where we are placing
 693          --  the messages on the instantiation in any case.
 694
 695          if Instantiation (Sindex_Loc) /= No_Location
 696            and then not Suppress_Instance_Location
 697          then
 698             Set_Msg_Str (", instance ");
 699             Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
 700          end if;
 701       end if;
 702    end Set_Msg_Insertion_Line_Number;
 703
 704    ----------------------------
 705    -- Set_Msg_Insertion_Name --
 706    ----------------------------
 707
 708    procedure Set_Msg_Insertion_Name is
 709    begin
 710       if Error_Msg_Name_1 = No_Name then
 711          null;
 712
 713       elsif Error_Msg_Name_1 = Error_Name then
 714          Set_Msg_Blank;
 715          Set_Msg_Str ("<error>");
 716
 717       else
 718          Set_Msg_Blank_Conditional;
 719          Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
 720
 721          --  Remove %s or %b at end. These come from unit names. If the
 722          --  caller wanted the (unit) or (body), then they would have used
 723          --  the $ insertion character. Certainly no error message should
 724          --  ever have %b or %s explicitly occurring.
 725
 726          if Name_Len > 2
 727            and then Name_Buffer (Name_Len - 1) = '%'
 728            and then (Name_Buffer (Name_Len) = 'b'
 729                        or else
 730                      Name_Buffer (Name_Len) = 's')
 731          then
 732             Name_Len := Name_Len - 2;
 733          end if;
 734
 735          --  Remove upper case letter at end, again, we should not be getting
 736          --  such names, and what we hope is that the remainder makes sense.
 737
 738          if Name_Len > 1
 739            and then Name_Buffer (Name_Len) in 'A' .. 'Z'
 740          then
 741             Name_Len := Name_Len - 1;
 742          end if;
 743
 744          --  If operator name or character literal name, just print it as is
 745          --  Also print as is if it ends in a right paren (case of x'val(nnn))
 746
 747          if Name_Buffer (1) = '"'
 748            or else Name_Buffer (1) = '''
 749            or else Name_Buffer (Name_Len) = ')'
 750          then
 751             Set_Msg_Name_Buffer;
 752
 753          --  Else output with surrounding quotes in proper casing mode
 754
 755          else
 756             Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
 757             Set_Msg_Quote;
 758             Set_Msg_Name_Buffer;
 759             Set_Msg_Quote;
 760          end if;
 761       end if;
 762
 763       --  The following assignments ensure that the second and third percent
 764       --  insertion characters will correspond to the Error_Msg_Name_2 and
 765       --  Error_Msg_Name_3 as required. We suppress possible validity checks in
 766       --  case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed
 767       --  and has not been set.
 768
 769       declare
 770          pragma Suppress (Range_Check);
 771       begin
 772          Error_Msg_Name_1 := Error_Msg_Name_2;
 773          Error_Msg_Name_2 := Error_Msg_Name_3;
 774       end;
 775    end Set_Msg_Insertion_Name;
 776
 777    -------------------------------------
 778    -- Set_Msg_Insertion_Reserved_Name --
 779    -------------------------------------
 780
 781    procedure Set_Msg_Insertion_Reserved_Name is
 782    begin
 783       Set_Msg_Blank_Conditional;
 784       Get_Name_String (Error_Msg_Name_1);
 785       Set_Msg_Quote;
 786       Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
 787       Set_Msg_Name_Buffer;
 788       Set_Msg_Quote;
 789    end Set_Msg_Insertion_Reserved_Name;
 790
 791    -------------------------------------
 792    -- Set_Msg_Insertion_Reserved_Word --
 793    -------------------------------------
 794
 795    procedure Set_Msg_Insertion_Reserved_Word
 796      (Text : String;
 797       J    : in out Integer)
 798    is
 799    begin
 800       Set_Msg_Blank_Conditional;
 801       Name_Len := 0;
 802
 803       while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
 804          Name_Len := Name_Len + 1;
 805          Name_Buffer (Name_Len) := Text (J);
 806          J := J + 1;
 807       end loop;
 808
 809       Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
 810       Set_Msg_Quote;
 811       Set_Msg_Name_Buffer;
 812       Set_Msg_Quote;
 813    end Set_Msg_Insertion_Reserved_Word;
 814
 815    -------------------------------------
 816    -- Set_Msg_Insertion_Run_Time_Name --
 817    -------------------------------------
 818
 819    procedure Set_Msg_Insertion_Run_Time_Name is
 820    begin
 821       if Targparm.Run_Time_Name_On_Target /= No_Name then
 822          Set_Msg_Blank_Conditional;
 823          Set_Msg_Char ('(');
 824          Get_Name_String (Targparm.Run_Time_Name_On_Target);
 825          Set_Casing (Mixed_Case);
 826          Set_Msg_Str (Name_Buffer (1 .. Name_Len));
 827          Set_Msg_Char (')');
 828       end if;
 829    end Set_Msg_Insertion_Run_Time_Name;
 830
 831    ----------------------------
 832    -- Set_Msg_Insertion_Uint --
 833    ----------------------------
 834
 835    procedure Set_Msg_Insertion_Uint is
 836    begin
 837       Set_Msg_Blank;
 838       UI_Image (Error_Msg_Uint_1);
 839
 840       for J in 1 .. UI_Image_Length loop
 841          Set_Msg_Char (UI_Image_Buffer (J));
 842       end loop;
 843
 844       --  The following assignment ensures that a second carret insertion
 845       --  character will correspond to the Error_Msg_Uint_2 parameter. We
 846       --  suppress possible validity checks in case operating in -gnatVa mode,
 847       --  and Error_Msg_Uint_2 is not needed and has not been set.
 848
 849       declare
 850          pragma Suppress (Range_Check);
 851       begin
 852          Error_Msg_Uint_1 := Error_Msg_Uint_2;
 853       end;
 854    end Set_Msg_Insertion_Uint;
 855
 856    -----------------
 857    -- Set_Msg_Int --
 858    -----------------
 859
 860    procedure Set_Msg_Int (Line : Int) is
 861    begin
 862       if Line > 9 then
 863          Set_Msg_Int (Line / 10);
 864       end if;
 865
 866       Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
 867    end Set_Msg_Int;
 868
 869    -------------------------
 870    -- Set_Msg_Name_Buffer --
 871    -------------------------
 872
 873    procedure Set_Msg_Name_Buffer is
 874    begin
 875       for J in 1 .. Name_Len loop
 876          Set_Msg_Char (Name_Buffer (J));
 877       end loop;
 878    end Set_Msg_Name_Buffer;
 879
 880    -------------------
 881    -- Set_Msg_Quote --
 882    -------------------
 883
 884    procedure Set_Msg_Quote is
 885    begin
 886       if not Manual_Quote_Mode then
 887          Set_Msg_Char ('"');
 888       end if;
 889    end Set_Msg_Quote;
 890
 891    -----------------
 892    -- Set_Msg_Str --
 893    -----------------
 894
 895    procedure Set_Msg_Str (Text : String) is
 896    begin
 897       for J in Text'Range loop
 898          Set_Msg_Char (Text (J));
 899       end loop;
 900    end Set_Msg_Str;
 901
 902    ------------------------------
 903    -- Set_Next_Non_Deleted_Msg --
 904    ------------------------------
 905
 906    procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
 907    begin
 908       if E = No_Error_Msg then
 909          return;
 910
 911       else
 912          loop
 913             E := Errors.Table (E).Next;
 914             exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
 915          end loop;
 916       end if;
 917    end Set_Next_Non_Deleted_Msg;
 918
 919    ---------------------------
 920    -- Set_Warnings_Mode_Off --
 921    ---------------------------
 922
 923    procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is
 924    begin
 925       --  Don't bother with entries from instantiation copies, since we
 926       --  will already have a copy in the template, which is what matters
 927
 928       if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
 929          return;
 930       end if;
 931
 932       --  If last entry in table already covers us, this is a redundant
 933       --  pragma Warnings (Off) and can be ignored. This also handles the
 934       --  case where all warnings are suppressed by command line switch.
 935
 936       if Warnings.Last >= Warnings.First
 937         and then Warnings.Table (Warnings.Last).Start <= Loc
 938         and then Loc <= Warnings.Table (Warnings.Last).Stop
 939       then
 940          return;
 941
 942       --  Otherwise establish a new entry, extending from the location of
 943       --  the pragma to the end of the current source file. This ending
 944       --  point will be adjusted by a subsequent pragma Warnings (On).
 945
 946       else
 947          Warnings.Increment_Last;
 948          Warnings.Table (Warnings.Last).Start := Loc;
 949          Warnings.Table (Warnings.Last).Stop :=
 950            Source_Last (Current_Source_File);
 951       end if;
 952    end Set_Warnings_Mode_Off;
 953
 954    --------------------------
 955    -- Set_Warnings_Mode_On --
 956    --------------------------
 957
 958    procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
 959    begin
 960       --  Don't bother with entries from instantiation copies, since we
 961       --  will already have a copy in the template, which is what matters
 962
 963       if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
 964          return;
 965       end if;
 966
 967       --  Nothing to do unless command line switch to suppress all warnings
 968       --  is off, and the last entry in the warnings table covers this
 969       --  pragma Warnings (On), in which case adjust the end point.
 970
 971       if (Warnings.Last >= Warnings.First
 972            and then Warnings.Table (Warnings.Last).Start <= Loc
 973            and then Loc <= Warnings.Table (Warnings.Last).Stop)
 974         and then Warning_Mode /= Suppress
 975       then
 976          Warnings.Table (Warnings.Last).Stop := Loc;
 977       end if;
 978    end Set_Warnings_Mode_On;
 979
 980    ------------------------------------
 981    -- Test_Style_Warning_Serious_Msg --
 982    ------------------------------------
 983
 984    procedure Test_Style_Warning_Serious_Msg (Msg : String) is
 985    begin
 986       if Msg (Msg'First) = '\' then
 987          return;
 988       end if;
 989
 990       Is_Serious_Error := True;
 991       Is_Warning_Msg   := False;
 992
 993       Is_Style_Msg :=
 994         (Msg'Length > 7
 995            and then Msg (Msg'First .. Msg'First + 6) = "(style)");
 996
 997       for J in Msg'Range loop
 998          if Msg (J) = '?'
 999            and then (J = Msg'First or else Msg (J - 1) /= ''')
1000          then
1001             Is_Warning_Msg := True;
1002
1003          elsif Msg (J) = '<'
1004            and then (J = Msg'First or else Msg (J - 1) /= ''')
1005          then
1006             Is_Warning_Msg := Error_Msg_Warn;
1007
1008          elsif Msg (J) = '|'
1009            and then (J = Msg'First or else Msg (J - 1) /= ''')
1010          then
1011             Is_Serious_Error := False;
1012          end if;
1013       end loop;
1014
1015       if Is_Warning_Msg or else Is_Style_Msg then
1016          Is_Serious_Error := False;
1017       end if;
1018    end Test_Style_Warning_Serious_Msg;
1019
1020    -------------------------
1021    -- Warnings_Suppressed --
1022    -------------------------
1023
1024    function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
1025    begin
1026       for J in Warnings.First .. Warnings.Last loop
1027          if Warnings.Table (J).Start <= Loc
1028            and then Loc <= Warnings.Table (J).Stop
1029          then
1030             return True;
1031          end if;
1032       end loop;
1033
1034       return False;
1035    end Warnings_Suppressed;
1036
1037 end Erroutc;