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