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