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