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