gcc/ada/errout.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                               E R R O U T                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                                                                          --
  10 --          Copyright (C) 1992-2002 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 --  Warning! Error messages can be generated during Gigi processing by direct
  29 --  calls to error message routines, so it is essential that the processing
  30 --  in this body be consistent with the requirements for the Gigi processing
  31 --  environment, and that in particular, no disallowed table expansion is
  32 --  allowed to occur.
  33
  34 with Atree;    use Atree;
  35 with Casing;   use Casing;
  36 with Csets;    use Csets;
  37 with Debug;    use Debug;
  38 with Einfo;    use Einfo;
  39 with Fname;    use Fname;
  40 with Hostparm;
  41 with Lib;      use Lib;
  42 with Namet;    use Namet;
  43 with Opt;      use Opt;
  44 with Nlists;   use Nlists;
  45 with Output;   use Output;
  46 with Scans;    use Scans;
  47 with Sinput;   use Sinput;
  48 with Sinfo;    use Sinfo;
  49 with Snames;   use Snames;
  50 with Stand;    use Stand;
  51 with Style;
  52 with Uintp;    use Uintp;
  53 with Uname;    use Uname;
  54
  55 package body Errout is
  56
  57    Class_Flag : Boolean := False;
  58    --  This flag is set True when outputting a reference to a class-wide
  59    --  type, and is used by Add_Class to insert 'Class at the proper point
  60
  61    Continuation : Boolean;
  62    --  Indicates if current message is a continuation. Initialized from the
  63    --  Msg_Cont parameter in Error_Msg_Internal and then set True if a \
  64    --  insertion character is encountered.
  65
  66    Cur_Msg : Error_Msg_Id;
  67    --  Id of most recently posted error message
  68
  69    Flag_Source : Source_File_Index;
  70    --  Source file index for source file where error is being posted
  71
  72    Is_Warning_Msg : Boolean;
  73    --  Set by Set_Msg_Text to indicate if current message is warning message
  74
  75    Is_Serious_Error : Boolean;
  76    --  Set by Set_Msg_Text to indicate if current message is serious error
  77
  78    Is_Unconditional_Msg : Boolean;
  79    --  Set by Set_Msg_Text to indicate if current message is unconditional
  80
  81    Kill_Message : Boolean;
  82    --  A flag used to kill weird messages (e.g. those containing uninterpreted
  83    --  implicit type references) if we have already seen at least one message
  84    --  already. The idea is that we hope the weird message is a junk cascaded
  85    --  message that should be suppressed.
  86
  87    Last_Killed : Boolean := False;
  88    --  Set True if the most recently posted non-continuation message was
  89    --  killed. This is used to determine the processing of any continuation
  90    --  messages that follow.
  91
  92    List_Pragmas_Index : Int;
  93    --  Index into List_Pragmas table
  94
  95    List_Pragmas_Mode : Boolean;
  96    --  Starts True, gets set False by pragma List (Off), True by List (On)
  97
  98    Manual_Quote_Mode : Boolean;
  99    --  Set True in manual quotation mode
 100
 101    Max_Msg_Length : constant := 80 + 2 * Hostparm.Max_Line_Length;
 102    --  Maximum length of error message. The addition of Max_Line_Length
 103    --  ensures that two insertion tokens of maximum length can be accomodated.
 104
 105    Msg_Buffer : String (1 .. Max_Msg_Length);
 106    --  Buffer used to prepare error messages
 107
 108    Msglen : Integer;
 109    --  Number of characters currently stored in the message buffer
 110
 111    Suppress_Message : Boolean;
 112    --  A flag used to suppress certain obviously redundant messages (i.e.
 113    --  those referring to a node whose type is Any_Type). This suppression
 114    --  is effective only if All_Errors_Mode is off.
 115
 116    Suppress_Instance_Location : Boolean := False;
 117    --  Normally, if a # location in a message references a location within
 118    --  a generic template, then a note is added giving the location of the
 119    --  instantiation. If this variable is set True, then this note is not
 120    --  output. This is used for internal processing for the case of an
 121    --  illegal instantiation. See Error_Msg routine for further details.
 122
 123    -----------------------------------
 124    -- Error Message Data Structures --
 125    -----------------------------------
 126
 127    --  The error messages are stored as a linked list of error message objects
 128    --  sorted into ascending order by the source location (Sloc). Each object
 129    --  records the text of the message and its source location.
 130
 131    --  The following record type and table are used to represent error
 132    --  messages, with one entry in the table being allocated for each message.
 133
 134    type Error_Msg_Object is record
 135       Text : String_Ptr;
 136       --  Text of error message, fully expanded with all insertions
 137
 138       Next : Error_Msg_Id;
 139       --  Pointer to next message in error chain
 140
 141       Sfile : Source_File_Index;
 142       --  Source table index of source file. In the case of an error that
 143       --  refers to a template, always references the original template
 144       --  not an instantiation copy.
 145
 146       Sptr : Source_Ptr;
 147       --  Flag pointer. In the case of an error that refers to a template,
 148       --  always references the original template, not an instantiation copy.
 149       --  This value is the actual place in the source that the error message
 150       --  will be posted.
 151
 152       Fptr : Source_Ptr;
 153       --  Flag location used in the call to post the error. This is normally
 154       --  the same as Sptr, except in the case of instantiations, where it
 155       --  is the original flag location value. This may refer to an instance
 156       --  when the actual message (and hence Sptr) references the template.
 157
 158       Line : Physical_Line_Number;
 159       --  Line number for error message
 160
 161       Col : Column_Number;
 162       --  Column number for error message
 163
 164       Warn : Boolean;
 165       --  True if warning message (i.e. insertion character ? appeared)
 166
 167       Serious : Boolean;
 168       --  True if serious error message (not a warning and no | character)
 169
 170       Uncond : Boolean;
 171       --  True if unconditional message (i.e. insertion character ! appeared)
 172
 173       Msg_Cont : Boolean;
 174       --  This is used for logical messages that are composed of multiple
 175       --  individual messages. For messages that are not part of such a
 176       --  group, or that are the first message in such a group. Msg_Cont
 177       --  is set to False. For subsequent messages in a group, Msg_Cont
 178       --  is set to True. This is used to make sure that such a group of
 179       --  messages is either suppressed or retained as a group (e.g. in
 180       --  the circuit that deletes identical messages).
 181
 182       Deleted : Boolean;
 183       --  If this flag is set, the message is not printed. This is used
 184       --  in the circuit for deleting duplicate/redundant error messages.
 185    end record;
 186
 187    package Errors is new Table.Table (
 188      Table_Component_Type => Error_Msg_Object,
 189      Table_Index_Type     => Error_Msg_Id,
 190      Table_Low_Bound      => 1,
 191      Table_Initial        => 200,
 192      Table_Increment      => 200,
 193      Table_Name           => "Error");
 194
 195    Error_Msgs : Error_Msg_Id;
 196    --  The list of error messages
 197
 198    --------------------------
 199    -- Warning Mode Control --
 200    --------------------------
 201
 202    --  Pragma Warnings allows warnings to be turned off for a specified
 203    --  region of code, and the following tabl is the data structure used
 204    --  to keep track of these regions.
 205
 206    --  It contains pairs of source locations, the first being the start
 207    --  location for a warnings off region, and the second being the end
 208    --  location. When a pragma Warnings (Off) is encountered, a new entry
 209    --  is established extending from the location of the pragma to the
 210    --  end of the current source file. A subsequent pragma Warnings (On)
 211    --  adjusts the end point of this entry appropriately.
 212
 213    --  If all warnings are suppressed by comamnd switch, then there is a
 214    --  dummy entry (put there by Errout.Initialize) at the start of the
 215    --  table which covers all possible Source_Ptr values. Note that the
 216    --  source pointer values in this table always reference the original
 217    --  template, not an instantiation copy, in the generic case.
 218
 219    type Warnings_Entry is record
 220       Start : Source_Ptr;
 221       Stop  : Source_Ptr;
 222    end record;
 223
 224    package Warnings is new Table.Table (
 225      Table_Component_Type => Warnings_Entry,
 226      Table_Index_Type     => Natural,
 227      Table_Low_Bound      => 1,
 228      Table_Initial        => 100,
 229      Table_Increment      => 200,
 230      Table_Name           => "Warnings");
 231
 232    -----------------------
 233    -- Local Subprograms --
 234    -----------------------
 235
 236    procedure Add_Class;
 237    --  Add 'Class to buffer for class wide type case (Class_Flag set)
 238
 239    function Buffer_Ends_With (S : String) return Boolean;
 240    --  Tests if message buffer ends with given string preceded by a space
 241
 242    procedure Buffer_Remove (S : String);
 243    --  Removes given string from end of buffer if it is present
 244    --  at end of buffer, and preceded by a space.
 245
 246    procedure Debug_Output (N : Node_Id);
 247    --  Called from Error_Msg_N and Error_Msg_NE to generate line of debug
 248    --  output giving node number (of node N) if the debug X switch is set.
 249
 250    procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id);
 251    --  This function is passed the Id values of two error messages. If
 252    --  either M1 or M2 is a continuation message, or is already deleted,
 253    --  the call is ignored. Otherwise a check is made to see if M1 and M2
 254    --  are duplicated or redundant. If so, the message to be deleted and
 255    --  all its continuations are marked with the Deleted flag set to True.
 256
 257    procedure Error_Msg_Internal
 258      (Msg           : String;
 259       Flag_Location : Source_Ptr;
 260       Msg_Cont      : Boolean);
 261    --  This is like Error_Msg, except that Flag_Location is known not to be
 262    --  a location within a instantiation of a generic template. The outer
 263    --  level routine, Error_Msg, takes care of dealing with the generic case.
 264    --  Msg_Cont is set True to indicate that the message is a continuation of
 265    --  a previous message. This means that it must have the same Flag_Location
 266    --  as the previous message.
 267
 268    procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id);
 269    --  Given a message id, move to next message id, but skip any deleted
 270    --  messages, so that this results in E on output being the first non-
 271    --  deleted message following the input value of E, or No_Error_Msg if
 272    --  the input value of E was either already No_Error_Msg, or was the
 273    --  last non-deleted message.
 274
 275    function No_Warnings (N : Node_Or_Entity_Id) return Boolean;
 276    --  Determines if warnings should be suppressed for the given node
 277
 278    function OK_Node (N : Node_Id) return Boolean;
 279    --  Determines if a node is an OK node to place an error message on (return
 280    --  True) or if the error message should be suppressed (return False). A
 281    --  message is suppressed if the node already has an error posted on it,
 282    --  or if it refers to an Etype that has an error posted on it, or if
 283    --  it references an Entity that has an error posted on it.
 284
 285    procedure Output_Error_Msgs (E : in out Error_Msg_Id);
 286    --  Output source line, error flag, and text of stored error message and
 287    --  all subsequent messages for the same line and unit. On return E is
 288    --  set to be one higher than the last message output.
 289
 290    procedure Output_Line_Number (L : Logical_Line_Number);
 291    --  Output a line number as six digits (with leading zeroes suppressed),
 292    --  followed by a period and a blank (note that this is 8 characters which
 293    --  means that tabs in the source line will not get messed up). Line numbers
 294    --  that match or are less than the last Source_Reference pragma are listed
 295    --  as all blanks, avoiding output of junk line numbers.
 296
 297    procedure Output_Msg_Text (E : Error_Msg_Id);
 298    --  Outputs characters of text in the text of the error message E, excluding
 299    --  any final exclamation point. Note that no end of line is output, the
 300    --  caller is responsible for adding the end of line.
 301
 302    procedure Output_Source_Line
 303      (L     : Physical_Line_Number;
 304       Sfile : Source_File_Index;
 305       Errs  : Boolean);
 306    --  Outputs text of source line L, in file S, together with preceding line
 307    --  number, as described above for Output_Line_Number. The Errs parameter
 308    --  indicates if there are errors attached to the line, which forces
 309    --  listing on, even in the presence of pragma List (Off).
 310
 311    function Same_Error (M1, M2 : Error_Msg_Id) return Boolean;
 312    --  See if two messages have the same text. Returns true if the text
 313    --  of the two messages is identical, or if one of them is the same
 314    --  as the other with an appended "instance at xxx" tag.
 315
 316    procedure Set_Msg_Blank;
 317    --  Sets a single blank in the message if the preceding character is a
 318    --  non-blank character other than a left parenthesis. Has no effect if
 319    --  manual quote mode is turned on.
 320
 321    procedure Set_Msg_Blank_Conditional;
 322    --  Sets a single blank in the message if the preceding character is a
 323    --  non-blank character other than a left parenthesis or quote. Has no
 324    --  effect if manual quote mode is turned on.
 325
 326    procedure Set_Msg_Char (C : Character);
 327    --  Add a single character to the current message. This routine does not
 328    --  check for special insertion characters (they are just treated as text
 329    --  characters if they occur).
 330
 331    procedure Set_Msg_Insertion_Column;
 332    --  Handle column number insertion (@ insertion character)
 333
 334    procedure Set_Msg_Insertion_Name;
 335    --  Handle name insertion (% insertion character)
 336
 337    procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr);
 338    --  Handle line number insertion (# insertion character). Loc is the
 339    --  location to be referenced, and Flag is the location at which the
 340    --  flag is posted (used to determine whether to add "in file xxx")
 341
 342    procedure Set_Msg_Insertion_Node;
 343    --  Handle node (name from node) insertion (& insertion character)
 344
 345    procedure Set_Msg_Insertion_Reserved_Name;
 346    --  Handle insertion of reserved word name (* insertion character).
 347
 348    procedure Set_Msg_Insertion_Reserved_Word
 349      (Text : String;
 350       J    : in out Integer);
 351    --  Handle reserved word insertion (upper case letters). The Text argument
 352    --  is the current error message input text, and J is an index which on
 353    --  entry points to the first character of the reserved word, and on exit
 354    --  points past the last character of the reserved word.
 355
 356    procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr);
 357    --  Handle type reference (right brace insertion character). Flag is the
 358    --  location of the flag, which is provided for the internal call to
 359    --  Set_Msg_Insertion_Line_Number,
 360
 361    procedure Set_Msg_Insertion_Uint;
 362    --  Handle Uint insertion (^ insertion character)
 363
 364    procedure Set_Msg_Insertion_Unit_Name;
 365    --  Handle unit name insertion ($ insertion character)
 366
 367    procedure Set_Msg_Insertion_File_Name;
 368    --  Handle file name insertion (left brace insertion character)
 369
 370    procedure Set_Msg_Int (Line : Int);
 371    --  Set the decimal representation of the argument in the error message
 372    --  buffer with no leading zeroes output.
 373
 374    procedure Set_Msg_Name_Buffer;
 375    --  Output name from Name_Buffer, with surrounding quotes unless manual
 376    --  quotation mode is in effect.
 377
 378    procedure Set_Msg_Node (Node : Node_Id);
 379    --  Add the sequence of characters for the name associated with the
 380    --  given node to the current message.
 381
 382    procedure Set_Msg_Quote;
 383    --  Set quote if in normal quote mode, nothing if in manual quote mode
 384
 385    procedure Set_Msg_Str (Text : String);
 386    --  Add a sequence of characters to the current message. This routine does
 387    --  not check for special insertion characters (they are just treated as
 388    --  text characters if they occur).
 389
 390    procedure Set_Msg_Text (Text : String; Flag : Source_Ptr);
 391    --  Add a sequence of characters to the current message. The characters may
 392    --  be one of the special insertion characters (see documentation in spec).
 393    --  Flag is the location at which the error is to be posted, which is used
 394    --  to determine whether or not the # insertion needs a file name. The
 395    --  variables Msg_Buffer, Msglen, Is_Warning_Msg, and Is_Unconditional_Msg
 396    --  are set on return.
 397
 398    procedure Set_Posted (N : Node_Id);
 399    --  Sets the Error_Posted flag on the given node, and all its parents
 400    --  that are subexpressions and then on the parent non-subexpression
 401    --  construct that contains the original expression (this reduces the
 402    --  number of cascaded messages)
 403
 404    procedure Set_Qualification (N : Nat; E : Entity_Id);
 405    --  Outputs up to N levels of qualification for the given entity. For
 406    --  example, the entity A.B.C.D will output B.C. if N = 2.
 407
 408    function Special_Msg_Delete
 409      (Msg  : String;
 410       N    : Node_Or_Entity_Id;
 411       E    : Node_Or_Entity_Id)
 412       return Boolean;
 413    --  This function is called from Error_Msg_NEL, passing the message Msg,
 414    --  node N on which the error is to be posted, and the entity or node E
 415    --  to be used for an & insertion in the message if any. The job of this
 416    --  procedure is to test for certain cascaded messages that we would like
 417    --  to suppress. If the message is to be suppressed then we return True.
 418    --  If the message should be generated (the normal case) False is returned.
 419
 420    procedure Test_Warning_Msg (Msg : String);
 421    --  Sets Is_Warning_Msg true if Msg is a warning message (contains a
 422    --  question mark character), and False otherwise.
 423
 424    procedure Unwind_Internal_Type (Ent : in out Entity_Id);
 425    --  This procedure is given an entity id for an internal type, i.e.
 426    --  a type with an internal name. It unwinds the type to try to get
 427    --  to something reasonably printable, generating prefixes like
 428    --  "subtype of", "access to", etc along the way in the buffer. The
 429    --  value in Ent on return is the final name to be printed. Hopefully
 430    --  this is not an internal name, but in some internal name cases, it
 431    --  is an internal name, and has to be printed anyway (although in this
 432    --  case the message has been killed if possible). The global variable
 433    --  Class_Flag is set to True if the resulting entity should have
 434    --  'Class appended to its name (see Add_Class procedure), and is
 435    --  otherwise unchanged.
 436
 437    function Warnings_Suppressed (Loc : Source_Ptr) return Boolean;
 438    --  Determines if given location is covered by a warnings off suppression
 439    --  range in the warnings table (or is suppressed by compilation option,
 440    --  which generates a warning range for the whole source file).
 441
 442    ---------------
 443    -- Add_Class --
 444    ---------------
 445
 446    procedure Add_Class is
 447    begin
 448       if Class_Flag then
 449          Class_Flag := False;
 450          Set_Msg_Char (''');
 451          Get_Name_String (Name_Class);
 452          Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
 453          Set_Msg_Name_Buffer;
 454       end if;
 455    end Add_Class;
 456
 457    ----------------------
 458    -- Buffer_Ends_With --
 459    ----------------------
 460
 461    function Buffer_Ends_With (S : String) return Boolean is
 462       Len : constant Natural := S'Length;
 463
 464    begin
 465       return
 466         Msglen > Len
 467           and then Msg_Buffer (Msglen - Len) = ' '
 468           and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S;
 469    end Buffer_Ends_With;
 470
 471    -------------------
 472    -- Buffer_Remove --
 473    -------------------
 474
 475    procedure Buffer_Remove (S : String) is
 476    begin
 477       if Buffer_Ends_With (S) then
 478          Msglen := Msglen - S'Length;
 479       end if;
 480    end Buffer_Remove;
 481
 482    -----------------------
 483    -- Change_Error_Text --
 484    -----------------------
 485
 486    procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String) is
 487       Save_Next : Error_Msg_Id;
 488       Err_Id    : Error_Msg_Id := Error_Id;
 489
 490    begin
 491       Set_Msg_Text (New_Msg, Errors.Table (Error_Id).Sptr);
 492       Errors.Table (Error_Id).Text := new String'(Msg_Buffer (1 .. Msglen));
 493
 494       --  If in immediate error message mode, output modified error message now
 495       --  This is just a bit tricky, because we want to output just a single
 496       --  message, and the messages we modified is already linked in. We solve
 497       --  this by temporarily resetting its forward pointer to empty.
 498
 499       if Debug_Flag_OO then
 500          Save_Next := Errors.Table (Error_Id).Next;
 501          Errors.Table (Error_Id).Next := No_Error_Msg;
 502          Write_Eol;
 503          Output_Source_Line
 504            (Errors.Table (Error_Id).Line, Errors.Table (Error_Id).Sfile, True);
 505          Output_Error_Msgs (Err_Id);
 506          Errors.Table (Error_Id).Next := Save_Next;
 507       end if;
 508    end Change_Error_Text;
 509
 510    -----------------------------
 511    -- Check_Duplicate_Message --
 512    -----------------------------
 513
 514    procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
 515       L1, L2 : Error_Msg_Id;
 516       N1, N2 : Error_Msg_Id;
 517
 518       procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
 519       --  Called to delete message Delete, keeping message Keep. Marks
 520       --  all messages of Delete with deleted flag set to True, and also
 521       --  makes sure that for the error messages that are retained the
 522       --  preferred message is the one retained (we prefer the shorter
 523       --  one in the case where one has an Instance tag). Note that we
 524       --  always know that Keep has at least as many continuations as
 525       --  Delete (since we always delete the shorter sequence).
 526
 527       ----------------
 528       -- Delete_Msg --
 529       ----------------
 530
 531       procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
 532          D, K : Error_Msg_Id;
 533
 534       begin
 535          D := Delete;
 536          K := Keep;
 537
 538          loop
 539             Errors.Table (D).Deleted := True;
 540
 541             --  Adjust error message count
 542
 543             if Errors.Table (D).Warn then
 544                Warnings_Detected := Warnings_Detected - 1;
 545             else
 546                Total_Errors_Detected := Total_Errors_Detected - 1;
 547
 548                if Errors.Table (D).Serious then
 549                   Serious_Errors_Detected := Serious_Errors_Detected - 1;
 550                end if;
 551             end if;
 552
 553             --  Substitute shorter of the two error messages
 554
 555             if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
 556                Errors.Table (K).Text := Errors.Table (D).Text;
 557             end if;
 558
 559             D := Errors.Table (D).Next;
 560             K := Errors.Table (K).Next;
 561
 562             if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
 563                return;
 564             end if;
 565          end loop;
 566       end Delete_Msg;
 567
 568    --  Start of processing for Check_Duplicate_Message
 569
 570    begin
 571       --  Both messages must be non-continuation messages and not deleted
 572
 573       if Errors.Table (M1).Msg_Cont
 574         or else Errors.Table (M2).Msg_Cont
 575         or else Errors.Table (M1).Deleted
 576         or else Errors.Table (M2).Deleted
 577       then
 578          return;
 579       end if;
 580
 581       --  Definitely not equal if message text does not match
 582
 583       if not Same_Error (M1, M2) then
 584          return;
 585       end if;
 586
 587       --  Same text. See if all continuations are also identical
 588
 589       L1 := M1;
 590       L2 := M2;
 591
 592       loop
 593          N1 := Errors.Table (L1).Next;
 594          N2 := Errors.Table (L2).Next;
 595
 596          --  If M1 continuations have run out, we delete M1, either the
 597          --  messages have the same number of continuations, or M2 has
 598          --  more and we prefer the one with more anyway.
 599
 600          if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
 601             Delete_Msg (M1, M2);
 602             return;
 603
 604          --  If M2 continuatins have run out, we delete M2
 605
 606          elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
 607             Delete_Msg (M2, M1);
 608             return;
 609
 610          --  Otherwise see if continuations are the same, if not, keep both
 611          --  sequences, a curious case, but better to keep everything!
 612
 613          elsif not Same_Error (N1, N2) then
 614             return;
 615
 616          --  If continuations are the same, continue scan
 617
 618          else
 619             L1 := N1;
 620             L2 := N2;
 621          end if;
 622       end loop;
 623    end Check_Duplicate_Message;
 624
 625    ------------------------
 626    -- Compilation_Errors --
 627    ------------------------
 628
 629    function Compilation_Errors return Boolean is
 630    begin
 631       return Total_Errors_Detected /= 0
 632         or else (Warnings_Detected /= 0
 633                   and then Warning_Mode = Treat_As_Error);
 634    end Compilation_Errors;
 635
 636    ------------------
 637    -- Debug_Output --
 638    ------------------
 639
 640    procedure Debug_Output (N : Node_Id) is
 641    begin
 642       if Debug_Flag_1 then
 643          Write_Str ("*** following error message posted on node id = #");
 644          Write_Int (Int (N));
 645          Write_Str (" ***");
 646          Write_Eol;
 647       end if;
 648    end Debug_Output;
 649
 650    ----------
 651    -- dmsg --
 652    ----------
 653
 654    procedure dmsg (Id : Error_Msg_Id) is
 655       E : Error_Msg_Object renames Errors.Table (Id);
 656
 657    begin
 658       w ("Dumping error message, Id = ", Int (Id));
 659       w ("  Text     = ", E.Text.all);
 660       w ("  Next     = ", Int (E.Next));
 661       w ("  Sfile    = ", Int (E.Sfile));
 662
 663       Write_Str
 664         ("  Sptr     = ");
 665       Write_Location (E.Sptr);
 666       Write_Eol;
 667
 668       Write_Str
 669         ("  Fptr     = ");
 670       Write_Location (E.Fptr);
 671       Write_Eol;
 672
 673       w ("  Line     = ", Int (E.Line));
 674       w ("  Col      = ", Int (E.Col));
 675       w ("  Warn     = ", E.Warn);
 676       w ("  Serious  = ", E.Serious);
 677       w ("  Uncond   = ", E.Uncond);
 678       w ("  Msg_Cont = ", E.Msg_Cont);
 679       w ("  Deleted  = ", E.Deleted);
 680
 681       Write_Eol;
 682    end dmsg;
 683
 684    ---------------
 685    -- Error_Msg --
 686    ---------------
 687
 688    --  Error_Msg posts a flag at the given location, except that if the
 689    --  Flag_Location points within a generic template and corresponds
 690    --  to an instantiation of this generic template, then the actual
 691    --  message will be posted on the generic instantiation, along with
 692    --  additional messages referencing the generic declaration.
 693
 694    procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
 695       Sindex : Source_File_Index;
 696       --  Source index for flag location
 697
 698       Orig_Loc : Source_Ptr;
 699       --  Original location of Flag_Location (i.e. location in original
 700       --  template in instantiation case, otherwise unchanged).
 701
 702    begin
 703       --  If we already have messages, and we are trying to place a message
 704       --  at No_Location or in package Standard, then just ignore the attempt
 705       --  since we assume that what is happening is some cascaded junk. Note
 706       --  that this is safe in the sense that proceeding will surely bomb.
 707
 708       if Flag_Location < First_Source_Ptr
 709         and then Total_Errors_Detected > 0
 710       then
 711          return;
 712       end if;
 713
 714       Sindex := Get_Source_File_Index (Flag_Location);
 715       Test_Warning_Msg (Msg);
 716
 717       --  It is a fatal error to issue an error message when scanning from
 718       --  the internal source buffer (see Sinput for further documentation)
 719
 720       pragma Assert (Source /= Internal_Source_Ptr);
 721
 722       --  Ignore warning message that is suppressed
 723
 724       Orig_Loc := Original_Location (Flag_Location);
 725
 726       if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then
 727          return;
 728       end if;
 729
 730       --  The idea at this stage is that we have two kinds of messages.
 731
 732       --  First, we have those that are to be placed as requested at
 733       --  Flag_Location. This includes messages that have nothing to
 734       --  do with generics, and also messages placed on generic templates
 735       --  that reflect an error in the template itself. For such messages
 736       --  we simply call Error_Msg_Internal to place the message in the
 737       --  requested location.
 738
 739       if Instantiation (Sindex) = No_Location then
 740          Error_Msg_Internal (Msg, Flag_Location, False);
 741          return;
 742       end if;
 743
 744       --  If we are trying to flag an error in an instantiation, we may have
 745       --  a generic contract violation. What we generate in this case is:
 746
 747       --     instantiation error at ...
 748       --     original error message
 749
 750       --  or
 751
 752       --     warning: in instantiation at
 753       --     warning: original warning message
 754
 755       --  All these messages are posted at the location of the top level
 756       --  instantiation. If there are nested instantiations, then the
 757       --  instantiation error message can be repeated, pointing to each
 758       --  of the relevant instantiations.
 759
 760       --  However, before we do this, we need to worry about the case where
 761       --  indeed we are in an instantiation, but the message is a warning
 762       --  message. In this case, it almost certainly a warning for the
 763       --  template itself and so it is posted on the template. At least
 764       --  this is the default mode, it can be cancelled (resulting the
 765       --  warning being placed on the instance as in the error case) by
 766       --  setting the global Warn_On_Instance True.
 767
 768       if (not Warn_On_Instance) and then Is_Warning_Msg then
 769          Error_Msg_Internal (Msg, Flag_Location, False);
 770          return;
 771       end if;
 772
 773       --  Second, we need to worry about the case where there was a real error
 774       --  in the template, and we are getting a repeat of this error in the
 775       --  instantiation. We don't want to complain about the instantiation
 776       --  in this case, since we have already flagged the template.
 777
 778       --  To deal with this case, just see if we have posted a message at
 779       --  the template location already. If so, assume that the current
 780       --  message is redundant. There could be cases in which this is not
 781       --  a correct assumption, but it is not terrible to lose a message
 782       --  about an incorrect instantiation given that we have already
 783       --  flagged a message on the template.
 784
 785       for Err in Errors.First .. Errors.Last loop
 786          if Errors.Table (Err).Sptr = Orig_Loc then
 787
 788          --  If the current message is a real error, as opposed to a
 789          --  warning, then we don't want to let a warning on the
 790          --  template inhibit a real error on the instantiation.
 791
 792             if Is_Warning_Msg
 793               or else not Errors.Table (Err).Warn
 794             then
 795                return;
 796             end if;
 797          end if;
 798       end loop;
 799
 800       --  OK, this is the case where we have an instantiation error, and
 801       --  we need to generate the error on the instantiation, rather than
 802       --  on the template. First, see if we have posted this exact error
 803       --  before, and if so suppress it. It is not so easy to use the main
 804       --  list of errors for this, since they have already been split up
 805       --  according to the processing below. Consequently we use an auxiliary
 806       --  data structure that just records these types of messages (it will
 807       --  never have very many entries).
 808
 809       declare
 810          Actual_Error_Loc : Source_Ptr;
 811          --  Location of outer level instantiation in instantiation case, or
 812          --  just a copy of Flag_Location in the normal case. This is the
 813          --  location where all error messages will actually be posted.
 814
 815          Save_Error_Msg_Sloc : constant Source_Ptr := Error_Msg_Sloc;
 816          --  Save possible location set for caller's message. We need to
 817          --  use Error_Msg_Sloc for the location of the instantiation error
 818          --  but we have to preserve a possible original value.
 819
 820          X : Source_File_Index;
 821
 822          Msg_Cont_Status : Boolean;
 823          --  Used to label continuation lines in instantiation case with
 824          --  proper Msg_Cont status.
 825
 826       begin
 827          --  Loop to find highest level instantiation, where all error
 828          --  messages will be placed.
 829
 830          X := Sindex;
 831          loop
 832             Actual_Error_Loc := Instantiation (X);
 833             X := Get_Source_File_Index (Actual_Error_Loc);
 834             exit when Instantiation (X) = No_Location;
 835          end loop;
 836
 837          --  Since we are generating the messages at the instantiation
 838          --  point in any case, we do not want the references to the
 839          --  bad lines in the instance to be annotated with the location
 840          --  of the instantiation.
 841
 842          Suppress_Instance_Location := True;
 843          Msg_Cont_Status := False;
 844
 845          --  Loop to generate instantiation messages
 846
 847          Error_Msg_Sloc := Flag_Location;
 848          X := Get_Source_File_Index (Flag_Location);
 849
 850          while Instantiation (X) /= No_Location loop
 851
 852             --  Suppress instantiation message on continuation lines
 853
 854             if Msg (1) /= '\' then
 855                if Is_Warning_Msg then
 856                   Error_Msg_Internal
 857                     ("?in instantiation #",
 858                      Actual_Error_Loc, Msg_Cont_Status);
 859
 860                else
 861                   Error_Msg_Internal
 862                     ("instantiation error #",
 863                      Actual_Error_Loc, Msg_Cont_Status);
 864                end if;
 865             end if;
 866
 867             Error_Msg_Sloc := Instantiation (X);
 868             X := Get_Source_File_Index (Error_Msg_Sloc);
 869             Msg_Cont_Status := True;
 870          end loop;
 871
 872          Suppress_Instance_Location := False;
 873          Error_Msg_Sloc := Save_Error_Msg_Sloc;
 874
 875          --  Here we output the original message on the outer instantiation
 876
 877          Error_Msg_Internal (Msg, Actual_Error_Loc, Msg_Cont_Status);
 878       end;
 879    end Error_Msg;
 880
 881    ------------------
 882    -- Error_Msg_AP --
 883    ------------------
 884
 885    procedure Error_Msg_AP (Msg : String) is
 886       S1 : Source_Ptr;
 887       C  : Character;
 888
 889    begin
 890       --  If we had saved the Scan_Ptr value after scanning the previous
 891       --  token, then we would have exactly the right place for putting
 892       --  the flag immediately at hand. However, that would add at least
 893       --  two instructions to a Scan call *just* to service the possibility
 894       --  of an Error_Msg_AP call. So instead we reconstruct that value.
 895
 896       --  We have two possibilities, start with Prev_Token_Ptr and skip over
 897       --  the current token, which is made harder by the possibility that this
 898       --  token may be in error, or start with Token_Ptr and work backwards.
 899       --  We used to take the second approach, but it's hard because of
 900       --  comments, and harder still because things that look like comments
 901       --  can appear inside strings. So now we take the first approach.
 902
 903       --  Note: in the case where there is no previous token, Prev_Token_Ptr
 904       --  is set to Source_First, which is a reasonable position for the
 905       --  error flag in this situation.
 906
 907       S1 := Prev_Token_Ptr;
 908       C := Source (S1);
 909
 910       --  If the previous token is a string literal, we need a special approach
 911       --  since there may be white space inside the literal and we don't want
 912       --  to stop on that white space.
 913
 914       if Prev_Token = Tok_String_Literal then
 915          loop
 916             S1 := S1 + 1;
 917
 918             if Source (S1) = C then
 919                S1 := S1 + 1;
 920                exit when Source (S1) /= C;
 921             elsif Source (S1) in Line_Terminator then
 922                exit;
 923             end if;
 924          end loop;
 925
 926       --  Character literal also needs special handling
 927
 928       elsif Prev_Token = Tok_Char_Literal then
 929          S1 := S1 + 3;
 930
 931       --  Otherwise we search forward for the end of the current token, marked
 932       --  by a line terminator, white space, a comment symbol or if we bump
 933       --  into the following token (i.e. the current token)
 934
 935       else
 936          while Source (S1) not in Line_Terminator
 937            and then Source (S1) /= ' '
 938            and then Source (S1) /= ASCII.HT
 939            and then (Source (S1) /= '-' or else Source (S1 + 1) /= '-')
 940            and then S1 /= Token_Ptr
 941          loop
 942             S1 := S1 + 1;
 943          end loop;
 944       end if;
 945
 946       --  S1 is now set to the location for the flag
 947
 948       Error_Msg (Msg, S1);
 949
 950    end Error_Msg_AP;
 951
 952    ------------------
 953    -- Error_Msg_BC --
 954    ------------------
 955
 956    procedure Error_Msg_BC (Msg : String) is
 957    begin
 958       --  If we are at end of file, post the flag after the previous token
 959
 960       if Token = Tok_EOF then
 961          Error_Msg_AP (Msg);
 962
 963       --  If we are at start of file, post the flag at the current token
 964
 965       elsif Token_Ptr = Source_First (Current_Source_File) then
 966          Error_Msg_SC (Msg);
 967
 968       --  If the character before the current token is a space or a horizontal
 969       --  tab, then we place the flag on this character (in the case of a tab
 970       --  we would really like to place it in the "last" character of the tab
 971       --  space, but that it too much trouble to worry about).
 972
 973       elsif Source (Token_Ptr - 1) = ' '
 974          or else Source (Token_Ptr - 1) = ASCII.HT
 975       then
 976          Error_Msg (Msg, Token_Ptr - 1);
 977
 978       --  If there is no space or tab before the current token, then there is
 979       --  no room to place the flag before the token, so we place it on the
 980       --  token instead (this happens for example at the start of a line).
 981
 982       else
 983          Error_Msg (Msg, Token_Ptr);
 984       end if;
 985    end Error_Msg_BC;
 986
 987    ------------------------
 988    -- Error_Msg_Internal --
 989    ------------------------
 990
 991    procedure Error_Msg_Internal
 992      (Msg           : String;
 993       Flag_Location : Source_Ptr;
 994       Msg_Cont      : Boolean)
 995    is
 996       Next_Msg : Error_Msg_Id;
 997       --  Pointer to next message at insertion point
 998
 999       Prev_Msg : Error_Msg_Id;
1000       --  Pointer to previous message at insertion point
1001
1002       Temp_Msg : Error_Msg_Id;
1003
1004       Orig_Loc : constant Source_Ptr := Original_Location (Flag_Location);
1005
1006       procedure Handle_Serious_Error;
1007       --  Internal procedure to do all error message handling for a serious
1008       --  error message, other than bumping the error counts and arranging
1009       --  for the message to be output.
1010
1011       --------------------------
1012       -- Handle_Serious_Error --
1013       --------------------------
1014
1015       procedure Handle_Serious_Error is
1016       begin
1017          --  Turn off code generation if not done already
1018
1019          if Operating_Mode = Generate_Code then
1020             Operating_Mode := Check_Semantics;
1021             Expander_Active := False;
1022          end if;
1023
1024          --  Set the fatal error flag in the unit table unless we are
1025          --  in Try_Semantics mode. This stops the semantics from being
1026          --  performed if we find a serious error. This is skipped if we
1027          --  are currently dealing with the configuration pragma file.
1028
1029          if not Try_Semantics
1030            and then Current_Source_Unit /= No_Unit
1031          then
1032             Set_Fatal_Error (Get_Source_Unit (Orig_Loc));
1033          end if;
1034       end Handle_Serious_Error;
1035
1036    --  Start of processing for Error_Msg_Internal
1037
1038    begin
1039       if Raise_Exception_On_Error /= 0 then
1040          raise Error_Msg_Exception;
1041       end if;
1042
1043       Continuation := Msg_Cont;
1044       Suppress_Message := False;
1045       Kill_Message := False;
1046       Set_Msg_Text (Msg, Orig_Loc);
1047
1048       --  Kill continuation if parent message killed
1049
1050       if Continuation and Last_Killed then
1051          return;
1052       end if;
1053
1054       --  Return without doing anything if message is suppressed
1055
1056       if Suppress_Message
1057         and not All_Errors_Mode
1058         and not (Msg (Msg'Last) = '!')
1059       then
1060          if not Continuation then
1061             Last_Killed := True;
1062          end if;
1063
1064          return;
1065       end if;
1066
1067       --  Return without doing anything if message is killed and this
1068       --  is not the first error message. The philosophy is that if we
1069       --  get a weird error message and we already have had a message,
1070       --  then we hope the weird message is a junk cascaded message
1071
1072       if Kill_Message
1073         and then not All_Errors_Mode
1074         and then Total_Errors_Detected /= 0
1075       then
1076          if not Continuation then
1077             Last_Killed := True;
1078          end if;
1079
1080          return;
1081       end if;
1082
1083       --  Immediate return if warning message and warnings are suppressed
1084
1085       if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then
1086          Cur_Msg := No_Error_Msg;
1087          return;
1088       end if;
1089
1090       --  If message is to be ignored in special ignore message mode, this is
1091       --  where we do this special processing, bypassing message output.
1092
1093       if Ignore_Errors_Enable > 0 then
1094          if Is_Serious_Error then
1095             Handle_Serious_Error;
1096          end if;
1097
1098          return;
1099       end if;
1100
1101       --  Otherwise build error message object for new message
1102
1103       Errors.Increment_Last;
1104       Cur_Msg := Errors.Last;
1105       Errors.Table (Cur_Msg).Text     := new String'(Msg_Buffer (1 .. Msglen));
1106       Errors.Table (Cur_Msg).Next     := No_Error_Msg;
1107       Errors.Table (Cur_Msg).Sptr     := Orig_Loc;
1108       Errors.Table (Cur_Msg).Fptr     := Flag_Location;
1109       Errors.Table (Cur_Msg).Sfile    := Get_Source_File_Index (Orig_Loc);
1110       Errors.Table (Cur_Msg).Line     := Get_Physical_Line_Number (Orig_Loc);
1111       Errors.Table (Cur_Msg).Col      := Get_Column_Number (Orig_Loc);
1112       Errors.Table (Cur_Msg).Warn     := Is_Warning_Msg;
1113       Errors.Table (Cur_Msg).Serious  := Is_Serious_Error;
1114       Errors.Table (Cur_Msg).Uncond   := Is_Unconditional_Msg;
1115       Errors.Table (Cur_Msg).Msg_Cont := Continuation;
1116       Errors.Table (Cur_Msg).Deleted  := False;
1117
1118       --  If immediate errors mode set, output error message now. Also output
1119       --  now if the -d1 debug flag is set (so node number message comes out
1120       --  just before actual error message)
1121
1122       if Debug_Flag_OO or else Debug_Flag_1 then
1123          Write_Eol;
1124          Output_Source_Line (Errors.Table (Cur_Msg).Line,
1125            Errors.Table (Cur_Msg).Sfile, True);
1126          Temp_Msg := Cur_Msg;
1127          Output_Error_Msgs (Temp_Msg);
1128
1129       --  If not in immediate errors mode, then we insert the message in the
1130       --  error chain for later output by Finalize. The messages are sorted
1131       --  first by unit (main unit comes first), and within a unit by source
1132       --  location (earlier flag location first in the chain).
1133
1134       else
1135          Prev_Msg := No_Error_Msg;
1136          Next_Msg := Error_Msgs;
1137
1138          while Next_Msg /= No_Error_Msg loop
1139             exit when
1140               Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;
1141
1142             if Errors.Table (Cur_Msg).Sfile =
1143                  Errors.Table (Next_Msg).Sfile
1144             then
1145                exit when Orig_Loc < Errors.Table (Next_Msg).Sptr;
1146             end if;
1147
1148             Prev_Msg := Next_Msg;
1149             Next_Msg := Errors.Table (Next_Msg).Next;
1150          end loop;
1151
1152          --  Now we insert the new message in the error chain. The insertion
1153          --  point for the message is after Prev_Msg and before Next_Msg.
1154
1155          --  The possible insertion point for the new message is after Prev_Msg
1156          --  and before Next_Msg. However, this is where we do a special check
1157          --  for redundant parsing messages, defined as messages posted on the
1158          --  same line. The idea here is that probably such messages are junk
1159          --  from the parser recovering. In full errors mode, we don't do this
1160          --  deletion, but otherwise such messages are discarded at this stage.
1161
1162          if Prev_Msg /= No_Error_Msg
1163            and then Errors.Table (Prev_Msg).Line =
1164                                              Errors.Table (Cur_Msg).Line
1165            and then Errors.Table (Prev_Msg).Sfile =
1166                                              Errors.Table (Cur_Msg).Sfile
1167            and then Compiler_State = Parsing
1168            and then not All_Errors_Mode
1169          then
1170             --  Don't delete unconditional messages and at this stage,
1171             --  don't delete continuation lines (we attempted to delete
1172             --  those earlier if the parent message was deleted.
1173
1174             if not Errors.Table (Cur_Msg).Uncond
1175               and then not Continuation
1176             then
1177
1178                --  Don't delete if prev msg is warning and new msg is
1179                --  an error. This is because we don't want a real error
1180                --  masked by a warning. In all other cases (that is parse
1181                --  errors for the same line that are not unconditional)
1182                --  we do delete the message. This helps to avoid
1183                --  junk extra messages from cascaded parsing errors
1184
1185                if not Errors.Table (Prev_Msg).Warn
1186                  or else Errors.Table (Cur_Msg).Warn
1187                then
1188                   --  All tests passed, delete the message by simply
1189                   --  returning without any further processing.
1190
1191                   if not Continuation then
1192                      Last_Killed := True;
1193                   end if;
1194
1195                   return;
1196                end if;
1197             end if;
1198          end if;
1199
1200          --  Come here if message is to be inserted in the error chain
1201
1202          if not Continuation then
1203             Last_Killed := False;
1204          end if;
1205
1206          if Prev_Msg = No_Error_Msg then
1207             Error_Msgs := Cur_Msg;
1208          else
1209             Errors.Table (Prev_Msg).Next := Cur_Msg;
1210          end if;
1211
1212          Errors.Table (Cur_Msg).Next := Next_Msg;
1213       end if;
1214
1215       --  Bump appropriate statistics count
1216
1217       if Errors.Table (Cur_Msg).Warn then
1218          Warnings_Detected := Warnings_Detected + 1;
1219       else
1220          Total_Errors_Detected := Total_Errors_Detected + 1;
1221
1222          if Errors.Table (Cur_Msg).Serious then
1223             Serious_Errors_Detected := Serious_Errors_Detected + 1;
1224             Handle_Serious_Error;
1225          end if;
1226       end if;
1227
1228       --  Terminate if max errors reached
1229
1230       if Total_Errors_Detected + Warnings_Detected = Maximum_Errors then
1231          raise Unrecoverable_Error;
1232       end if;
1233
1234    end Error_Msg_Internal;
1235
1236    -----------------
1237    -- Error_Msg_N --
1238    -----------------
1239
1240    procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is
1241    begin
1242       Error_Msg_NEL (Msg, N, N, Sloc (N));
1243    end Error_Msg_N;
1244
1245    ------------------
1246    -- Error_Msg_NE --
1247    ------------------
1248
1249    procedure Error_Msg_NE
1250      (Msg : String;
1251       N   : Node_Or_Entity_Id;
1252       E   : Node_Or_Entity_Id)
1253    is
1254    begin
1255       Error_Msg_NEL (Msg, N, E, Sloc (N));
1256    end Error_Msg_NE;
1257
1258    -------------------
1259    -- Error_Msg_NEL --
1260    -------------------
1261
1262    procedure Error_Msg_NEL
1263      (Msg           : String;
1264       N             : Node_Or_Entity_Id;
1265       E             : Node_Or_Entity_Id;
1266       Flag_Location : Source_Ptr)
1267    is
1268    begin
1269       if Special_Msg_Delete (Msg, N, E) then
1270          return;
1271       end if;
1272
1273       if No_Warnings (N) or else No_Warnings (E) then
1274          Test_Warning_Msg (Msg);
1275
1276          if Is_Warning_Msg then
1277             return;
1278          end if;
1279       end if;
1280
1281       if All_Errors_Mode
1282         or else Msg (Msg'Last) = '!'
1283         or else OK_Node (N)
1284         or else (Msg (1) = '\' and not Last_Killed)
1285       then
1286          Debug_Output (N);
1287          Error_Msg_Node_1 := E;
1288          Error_Msg (Msg, Flag_Location);
1289
1290       else
1291          Last_Killed := True;
1292       end if;
1293
1294       if not Is_Warning_Msg then
1295          Set_Posted (N);
1296       end if;
1297    end Error_Msg_NEL;
1298
1299    -----------------
1300    -- Error_Msg_S --
1301    -----------------
1302
1303    procedure Error_Msg_S (Msg : String) is
1304    begin
1305       Error_Msg (Msg, Scan_Ptr);
1306    end Error_Msg_S;
1307
1308    ------------------
1309    -- Error_Msg_SC --
1310    ------------------
1311
1312    procedure Error_Msg_SC (Msg : String) is
1313    begin
1314       --  If we are at end of file, post the flag after the previous token
1315
1316       if Token = Tok_EOF then
1317          Error_Msg_AP (Msg);
1318
1319       --  For all other cases the message is posted at the current token
1320       --  pointer position
1321
1322       else
1323          Error_Msg (Msg, Token_Ptr);
1324       end if;
1325    end Error_Msg_SC;
1326
1327    ------------------
1328    -- Error_Msg_SP --
1329    ------------------
1330
1331    procedure Error_Msg_SP (Msg : String) is
1332    begin
1333       --  Note: in the case where there is no previous token, Prev_Token_Ptr
1334       --  is set to Source_First, which is a reasonable position for the
1335       --  error flag in this situation
1336
1337       Error_Msg (Msg, Prev_Token_Ptr);
1338    end Error_Msg_SP;
1339
1340    --------------
1341    -- Finalize --
1342    --------------
1343
1344    procedure Finalize is
1345       Cur      : Error_Msg_Id;
1346       Nxt      : Error_Msg_Id;
1347       E, F     : Error_Msg_Id;
1348       Err_Flag : Boolean;
1349
1350    begin
1351       --  Reset current error source file if the main unit has a pragma
1352       --  Source_Reference. This ensures outputting the proper name of
1353       --  the source file in this situation.
1354
1355       if Num_SRef_Pragmas (Main_Source_File) /= 0 then
1356          Current_Error_Source_File := No_Source_File;
1357       end if;
1358
1359       --  Eliminate any duplicated error messages from the list. This is
1360       --  done after the fact to avoid problems with Change_Error_Text.
1361
1362       Cur := Error_Msgs;
1363       while Cur /= No_Error_Msg loop
1364          Nxt := Errors.Table (Cur).Next;
1365
1366          F := Nxt;
1367          while F /= No_Error_Msg
1368            and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr
1369          loop
1370             Check_Duplicate_Message (Cur, F);
1371             F := Errors.Table (F).Next;
1372          end loop;
1373
1374          Cur := Nxt;
1375       end loop;
1376
1377       --  Brief Error mode
1378
1379       if Brief_Output or (not Full_List and not Verbose_Mode) then
1380          E := Error_Msgs;
1381          Set_Standard_Error;
1382
1383          while E /= No_Error_Msg loop
1384             if not Errors.Table (E).Deleted and then not Debug_Flag_KK then
1385                Write_Name (Reference_Name (Errors.Table (E).Sfile));
1386                Write_Char (':');
1387                Write_Int (Int (Physical_To_Logical
1388                                 (Errors.Table (E).Line,
1389                                  Errors.Table (E).Sfile)));
1390                Write_Char (':');
1391
1392                if Errors.Table (E).Col < 10 then
1393                   Write_Char ('0');
1394                end if;
1395
1396                Write_Int (Int (Errors.Table (E).Col));
1397                Write_Str (": ");
1398                Output_Msg_Text (E);
1399                Write_Eol;
1400             end if;
1401
1402             E := Errors.Table (E).Next;
1403          end loop;
1404
1405          Set_Standard_Output;
1406       end if;
1407
1408       --  Full source listing case
1409
1410       if Full_List then
1411          List_Pragmas_Index := 1;
1412          List_Pragmas_Mode := True;
1413          E := Error_Msgs;
1414          Write_Eol;
1415
1416          --  First list initial main source file with its error messages
1417
1418          for N in 1 .. Last_Source_Line (Main_Source_File) loop
1419             Err_Flag :=
1420               E /= No_Error_Msg
1421                 and then Errors.Table (E).Line = N
1422                 and then Errors.Table (E).Sfile = Main_Source_File;
1423
1424             Output_Source_Line (N, Main_Source_File, Err_Flag);
1425
1426             if Err_Flag then
1427                Output_Error_Msgs (E);
1428
1429                if not Debug_Flag_2 then
1430                   Write_Eol;
1431                end if;
1432             end if;
1433
1434          end loop;
1435
1436          --  Then output errors, if any, for subsidiary units
1437
1438          while E /= No_Error_Msg
1439            and then Errors.Table (E).Sfile /= Main_Source_File
1440          loop
1441             Write_Eol;
1442             Output_Source_Line
1443               (Errors.Table (E).Line, Errors.Table (E).Sfile, True);
1444             Output_Error_Msgs (E);
1445          end loop;
1446       end if;
1447
1448       --  Verbose mode (error lines only with error flags)
1449
1450       if Verbose_Mode and not Full_List then
1451          E := Error_Msgs;
1452
1453          --  Loop through error lines
1454
1455          while E /= No_Error_Msg loop
1456             Write_Eol;
1457             Output_Source_Line
1458               (Errors.Table (E).Line, Errors.Table (E).Sfile, True);
1459             Output_Error_Msgs (E);
1460          end loop;
1461       end if;
1462
1463       --  Output error summary if verbose or full list mode
1464
1465       if Verbose_Mode or else Full_List then
1466
1467          --  Extra blank line if error messages or source listing were output
1468
1469          if Total_Errors_Detected + Warnings_Detected > 0
1470            or else Full_List
1471          then
1472             Write_Eol;
1473          end if;
1474
1475          --  Message giving number of lines read and number of errors detected.
1476          --  This normally goes to Standard_Output. The exception is when brief
1477          --  mode is not set, verbose mode (or full list mode) is set, and
1478          --  there are errors. In this case we send the message to standard
1479          --  error to make sure that *something* appears on standard error in
1480          --  an error situation.
1481
1482          --  Formerly, only the "# errors" suffix was sent to stderr, whereas
1483          --  "# lines:" appeared on stdout. This caused problems on VMS when
1484          --  the stdout buffer was flushed, giving an extra line feed after
1485          --  the prefix.
1486
1487          if Total_Errors_Detected + Warnings_Detected /= 0
1488            and then not Brief_Output
1489            and then (Verbose_Mode or Full_List)
1490          then
1491             Set_Standard_Error;
1492          end if;
1493
1494          --  Message giving total number of lines
1495
1496          Write_Str (" ");
1497          Write_Int (Num_Source_Lines (Main_Source_File));
1498
1499          if Num_Source_Lines (Main_Source_File) = 1 then
1500             Write_Str (" line: ");
1501          else
1502             Write_Str (" lines: ");
1503          end if;
1504
1505          if Total_Errors_Detected = 0 then
1506             Write_Str ("No errors");
1507
1508          elsif Total_Errors_Detected = 1 then
1509             Write_Str ("1 error");
1510
1511          else
1512             Write_Int (Total_Errors_Detected);
1513             Write_Str (" errors");
1514          end if;
1515
1516          if Warnings_Detected /= 0 then
1517             Write_Str (", ");
1518             Write_Int (Warnings_Detected);
1519             Write_Str (" warning");
1520
1521             if Warnings_Detected /= 1 then
1522                Write_Char ('s');
1523             end if;
1524
1525             if Warning_Mode = Treat_As_Error then
1526                Write_Str (" (treated as error");
1527
1528                if Warnings_Detected /= 1 then
1529                   Write_Char ('s');
1530                end if;
1531
1532                Write_Char (')');
1533             end if;
1534          end if;
1535
1536          Write_Eol;
1537          Set_Standard_Output;
1538       end if;
1539
1540       if Maximum_Errors /= 0
1541         and then Total_Errors_Detected + Warnings_Detected = Maximum_Errors
1542       then
1543          Set_Standard_Error;
1544          Write_Str ("fatal error: maximum errors reached");
1545          Write_Eol;
1546          Set_Standard_Output;
1547       end if;
1548
1549       if Warning_Mode = Treat_As_Error then
1550          Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected;
1551          Warnings_Detected := 0;
1552       end if;
1553
1554    end Finalize;
1555
1556    ------------------
1557    -- Get_Location --
1558    ------------------
1559
1560    function Get_Location (E : Error_Msg_Id) return Source_Ptr is
1561    begin
1562       return Errors.Table (E).Sptr;
1563    end Get_Location;
1564
1565    ----------------
1566    -- Get_Msg_Id --
1567    ----------------
1568
1569    function Get_Msg_Id return Error_Msg_Id is
1570    begin
1571       return Cur_Msg;
1572    end Get_Msg_Id;
1573
1574    ----------------
1575    -- Initialize --
1576    ----------------
1577
1578    procedure Initialize is
1579    begin
1580       Errors.Init;
1581       Error_Msgs := No_Error_Msg;
1582       Serious_Errors_Detected := 0;
1583       Total_Errors_Detected := 0;
1584       Warnings_Detected := 0;
1585       Cur_Msg := No_Error_Msg;
1586       List_Pragmas.Init;
1587
1588       --  Initialize warnings table, if all warnings are suppressed, supply
1589       --  an initial dummy entry covering all possible source locations.
1590
1591       Warnings.Init;
1592
1593       if Warning_Mode = Suppress then
1594          Warnings.Increment_Last;
1595          Warnings.Table (Warnings.Last).Start := Source_Ptr'First;
1596          Warnings.Table (Warnings.Last).Stop  := Source_Ptr'Last;
1597       end if;
1598
1599    end Initialize;
1600
1601    -----------------
1602    -- No_Warnings --
1603    -----------------
1604
1605    function No_Warnings (N : Node_Or_Entity_Id) return Boolean is
1606    begin
1607       if Error_Posted (N) then
1608          return True;
1609
1610       elsif Nkind (N) in N_Entity and then Warnings_Off (N) then
1611          return True;
1612
1613       elsif Is_Entity_Name (N)
1614         and then Present (Entity (N))
1615         and then Warnings_Off (Entity (N))
1616       then
1617          return True;
1618
1619       else
1620          return False;
1621       end if;
1622    end No_Warnings;
1623
1624    -------------
1625    -- OK_Node --
1626    -------------
1627
1628    function OK_Node (N : Node_Id) return Boolean is
1629       K : constant Node_Kind := Nkind (N);
1630
1631    begin
1632       if Error_Posted (N) then
1633          return False;
1634
1635       elsif K in N_Has_Etype
1636         and then Present (Etype (N))
1637         and then Error_Posted (Etype (N))
1638       then
1639          return False;
1640
1641       elsif (K in N_Op
1642               or else K = N_Attribute_Reference
1643               or else K = N_Character_Literal
1644               or else K = N_Expanded_Name
1645               or else K = N_Identifier
1646               or else K = N_Operator_Symbol)
1647         and then Present (Entity (N))
1648         and then Error_Posted (Entity (N))
1649       then
1650          return False;
1651       else
1652          return True;
1653       end if;
1654    end OK_Node;
1655
1656    -----------------------
1657    -- Output_Error_Msgs --
1658    -----------------------
1659
1660    procedure Output_Error_Msgs (E : in out Error_Msg_Id) is
1661       P : Source_Ptr;
1662       T : Error_Msg_Id;
1663       S : Error_Msg_Id;
1664
1665       Flag_Num   : Pos;
1666       Mult_Flags : Boolean := False;
1667
1668    begin
1669       S := E;
1670
1671       --  Skip deleted messages at start
1672
1673       if Errors.Table (S).Deleted then
1674          Set_Next_Non_Deleted_Msg (S);
1675       end if;
1676
1677       --  Figure out if we will place more than one error flag on this line
1678
1679       T := S;
1680       while T /= No_Error_Msg
1681         and then Errors.Table (T).Line = Errors.Table (E).Line
1682         and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
1683       loop
1684          if Errors.Table (T).Sptr > Errors.Table (E).Sptr then
1685             Mult_Flags := True;
1686          end if;
1687
1688          Set_Next_Non_Deleted_Msg (T);
1689       end loop;
1690
1691       --  Output the error flags. The circuit here makes sure that the tab
1692       --  characters in the original line are properly accounted for. The
1693       --  eight blanks at the start are to match the line number.
1694
1695       if not Debug_Flag_2 then
1696          Write_Str ("        ");
1697          P := Line_Start (Errors.Table (E).Sptr);
1698          Flag_Num := 1;
1699
1700          --  Loop through error messages for this line to place flags
1701
1702          T := S;
1703          while T /= No_Error_Msg
1704            and then Errors.Table (T).Line = Errors.Table (E).Line
1705            and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
1706          loop
1707             --  Loop to output blanks till current flag position
1708
1709             while P < Errors.Table (T).Sptr loop
1710                if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then
1711                   Write_Char (ASCII.HT);
1712                else
1713                   Write_Char (' ');
1714                end if;
1715
1716                P := P + 1;
1717             end loop;
1718
1719             --  Output flag (unless already output, this happens if more
1720             --  than one error message occurs at the same flag position).
1721
1722             if P = Errors.Table (T).Sptr then
1723                if (Flag_Num = 1 and then not Mult_Flags)
1724                  or else Flag_Num > 9
1725                then
1726                   Write_Char ('|');
1727                else
1728                   Write_Char (Character'Val (Character'Pos ('0') + Flag_Num));
1729                end if;
1730
1731                P := P + 1;
1732             end if;
1733
1734             Set_Next_Non_Deleted_Msg (T);
1735             Flag_Num := Flag_Num + 1;
1736          end loop;
1737
1738          Write_Eol;
1739       end if;
1740
1741       --  Now output the error messages
1742
1743       T := S;
1744       while T /= No_Error_Msg
1745         and then Errors.Table (T).Line = Errors.Table (E).Line
1746         and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
1747
1748       loop
1749          Write_Str ("        >>> ");
1750          Output_Msg_Text (T);
1751
1752          if Debug_Flag_2 then
1753             while Column < 74 loop
1754                Write_Char (' ');
1755             end loop;
1756
1757             Write_Str (" <<<");
1758          end if;
1759
1760          Write_Eol;
1761          Set_Next_Non_Deleted_Msg (T);
1762       end loop;
1763
1764       E := T;
1765    end Output_Error_Msgs;
1766
1767    ------------------------
1768    -- Output_Line_Number --
1769    ------------------------
1770
1771    procedure Output_Line_Number (L : Logical_Line_Number) is
1772       D     : Int;       -- next digit
1773       C     : Character; -- next character
1774       Z     : Boolean;   -- flag for zero suppress
1775       N, M  : Int;       -- temporaries
1776
1777    begin
1778       if L = No_Line_Number then
1779          Write_Str ("        ");
1780
1781       else
1782          Z := False;
1783          N := Int (L);
1784
1785          M := 100_000;
1786          while M /= 0 loop
1787             D := Int (N / M);
1788             N := N rem M;
1789             M := M / 10;
1790
1791             if D = 0 then
1792                if Z then
1793                   C := '0';
1794                else
1795                   C := ' ';
1796                end if;
1797             else
1798                Z := True;
1799                C := Character'Val (D + 48);
1800             end if;
1801
1802             Write_Char (C);
1803          end loop;
1804
1805          Write_Str (". ");
1806       end if;
1807    end Output_Line_Number;
1808
1809    ---------------------
1810    -- Output_Msg_Text --
1811    ---------------------
1812
1813    procedure Output_Msg_Text (E : Error_Msg_Id) is
1814    begin
1815       if Errors.Table (E).Warn then
1816          if Errors.Table (E).Text'Length > 7
1817            and then Errors.Table (E).Text (1 .. 7) /= "(style)"
1818          then
1819             Write_Str ("warning: ");
1820          end if;
1821
1822       elsif Opt.Unique_Error_Tag then
1823          Write_Str ("error: ");
1824       end if;
1825
1826       Write_Str (Errors.Table (E).Text.all);
1827    end Output_Msg_Text;
1828
1829    ------------------------
1830    -- Output_Source_Line --
1831    ------------------------
1832
1833    procedure Output_Source_Line
1834      (L     : Physical_Line_Number;
1835       Sfile : Source_File_Index;
1836       Errs  : Boolean)
1837    is
1838       S : Source_Ptr;
1839       C : Character;
1840
1841       Line_Number_Output : Boolean := False;
1842       --  Set True once line number is output
1843
1844    begin
1845       if Sfile /= Current_Error_Source_File then
1846          Write_Str ("==============Error messages for source file: ");
1847          Write_Name (Full_File_Name (Sfile));
1848          Write_Eol;
1849
1850          if Num_SRef_Pragmas (Sfile) > 0 then
1851             Write_Str ("--------------Line numbers from file: ");
1852             Write_Name (Full_Ref_Name (Sfile));
1853
1854             --  Write starting line, except do not write it if we had more
1855             --  than one source reference pragma, since in this case there
1856             --  is no very useful number to write.
1857
1858             Write_Str (" (starting at line ");
1859             Write_Int (Int (First_Mapped_Line (Sfile)));
1860             Write_Char (')');
1861             Write_Eol;
1862          end if;
1863
1864          Current_Error_Source_File := Sfile;
1865       end if;
1866
1867       if Errs or List_Pragmas_Mode then
1868          Output_Line_Number (Physical_To_Logical (L, Sfile));
1869          Line_Number_Output := True;
1870       end if;
1871
1872       S := Line_Start (L, Sfile);
1873
1874       loop
1875          C := Source_Text (Sfile) (S);
1876          exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF;
1877
1878          --  Deal with matching entry in List_Pragmas table
1879
1880          if Full_List
1881            and then List_Pragmas_Index <= List_Pragmas.Last
1882            and then S = List_Pragmas.Table (List_Pragmas_Index).Ploc
1883          then
1884             case List_Pragmas.Table (List_Pragmas_Index).Ptyp is
1885                when Page =>
1886                   Write_Char (C);
1887
1888                   --  Ignore if on line with errors so that error flags
1889                   --  get properly listed with the error line .
1890
1891                   if not Errs then
1892                      Write_Char (ASCII.FF);
1893                   end if;
1894
1895                when List_On =>
1896                   List_Pragmas_Mode := True;
1897
1898                   if not Line_Number_Output then
1899                      Output_Line_Number (Physical_To_Logical (L, Sfile));
1900                      Line_Number_Output := True;
1901                   end if;
1902
1903                   Write_Char (C);
1904
1905                when List_Off =>
1906                   Write_Char (C);
1907                   List_Pragmas_Mode := False;
1908             end case;
1909
1910             List_Pragmas_Index := List_Pragmas_Index + 1;
1911
1912          --  Normal case (no matching entry in List_Pragmas table)
1913
1914          else
1915             if Errs or List_Pragmas_Mode then
1916                Write_Char (C);
1917             end if;
1918          end if;
1919
1920          S := S + 1;
1921       end loop;
1922
1923       if Line_Number_Output then
1924          Write_Eol;
1925       end if;
1926    end Output_Source_Line;
1927
1928    --------------------
1929    -- Purge_Messages --
1930    --------------------
1931
1932    procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
1933       E : Error_Msg_Id;
1934
1935       function To_Be_Purged (E : Error_Msg_Id) return Boolean;
1936       --  Returns True for a message that is to be purged. Also adjusts
1937       --  error counts appropriately.
1938
1939       function To_Be_Purged (E : Error_Msg_Id) return Boolean is
1940       begin
1941          if E /= No_Error_Msg
1942            and then Errors.Table (E).Sptr > From
1943            and then Errors.Table (E).Sptr < To
1944          then
1945             if Errors.Table (E).Warn then
1946                Warnings_Detected := Warnings_Detected - 1;
1947             else
1948                Total_Errors_Detected := Total_Errors_Detected - 1;
1949
1950                if Errors.Table (E).Serious then
1951                   Serious_Errors_Detected := Serious_Errors_Detected - 1;
1952                end if;
1953             end if;
1954
1955             return True;
1956
1957          else
1958             return False;
1959          end if;
1960       end To_Be_Purged;
1961
1962    --  Start of processing for Purge_Messages
1963
1964    begin
1965       while To_Be_Purged (Error_Msgs) loop
1966          Error_Msgs := Errors.Table (Error_Msgs).Next;
1967       end loop;
1968
1969       E := Error_Msgs;
1970       while E /= No_Error_Msg loop
1971          while To_Be_Purged (Errors.Table (E).Next) loop
1972             Errors.Table (E).Next :=
1973               Errors.Table (Errors.Table (E).Next).Next;
1974          end loop;
1975
1976          E := Errors.Table (E).Next;
1977       end loop;
1978    end Purge_Messages;
1979
1980    -----------------------------
1981    -- Remove_Warning_Messages --
1982    -----------------------------
1983
1984    procedure Remove_Warning_Messages (N : Node_Id) is
1985
1986       function Check_For_Warning (N : Node_Id) return Traverse_Result;
1987       --  This function checks one node for a possible warning message.
1988
1989       function Check_All_Warnings is new
1990         Traverse_Func (Check_For_Warning);
1991       --  This defines the traversal operation
1992
1993       -----------------------
1994       -- Check_For_Warning --
1995       -----------------------
1996
1997       function Check_For_Warning (N : Node_Id) return Traverse_Result is
1998          Loc : constant Source_Ptr := Sloc (N);
1999          E   : Error_Msg_Id;
2000
2001          function To_Be_Removed (E : Error_Msg_Id) return Boolean;
2002          --  Returns True for a message that is to be removed. Also adjusts
2003          --  warning count appropriately.
2004
2005          -------------------
2006          -- To_Be_Removed --
2007          -------------------
2008
2009          function To_Be_Removed (E : Error_Msg_Id) return Boolean is
2010          begin
2011             if E /= No_Error_Msg
2012               and then Errors.Table (E).Fptr = Loc
2013               and then Errors.Table (E).Warn
2014             then
2015                Warnings_Detected := Warnings_Detected - 1;
2016                return True;
2017             else
2018                return False;
2019             end if;
2020          end To_Be_Removed;
2021
2022       --  Start of processing for Check_For_Warnings
2023
2024       begin
2025          while To_Be_Removed (Error_Msgs) loop
2026             Error_Msgs := Errors.Table (Error_Msgs).Next;
2027          end loop;
2028
2029          E := Error_Msgs;
2030          while E /= No_Error_Msg loop
2031             while To_Be_Removed (Errors.Table (E).Next) loop
2032                Errors.Table (E).Next :=
2033                  Errors.Table (Errors.Table (E).Next).Next;
2034             end loop;
2035
2036             E := Errors.Table (E).Next;
2037          end loop;
2038
2039          if Nkind (N) = N_Raise_Constraint_Error
2040            and then Original_Node (N) /= N
2041            and then No (Condition (N))
2042          then
2043             --  Warnings may have been posted on subexpressions of
2044             --  the original tree. We place the original node back
2045             --  on the tree to remove those warnings, whose sloc
2046             --  do not match those of any node in the current tree.
2047             --  Given that we are in unreachable code, this modification
2048             --  to the tree is harmless.
2049
2050             declare
2051                Status : Traverse_Result;
2052
2053             begin
2054                if Is_List_Member (N) then
2055                   Set_Condition (N, Original_Node (N));
2056                   Status := Check_All_Warnings (Condition (N));
2057                else
2058                   Rewrite (N, Original_Node (N));
2059                   Status := Check_All_Warnings (N);
2060                end if;
2061
2062                return Status;
2063             end;
2064
2065          else
2066             return OK;
2067          end if;
2068       end Check_For_Warning;
2069
2070    --  Start of processing for Remove_Warning_Messages
2071
2072    begin
2073       if Warnings_Detected /= 0 then
2074          declare
2075             Discard : Traverse_Result;
2076          begin
2077             Discard := Check_All_Warnings (N);
2078          end;
2079       end if;
2080    end Remove_Warning_Messages;
2081
2082    ----------------
2083    -- Same_Error --
2084    ----------------
2085
2086    function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
2087       Msg1 : constant String_Ptr := Errors.Table (M1).Text;
2088       Msg2 : constant String_Ptr := Errors.Table (M2).Text;
2089
2090       Msg2_Len : constant Integer := Msg2'Length;
2091       Msg1_Len : constant Integer := Msg1'Length;
2092
2093    begin
2094       return
2095         Msg1.all = Msg2.all
2096           or else
2097             (Msg1_Len - 10 > Msg2_Len
2098                and then
2099              Msg2.all = Msg1.all (1 .. Msg2_Len)
2100                and then
2101              Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
2102           or else
2103             (Msg2_Len - 10 > Msg1_Len
2104                and then
2105              Msg1.all = Msg2.all (1 .. Msg1_Len)
2106                and then
2107              Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
2108    end Same_Error;
2109
2110    -------------------
2111    -- Set_Msg_Blank --
2112    -------------------
2113
2114    procedure Set_Msg_Blank is
2115    begin
2116       if Msglen > 0
2117         and then Msg_Buffer (Msglen) /= ' '
2118         and then Msg_Buffer (Msglen) /= '('
2119         and then not Manual_Quote_Mode
2120       then
2121          Set_Msg_Char (' ');
2122       end if;
2123    end Set_Msg_Blank;
2124
2125    -------------------------------
2126    -- Set_Msg_Blank_Conditional --
2127    -------------------------------
2128
2129    procedure Set_Msg_Blank_Conditional is
2130    begin
2131       if Msglen > 0
2132         and then Msg_Buffer (Msglen) /= ' '
2133         and then Msg_Buffer (Msglen) /= '('
2134         and then Msg_Buffer (Msglen) /= '"'
2135         and then not Manual_Quote_Mode
2136       then
2137          Set_Msg_Char (' ');
2138       end if;
2139    end Set_Msg_Blank_Conditional;
2140
2141    ------------------
2142    -- Set_Msg_Char --
2143    ------------------
2144
2145    procedure Set_Msg_Char (C : Character) is
2146    begin
2147
2148       --  The check for message buffer overflow is needed to deal with cases
2149       --  where insertions get too long (in particular a child unit name can
2150       --  be very long).
2151
2152       if Msglen < Max_Msg_Length then
2153          Msglen := Msglen + 1;
2154          Msg_Buffer (Msglen) := C;
2155       end if;
2156    end Set_Msg_Char;
2157
2158    ------------------------------
2159    -- Set_Msg_Insertion_Column --
2160    ------------------------------
2161
2162    procedure Set_Msg_Insertion_Column is
2163    begin
2164       if Style.RM_Column_Check then
2165          Set_Msg_Str (" in column ");
2166          Set_Msg_Int (Int (Error_Msg_Col) + 1);
2167       end if;
2168    end Set_Msg_Insertion_Column;
2169
2170    ---------------------------------
2171    -- Set_Msg_Insertion_File_Name --
2172    ---------------------------------
2173
2174    procedure Set_Msg_Insertion_File_Name is
2175    begin
2176       if Error_Msg_Name_1 = No_Name then
2177          null;
2178
2179       elsif Error_Msg_Name_1 = Error_Name then
2180          Set_Msg_Blank;
2181          Set_Msg_Str ("<error>");
2182
2183       else
2184          Set_Msg_Blank;
2185          Get_Name_String (Error_Msg_Name_1);
2186          Set_Msg_Quote;
2187          Set_Msg_Name_Buffer;
2188          Set_Msg_Quote;
2189       end if;
2190
2191       --  The following assignments ensure that the second and third percent
2192       --  insertion characters will correspond to the Error_Msg_Name_2 and
2193       --  Error_Msg_Name_3 as required.
2194
2195       Error_Msg_Name_1 := Error_Msg_Name_2;
2196       Error_Msg_Name_2 := Error_Msg_Name_3;
2197
2198    end Set_Msg_Insertion_File_Name;
2199
2200    -----------------------------------
2201    -- Set_Msg_Insertion_Line_Number --
2202    -----------------------------------
2203
2204    procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
2205       Sindex_Loc  : Source_File_Index;
2206       Sindex_Flag : Source_File_Index;
2207
2208    begin
2209       Set_Msg_Blank;
2210
2211       if Loc = No_Location then
2212          Set_Msg_Str ("at unknown location");
2213
2214       elsif Loc <= Standard_Location then
2215          Set_Msg_Str ("in package Standard");
2216
2217          if Loc = Standard_ASCII_Location then
2218             Set_Msg_Str (".ASCII");
2219          end if;
2220
2221       else
2222          --  Add "at file-name:" if reference is to other than the source
2223          --  file in which the error message is placed. Note that we check
2224          --  full file names, rather than just the source indexes, to
2225          --  deal with generic instantiations from the current file.
2226
2227          Sindex_Loc  := Get_Source_File_Index (Loc);
2228          Sindex_Flag := Get_Source_File_Index (Flag);
2229
2230          if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
2231             Set_Msg_Str ("at ");
2232             Get_Name_String
2233               (Reference_Name (Get_Source_File_Index (Loc)));
2234             Set_Msg_Name_Buffer;
2235             Set_Msg_Char (':');
2236
2237          --  If in current file, add text "at line "
2238
2239          else
2240             Set_Msg_Str ("at line ");
2241          end if;
2242
2243          --  Output line number for reference
2244
2245          Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
2246
2247          --  Deal with the instantiation case. We may have a reference to,
2248          --  e.g. a type, that is declared within a generic template, and
2249          --  what we are really referring to is the occurrence in an instance.
2250          --  In this case, the line number of the instantiation is also of
2251          --  interest, and we add a notation:
2252
2253          --    , instance at xxx
2254
2255          --  where xxx is a line number output using this same routine (and
2256          --  the recursion can go further if the instantiation is itself in
2257          --  a generic template).
2258
2259          --  The flag location passed to us in this situation is indeed the
2260          --  line number within the template, but as described in Sinput.L
2261          --  (file sinput-l.ads, section "Handling Generic Instantiations")
2262          --  we can retrieve the location of the instantiation itself from
2263          --  this flag location value.
2264
2265          --  Note: this processing is suppressed if Suppress_Instance_Location
2266          --  is set True. This is used to prevent redundant annotations of the
2267          --  location of the instantiation in the case where we are placing
2268          --  the messages on the instantiation in any case.
2269
2270          if Instantiation (Sindex_Loc) /= No_Location
2271            and then not Suppress_Instance_Location
2272          then
2273             Set_Msg_Str (", instance ");
2274             Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
2275          end if;
2276       end if;
2277    end Set_Msg_Insertion_Line_Number;
2278
2279    ----------------------------
2280    -- Set_Msg_Insertion_Name --
2281    ----------------------------
2282
2283    procedure Set_Msg_Insertion_Name is
2284    begin
2285       if Error_Msg_Name_1 = No_Name then
2286          null;
2287
2288       elsif Error_Msg_Name_1 = Error_Name then
2289          Set_Msg_Blank;
2290          Set_Msg_Str ("<error>");
2291
2292       else
2293          Set_Msg_Blank_Conditional;
2294          Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
2295
2296          --  Remove %s or %b at end. These come from unit names. If the
2297          --  caller wanted the (unit) or (body), then they would have used
2298          --  the $ insertion character. Certainly no error message should
2299          --  ever have %b or %s explicitly occurring.
2300
2301          if Name_Len > 2
2302            and then Name_Buffer (Name_Len - 1) = '%'
2303            and then (Name_Buffer (Name_Len) = 'b'
2304                        or else
2305                      Name_Buffer (Name_Len) = 's')
2306          then
2307             Name_Len := Name_Len - 2;
2308          end if;
2309
2310          --  Remove upper case letter at end, again, we should not be getting
2311          --  such names, and what we hope is that the remainder makes sense.
2312
2313          if Name_Len > 1
2314            and then Name_Buffer (Name_Len) in 'A' .. 'Z'
2315          then
2316             Name_Len := Name_Len - 1;
2317          end if;
2318
2319          --  If operator name or character literal name, just print it as is
2320          --  Also print as is if it ends in a right paren (case of x'val(nnn))
2321
2322          if Name_Buffer (1) = '"'
2323            or else Name_Buffer (1) = '''
2324            or else Name_Buffer (Name_Len) = ')'
2325          then
2326             Set_Msg_Name_Buffer;
2327
2328          --  Else output with surrounding quotes in proper casing mode
2329
2330          else
2331             Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
2332             Set_Msg_Quote;
2333             Set_Msg_Name_Buffer;
2334             Set_Msg_Quote;
2335          end if;
2336       end if;
2337
2338       --  The following assignments ensure that the second and third percent
2339       --  insertion characters will correspond to the Error_Msg_Name_2 and
2340       --  Error_Msg_Name_3 as required.
2341
2342       Error_Msg_Name_1 := Error_Msg_Name_2;
2343       Error_Msg_Name_2 := Error_Msg_Name_3;
2344
2345    end Set_Msg_Insertion_Name;
2346
2347    ----------------------------
2348    -- Set_Msg_Insertion_Node --
2349    ----------------------------
2350
2351    procedure Set_Msg_Insertion_Node is
2352    begin
2353       Suppress_Message :=
2354         Error_Msg_Node_1 = Error
2355           or else Error_Msg_Node_1 = Any_Type;
2356
2357       if Error_Msg_Node_1 = Empty then
2358          Set_Msg_Blank_Conditional;
2359          Set_Msg_Str ("<empty>");
2360
2361       elsif Error_Msg_Node_1 = Error then
2362          Set_Msg_Blank;
2363          Set_Msg_Str ("<error>");
2364
2365       elsif Error_Msg_Node_1 = Standard_Void_Type then
2366          Set_Msg_Blank;
2367          Set_Msg_Str ("procedure name");
2368
2369       else
2370          Set_Msg_Blank_Conditional;
2371
2372          --  Skip quotes for operator case
2373
2374          if Nkind (Error_Msg_Node_1) in N_Op then
2375             Set_Msg_Node (Error_Msg_Node_1);
2376
2377          else
2378             Set_Msg_Quote;
2379             Set_Qualification (Error_Msg_Qual_Level, Error_Msg_Node_1);
2380             Set_Msg_Node (Error_Msg_Node_1);
2381             Set_Msg_Quote;
2382          end if;
2383       end if;
2384
2385       --  The following assignment ensures that a second ampersand insertion
2386       --  character will correspond to the Error_Msg_Node_2 parameter.
2387
2388       Error_Msg_Node_1 := Error_Msg_Node_2;
2389
2390    end Set_Msg_Insertion_Node;
2391
2392    -------------------------------------
2393    -- Set_Msg_Insertion_Reserved_Name --
2394    -------------------------------------
2395
2396    procedure Set_Msg_Insertion_Reserved_Name is
2397    begin
2398       Set_Msg_Blank_Conditional;
2399       Get_Name_String (Error_Msg_Name_1);
2400       Set_Msg_Quote;
2401       Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
2402       Set_Msg_Name_Buffer;
2403       Set_Msg_Quote;
2404    end Set_Msg_Insertion_Reserved_Name;
2405
2406    -------------------------------------
2407    -- Set_Msg_Insertion_Reserved_Word --
2408    -------------------------------------
2409
2410    procedure Set_Msg_Insertion_Reserved_Word
2411      (Text : String;
2412       J    : in out Integer)
2413    is
2414    begin
2415       Set_Msg_Blank_Conditional;
2416       Name_Len := 0;
2417
2418       while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
2419          Name_Len := Name_Len + 1;
2420          Name_Buffer (Name_Len) := Text (J);
2421          J := J + 1;
2422       end loop;
2423
2424       Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
2425       Set_Msg_Quote;
2426       Set_Msg_Name_Buffer;
2427       Set_Msg_Quote;
2428    end Set_Msg_Insertion_Reserved_Word;
2429
2430    --------------------------------------
2431    -- Set_Msg_Insertion_Type_Reference --
2432    --------------------------------------
2433
2434    procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr) is
2435       Ent : Entity_Id;
2436
2437    begin
2438       Set_Msg_Blank;
2439
2440       if Error_Msg_Node_1 = Standard_Void_Type then
2441          Set_Msg_Str ("package or procedure name");
2442          return;
2443
2444       elsif Error_Msg_Node_1 = Standard_Exception_Type then
2445          Set_Msg_Str ("exception name");
2446          return;
2447
2448       elsif     Error_Msg_Node_1 = Any_Access
2449         or else Error_Msg_Node_1 = Any_Array
2450         or else Error_Msg_Node_1 = Any_Boolean
2451         or else Error_Msg_Node_1 = Any_Character
2452         or else Error_Msg_Node_1 = Any_Composite
2453         or else Error_Msg_Node_1 = Any_Discrete
2454         or else Error_Msg_Node_1 = Any_Fixed
2455         or else Error_Msg_Node_1 = Any_Integer
2456         or else Error_Msg_Node_1 = Any_Modular
2457         or else Error_Msg_Node_1 = Any_Numeric
2458         or else Error_Msg_Node_1 = Any_Real
2459         or else Error_Msg_Node_1 = Any_Scalar
2460         or else Error_Msg_Node_1 = Any_String
2461       then
2462          Get_Unqualified_Decoded_Name_String (Chars (Error_Msg_Node_1));
2463          Set_Msg_Name_Buffer;
2464          return;
2465
2466       elsif Error_Msg_Node_1 = Universal_Real then
2467          Set_Msg_Str ("type universal real");
2468          return;
2469
2470       elsif Error_Msg_Node_1 = Universal_Integer then
2471          Set_Msg_Str ("type universal integer");
2472          return;
2473
2474       elsif Error_Msg_Node_1 = Universal_Fixed then
2475          Set_Msg_Str ("type universal fixed");
2476          return;
2477       end if;
2478
2479       --  Special case of anonymous array
2480
2481       if Nkind (Error_Msg_Node_1) in N_Entity
2482         and then Is_Array_Type (Error_Msg_Node_1)
2483         and then Present (Related_Array_Object (Error_Msg_Node_1))
2484       then
2485          Set_Msg_Str ("type of ");
2486          Set_Msg_Node (Related_Array_Object (Error_Msg_Node_1));
2487          Set_Msg_Str (" declared");
2488          Set_Msg_Insertion_Line_Number
2489            (Sloc (Related_Array_Object (Error_Msg_Node_1)), Flag);
2490          return;
2491       end if;
2492
2493       --  If we fall through, it is not a special case, so first output
2494       --  the name of the type, preceded by private for a private type
2495
2496       if Is_Private_Type (Error_Msg_Node_1) then
2497          Set_Msg_Str ("private type ");
2498       else
2499          Set_Msg_Str ("type ");
2500       end if;
2501
2502       Ent := Error_Msg_Node_1;
2503
2504       if Is_Internal_Name (Chars (Ent)) then
2505          Unwind_Internal_Type (Ent);
2506       end if;
2507
2508       --  Types in Standard are displayed as "Standard.name"
2509
2510       if Sloc (Ent) <= Standard_Location then
2511          Set_Msg_Quote;
2512          Set_Msg_Str ("Standard.");
2513          Set_Msg_Node (Ent);
2514          Add_Class;
2515          Set_Msg_Quote;
2516
2517       --  Types in other language defined units are displayed as
2518       --  "package-name.type-name"
2519
2520       elsif
2521         Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Ent)))
2522       then
2523          Get_Unqualified_Decoded_Name_String
2524            (Unit_Name (Get_Source_Unit (Ent)));
2525          Name_Len := Name_Len - 2;
2526          Set_Msg_Quote;
2527          Set_Casing (Mixed_Case);
2528          Set_Msg_Name_Buffer;
2529          Set_Msg_Char ('.');
2530          Set_Casing (Mixed_Case);
2531          Set_Msg_Node (Ent);
2532          Add_Class;
2533          Set_Msg_Quote;
2534
2535       --  All other types display as "type name" defined at line xxx
2536       --  possibly qualified if qualification is requested.
2537
2538       else
2539          Set_Msg_Quote;
2540          Set_Qualification (Error_Msg_Qual_Level, Ent);
2541          Set_Msg_Node (Ent);
2542          Add_Class;
2543          Set_Msg_Quote;
2544       end if;
2545
2546       --  If the original type did not come from a predefined
2547       --  file, add the location where the type was defined.
2548
2549       if Sloc (Error_Msg_Node_1) > Standard_Location
2550         and then
2551           not Is_Predefined_File_Name
2552                 (Unit_File_Name (Get_Source_Unit (Error_Msg_Node_1)))
2553       then
2554          Set_Msg_Str (" defined");
2555          Set_Msg_Insertion_Line_Number (Sloc (Error_Msg_Node_1), Flag);
2556
2557       --  If it did come from a predefined file, deal with the case where
2558       --  this was a file with a generic instantiation from elsewhere.
2559
2560       else
2561          if Sloc (Error_Msg_Node_1) > Standard_Location then
2562             declare
2563                Iloc : constant Source_Ptr :=
2564                         Instantiation_Location (Sloc (Error_Msg_Node_1));
2565
2566             begin
2567                if Iloc /= No_Location
2568                  and then not Suppress_Instance_Location
2569                then
2570                   Set_Msg_Str (" from instance");
2571                   Set_Msg_Insertion_Line_Number (Iloc, Flag);
2572                end if;
2573             end;
2574          end if;
2575       end if;
2576
2577    end Set_Msg_Insertion_Type_Reference;
2578
2579    ----------------------------
2580    -- Set_Msg_Insertion_Uint --
2581    ----------------------------
2582
2583    procedure Set_Msg_Insertion_Uint is
2584    begin
2585       Set_Msg_Blank;
2586       UI_Image (Error_Msg_Uint_1);
2587
2588       for J in 1 .. UI_Image_Length loop
2589          Set_Msg_Char (UI_Image_Buffer (J));
2590       end loop;
2591
2592       --  The following assignment ensures that a second carret insertion
2593       --  character will correspond to the Error_Msg_Uint_2 parameter.
2594
2595       Error_Msg_Uint_1 := Error_Msg_Uint_2;
2596    end Set_Msg_Insertion_Uint;
2597
2598    ---------------------------------
2599    -- Set_Msg_Insertion_Unit_Name --
2600    ---------------------------------
2601
2602    procedure Set_Msg_Insertion_Unit_Name is
2603    begin
2604       if Error_Msg_Unit_1 = No_Name then
2605          null;
2606
2607       elsif Error_Msg_Unit_1 = Error_Name then
2608          Set_Msg_Blank;
2609          Set_Msg_Str ("<error>");
2610
2611       else
2612          Get_Unit_Name_String (Error_Msg_Unit_1);
2613          Set_Msg_Blank;
2614          Set_Msg_Quote;
2615          Set_Msg_Name_Buffer;
2616          Set_Msg_Quote;
2617       end if;
2618
2619       --  The following assignment ensures that a second percent insertion
2620       --  character will correspond to the Error_Msg_Unit_2 parameter.
2621
2622       Error_Msg_Unit_1 := Error_Msg_Unit_2;
2623
2624    end Set_Msg_Insertion_Unit_Name;
2625
2626    -----------------
2627    -- Set_Msg_Int --
2628    -----------------
2629
2630    procedure Set_Msg_Int (Line : Int) is
2631    begin
2632       if Line > 9 then
2633          Set_Msg_Int (Line / 10);
2634       end if;
2635
2636       Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
2637    end Set_Msg_Int;
2638
2639    -------------------------
2640    -- Set_Msg_Name_Buffer --
2641    -------------------------
2642
2643    procedure Set_Msg_Name_Buffer is
2644    begin
2645       for J in 1 .. Name_Len loop
2646          Set_Msg_Char (Name_Buffer (J));
2647       end loop;
2648    end Set_Msg_Name_Buffer;
2649
2650    ------------------
2651    -- Set_Msg_Node --
2652    ------------------
2653
2654    procedure Set_Msg_Node (Node : Node_Id) is
2655       Ent : Entity_Id;
2656       Nam : Name_Id;
2657
2658    begin
2659       if Nkind (Node) = N_Designator then
2660          Set_Msg_Node (Name (Node));
2661          Set_Msg_Char ('.');
2662          Set_Msg_Node (Identifier (Node));
2663          return;
2664
2665       elsif Nkind (Node) = N_Defining_Program_Unit_Name then
2666          Set_Msg_Node (Name (Node));
2667          Set_Msg_Char ('.');
2668          Set_Msg_Node (Defining_Identifier (Node));
2669          return;
2670
2671       elsif Nkind (Node) = N_Selected_Component then
2672          Set_Msg_Node (Prefix (Node));
2673          Set_Msg_Char ('.');
2674          Set_Msg_Node (Selector_Name (Node));
2675          return;
2676       end if;
2677
2678       --  The only remaining possibilities are identifiers, defining
2679       --  identifiers, pragmas, and pragma argument associations, i.e.
2680       --  nodes that have a Chars field.
2681
2682       --  Internal names generally represent something gone wrong. An exception
2683       --  is the case of internal type names, where we try to find a reasonable
2684       --  external representation for the external name
2685
2686       if Is_Internal_Name (Chars (Node))
2687         and then
2688           ((Is_Entity_Name (Node)
2689                           and then Present (Entity (Node))
2690                           and then Is_Type (Entity (Node)))
2691               or else
2692            (Nkind (Node) = N_Defining_Identifier and then Is_Type (Node)))
2693       then
2694          if Nkind (Node) = N_Identifier then
2695             Ent := Entity (Node);
2696          else
2697             Ent := Node;
2698          end if;
2699
2700          Unwind_Internal_Type (Ent);
2701          Nam := Chars (Ent);
2702
2703       else
2704          Nam := Chars (Node);
2705       end if;
2706
2707       --  At this stage, the name to output is in Nam
2708
2709       Get_Unqualified_Decoded_Name_String (Nam);
2710
2711       --  Remove trailing upper case letters from the name (useful for
2712       --  dealing with some cases of internal names.
2713
2714       while Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' loop
2715          Name_Len := Name_Len  - 1;
2716       end loop;
2717
2718       --  If we have any of the names from standard that start with the
2719       --  characters "any " (e.g. Any_Type), then kill the message since
2720       --  almost certainly it is a junk cascaded message.
2721
2722       if Name_Len > 4
2723         and then Name_Buffer (1 .. 4) = "any "
2724       then
2725          Kill_Message := True;
2726       end if;
2727
2728       --  Now we have to set the proper case. If we have a source location
2729       --  then do a check to see if the name in the source is the same name
2730       --  as the name in the Names table, except for possible differences
2731       --  in case, which is the case when we can copy from the source.
2732
2733       declare
2734          Src_Loc : constant Source_Ptr := Sloc (Error_Msg_Node_1);
2735          Sbuffer : Source_Buffer_Ptr;
2736          Ref_Ptr : Integer;
2737          Src_Ptr : Source_Ptr;
2738
2739       begin
2740          Ref_Ptr := 1;
2741          Src_Ptr := Src_Loc;
2742
2743          --  Determine if the reference we are dealing with corresponds
2744          --  to text at the point of the error reference. This will often
2745          --  be the case for simple identifier references, and is the case
2746          --  where we can copy the spelling from the source.
2747
2748          if Src_Loc /= No_Location
2749            and then Src_Loc > Standard_Location
2750          then
2751             Sbuffer := Source_Text (Get_Source_File_Index (Src_Loc));
2752
2753             while Ref_Ptr <= Name_Len loop
2754                exit when
2755                  Fold_Lower (Sbuffer (Src_Ptr)) /=
2756                  Fold_Lower (Name_Buffer (Ref_Ptr));
2757                Ref_Ptr := Ref_Ptr + 1;
2758                Src_Ptr := Src_Ptr + 1;
2759             end loop;
2760          end if;
2761
2762          --  If we get through the loop without a mismatch, then output
2763          --  the name the way it is spelled in the source program
2764
2765          if Ref_Ptr > Name_Len then
2766             Src_Ptr := Src_Loc;
2767
2768             for J in 1 .. Name_Len loop
2769                Name_Buffer (J) := Sbuffer (Src_Ptr);
2770                Src_Ptr := Src_Ptr + 1;
2771             end loop;
2772
2773          --  Otherwise set the casing using the default identifier casing
2774
2775          else
2776             Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
2777          end if;
2778       end;
2779
2780       Set_Msg_Name_Buffer;
2781       Add_Class;
2782
2783       --  Add 'Class if class wide type
2784
2785       if Class_Flag then
2786          Set_Msg_Char (''');
2787          Get_Name_String (Name_Class);
2788          Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
2789          Set_Msg_Name_Buffer;
2790       end if;
2791    end Set_Msg_Node;
2792
2793    -------------------
2794    -- Set_Msg_Quote --
2795    -------------------
2796
2797    procedure Set_Msg_Quote is
2798    begin
2799       if not Manual_Quote_Mode then
2800          Set_Msg_Char ('"');
2801       end if;
2802    end Set_Msg_Quote;
2803
2804    -----------------
2805    -- Set_Msg_Str --
2806    -----------------
2807
2808    procedure Set_Msg_Str (Text : String) is
2809    begin
2810       for J in Text'Range loop
2811          Set_Msg_Char (Text (J));
2812       end loop;
2813    end Set_Msg_Str;
2814
2815    ------------------
2816    -- Set_Msg_Text --
2817    ------------------
2818
2819    procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is
2820       C : Character;         -- Current character
2821       P : Natural;           -- Current index;
2822
2823    begin
2824       Manual_Quote_Mode := False;
2825       Is_Unconditional_Msg := False;
2826       Msglen := 0;
2827       Flag_Source := Get_Source_File_Index (Flag);
2828       P := Text'First;
2829
2830       while P <= Text'Last loop
2831          C := Text (P);
2832          P := P + 1;
2833
2834          --  Check for insertion character
2835
2836          if C = '%' then
2837             Set_Msg_Insertion_Name;
2838
2839          elsif C = '$' then
2840             Set_Msg_Insertion_Unit_Name;
2841
2842          elsif C = '{' then
2843             Set_Msg_Insertion_File_Name;
2844
2845          elsif C = '}' then
2846             Set_Msg_Insertion_Type_Reference (Flag);
2847
2848          elsif C = '*' then
2849             Set_Msg_Insertion_Reserved_Name;
2850
2851          elsif C = '&' then
2852             Set_Msg_Insertion_Node;
2853
2854          elsif C = '#' then
2855             Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);
2856
2857          elsif C = '\' then
2858             Continuation := True;
2859
2860          elsif C = '@' then
2861             Set_Msg_Insertion_Column;
2862
2863          elsif C = '^' then
2864             Set_Msg_Insertion_Uint;
2865
2866          elsif C = '`' then
2867             Manual_Quote_Mode := not Manual_Quote_Mode;
2868             Set_Msg_Char ('"');
2869
2870          elsif C = '!' then
2871             Is_Unconditional_Msg := True;
2872
2873          elsif C = '?' then
2874             null;
2875
2876          elsif C = '|' then
2877             null;
2878
2879          elsif C = ''' then
2880             Set_Msg_Char (Text (P));
2881             P := P + 1;
2882
2883          --  Upper case letter (start of reserved word if 2 or more)
2884
2885          elsif C in 'A' .. 'Z'
2886            and then P <= Text'Last
2887            and then Text (P) in 'A' .. 'Z'
2888          then
2889             P := P - 1;
2890             Set_Msg_Insertion_Reserved_Word (Text, P);
2891
2892          --  Normal character with no special treatment
2893
2894          else
2895             Set_Msg_Char (C);
2896          end if;
2897
2898       end loop;
2899    end Set_Msg_Text;
2900
2901    ------------------------------
2902    -- Set_Next_Non_Deleted_Msg --
2903    ------------------------------
2904
2905    procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
2906    begin
2907       if E = No_Error_Msg then
2908          return;
2909
2910       else
2911          loop
2912             E := Errors.Table (E).Next;
2913             exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
2914          end loop;
2915       end if;
2916    end Set_Next_Non_Deleted_Msg;
2917
2918    ----------------
2919    -- Set_Posted --
2920    ----------------
2921
2922    procedure Set_Posted (N : Node_Id) is
2923       P : Node_Id;
2924
2925    begin
2926       --  We always set Error_Posted on the node itself
2927
2928       Set_Error_Posted (N);
2929
2930       --  If it is a subexpression, then set Error_Posted on parents
2931       --  up to and including the first non-subexpression construct. This
2932       --  helps avoid cascaded error messages within a single expression.
2933
2934       P := N;
2935       loop
2936          P := Parent (P);
2937          exit when No (P);
2938          Set_Error_Posted (P);
2939          exit when Nkind (P) not in N_Subexpr;
2940       end loop;
2941
2942       --  A special check, if we just posted an error on an attribute
2943       --  definition clause, then also set the entity involved as posted.
2944       --  For example, this stops complaining about the alignment after
2945       --  complaining about the size, which is likely to be useless.
2946
2947       if Nkind (P) = N_Attribute_Definition_Clause then
2948          if Is_Entity_Name (Name (P)) then
2949             Set_Error_Posted (Entity (Name (P)));
2950          end if;
2951       end if;
2952    end Set_Posted;
2953
2954    -----------------------
2955    -- Set_Qualification --
2956    -----------------------
2957
2958    procedure Set_Qualification (N : Nat; E : Entity_Id) is
2959    begin
2960       if N /= 0 and then Scope (E) /= Standard_Standard then
2961          Set_Qualification (N - 1, Scope (E));
2962          Set_Msg_Node (Scope (E));
2963          Set_Msg_Char ('.');
2964       end if;
2965    end Set_Qualification;
2966
2967    ---------------------------
2968    -- Set_Warnings_Mode_Off --
2969    ---------------------------
2970
2971    procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is
2972    begin
2973       --  Don't bother with entries from instantiation copies, since we
2974       --  will already have a copy in the template, which is what matters
2975
2976       if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
2977          return;
2978       end if;
2979
2980       --  If last entry in table already covers us, this is a redundant
2981       --  pragma Warnings (Off) and can be ignored. This also handles the
2982       --  case where all warnings are suppressed by command line switch.
2983
2984       if Warnings.Last >= Warnings.First
2985         and then Warnings.Table (Warnings.Last).Start <= Loc
2986         and then Loc <= Warnings.Table (Warnings.Last).Stop
2987       then
2988          return;
2989
2990       --  Otherwise establish a new entry, extending from the location of
2991       --  the pragma to the end of the current source file. This ending
2992       --  point will be adjusted by a subsequent pragma Warnings (On).
2993
2994       else
2995          Warnings.Increment_Last;
2996          Warnings.Table (Warnings.Last).Start := Loc;
2997          Warnings.Table (Warnings.Last).Stop :=
2998            Source_Last (Current_Source_File);
2999       end if;
3000    end Set_Warnings_Mode_Off;
3001
3002    --------------------------
3003    -- Set_Warnings_Mode_On --
3004    --------------------------
3005
3006    procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
3007    begin
3008       --  Don't bother with entries from instantiation copies, since we
3009       --  will already have a copy in the template, which is what matters
3010
3011       if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
3012          return;
3013       end if;
3014
3015       --  Nothing to do unless command line switch to suppress all warnings
3016       --  is off, and the last entry in the warnings table covers this
3017       --  pragma Warnings (On), in which case adjust the end point.
3018
3019       if (Warnings.Last >= Warnings.First
3020            and then Warnings.Table (Warnings.Last).Start <= Loc
3021            and then Loc <= Warnings.Table (Warnings.Last).Stop)
3022         and then Warning_Mode /= Suppress
3023       then
3024          Warnings.Table (Warnings.Last).Stop := Loc;
3025       end if;
3026    end Set_Warnings_Mode_On;
3027
3028    ------------------------
3029    -- Special_Msg_Delete --
3030    ------------------------
3031
3032    function Special_Msg_Delete
3033      (Msg  : String;
3034       N    : Node_Or_Entity_Id;
3035       E    : Node_Or_Entity_Id)
3036       return Boolean
3037    is
3038    begin
3039       --  Never delete messages in -gnatdO mode
3040
3041       if Debug_Flag_OO then
3042          return False;
3043
3044       --  When an atomic object refers to a non-atomic type in the same
3045       --  scope, we implicitly make the type atomic. In the non-error
3046       --  case this is surely safe (and in fact prevents an error from
3047       --  occurring if the type is not atomic by default). But if the
3048       --  object cannot be made atomic, then we introduce an extra junk
3049       --  message by this manipulation, which we get rid of here.
3050
3051       --  We identify this case by the fact that it references a type for
3052       --  which Is_Atomic is set, but there is no Atomic pragma setting it.
3053
3054       elsif Msg = "atomic access to & cannot be guaranteed"
3055         and then Is_Type (E)
3056         and then Is_Atomic (E)
3057         and then No (Get_Rep_Pragma (E, Name_Atomic))
3058       then
3059          return True;
3060
3061       --  When a size is wrong for a frozen type there is no explicit
3062       --  size clause, and other errors have occurred, suppress the
3063       --  message, since it is likely that this size error is a cascaded
3064       --  result of other errors. The reason we eliminate unfrozen types
3065       --  is that messages issued before the freeze type are for sure OK.
3066
3067       elsif Msg = "size for& too small, minimum allowed is ^"
3068         and then Is_Frozen (E)
3069         and then Serious_Errors_Detected > 0
3070         and then Nkind (N) /= N_Component_Clause
3071         and then Nkind (Parent (N)) /= N_Component_Clause
3072         and then
3073           No (Get_Attribute_Definition_Clause (E, Attribute_Size))
3074         and then
3075           No (Get_Attribute_Definition_Clause (E, Attribute_Object_Size))
3076         and then
3077           No (Get_Attribute_Definition_Clause (E, Attribute_Value_Size))
3078       then
3079          return True;
3080
3081       --  All special tests complete, so go ahead with message
3082
3083       else
3084          return False;
3085       end if;
3086    end Special_Msg_Delete;
3087
3088    ------------------------------
3089    -- Test_Warning_Serious_Msg --
3090    ------------------------------
3091
3092    procedure Test_Warning_Msg (Msg : String) is
3093    begin
3094       Is_Serious_Error := True;
3095
3096       if Msg'Length > 7 and then Msg (1 .. 7) = "(style)" then
3097          Is_Warning_Msg := True;
3098       else
3099          Is_Warning_Msg := False;
3100       end if;
3101
3102       for J in Msg'Range loop
3103          if Msg (J) = '?'
3104            and then (J = Msg'First or else Msg (J - 1) /= ''')
3105          then
3106             Is_Warning_Msg := True;
3107
3108          elsif Msg (J) = '|'
3109            and then (J = Msg'First or else Msg (J - 1) /= ''')
3110          then
3111             Is_Serious_Error := False;
3112          end if;
3113       end loop;
3114
3115       if Is_Warning_Msg then
3116          Is_Serious_Error := False;
3117       end if;
3118    end Test_Warning_Msg;
3119
3120    --------------------------
3121    -- Unwind_Internal_Type --
3122    --------------------------
3123
3124    procedure Unwind_Internal_Type (Ent : in out Entity_Id) is
3125       Derived : Boolean := False;
3126       Mchar   : Character;
3127       Old_Ent : Entity_Id;
3128
3129    begin
3130       --  Undo placement of a quote, since we will put it back later
3131
3132       Mchar := Msg_Buffer (Msglen);
3133
3134       if Mchar = '"' then
3135          Msglen := Msglen - 1;
3136       end if;
3137
3138       --  The loop here deals with recursive types, we are trying to
3139       --  find a related entity that is not an implicit type. Note
3140       --  that the check with Old_Ent stops us from getting "stuck".
3141       --  Also, we don't output the "type derived from" message more
3142       --  than once in the case where we climb up multiple levels.
3143
3144       loop
3145          Old_Ent := Ent;
3146
3147          --  Implicit access type, use directly designated type
3148
3149          if Is_Access_Type (Ent) then
3150             Set_Msg_Str ("access to ");
3151             Ent := Directly_Designated_Type (Ent);
3152
3153          --  Classwide type
3154
3155          elsif Is_Class_Wide_Type (Ent) then
3156             Class_Flag := True;
3157             Ent := Root_Type (Ent);
3158
3159          --  Use base type if this is a subtype
3160
3161          elsif Ent /= Base_Type (Ent) then
3162             Buffer_Remove ("type ");
3163
3164             --  Avoid duplication "subtype of subtype of", and also replace
3165             --  "derived from subtype of" simply by "derived from"
3166
3167             if not Buffer_Ends_With ("subtype of ")
3168               and then not Buffer_Ends_With ("derived from ")
3169             then
3170                Set_Msg_Str ("subtype of ");
3171             end if;
3172
3173             Ent := Base_Type (Ent);
3174
3175          --  If this is a base type with a first named subtype, use the
3176          --  first named subtype instead. This is not quite accurate in
3177          --  all cases, but it makes too much noise to be accurate and
3178          --  add 'Base in all cases. Note that we only do this is the
3179          --  first named subtype is not itself an internal name. This
3180          --  avoids the obvious loop (subtype->basetype->subtype) which
3181          --  would otherwise occur!)
3182
3183          elsif Present (Freeze_Node (Ent))
3184            and then Present (First_Subtype_Link (Freeze_Node (Ent)))
3185            and then
3186              not Is_Internal_Name
3187                    (Chars (First_Subtype_Link (Freeze_Node (Ent))))
3188          then
3189             Ent := First_Subtype_Link (Freeze_Node (Ent));
3190
3191          --  Otherwise use root type
3192
3193          else
3194             if not Derived then
3195                Buffer_Remove ("type ");
3196
3197                --  Test for "subtype of type derived from" which seems
3198                --  excessive and is replaced by simply "type derived from"
3199
3200                Buffer_Remove ("subtype of");
3201
3202                --  Avoid duplication "type derived from type derived from"
3203
3204                if not Buffer_Ends_With ("type derived from ") then
3205                   Set_Msg_Str ("type derived from ");
3206                end if;
3207
3208                Derived := True;
3209             end if;
3210
3211             Ent := Etype (Ent);
3212          end if;
3213
3214          --  If we are stuck in a loop, get out and settle for the internal
3215          --  name after all. In this case we set to kill the message if it
3216          --  is not the first error message (we really try hard not to show
3217          --  the dirty laundry of the implementation to the poor user!)
3218
3219          if Ent = Old_Ent then
3220             Kill_Message := True;
3221             exit;
3222          end if;
3223
3224          --  Get out if we finally found a non-internal name to use
3225
3226          exit when not Is_Internal_Name (Chars (Ent));
3227       end loop;
3228
3229       if Mchar = '"' then
3230          Set_Msg_Char ('"');
3231       end if;
3232
3233    end Unwind_Internal_Type;
3234
3235    -------------------------
3236    -- Warnings_Suppressed --
3237    -------------------------
3238
3239    function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
3240    begin
3241       for J in Warnings.First .. Warnings.Last loop
3242          if Warnings.Table (J).Start <= Loc
3243            and then Loc <= Warnings.Table (J).Stop
3244          then
3245             return True;
3246          end if;
3247       end loop;
3248
3249       return False;
3250    end Warnings_Suppressed;
3251
3252 end Errout;