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