Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                               E R R O U T                                --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --

--                                                                          --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --

-- for  more details.  You should have  received  a copy of the GNU General --

-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --

-- http://www.gnu.org/licenses for a complete copy of the license.          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

--  Warning! Error messages can be generated during Gigi processing by direct

--  calls to error message routines, so it is essential that the processing

--  in this body be consistent with the requirements for the Gigi processing

--  environment, and that in particular, no disallowed table expansion is

--  allowed to occur.

with Atree;    use Atree;

with Casing;   use Casing;

with Csets;    use Csets;

with Debug;    use Debug;

with Einfo;    use Einfo;

with Erroutc;  use Erroutc;

with Fname;    use Fname;

with Gnatvsn;  use Gnatvsn;

with Hostparm; use Hostparm;

with Lib;      use Lib;

with Opt;      use Opt;

with Nlists;   use Nlists;

with Output;   use Output;

with Scans;    use Scans;

with Sem_Aux;  use Sem_Aux;

with Sinput;   use Sinput;

with Sinfo;    use Sinfo;

with Snames;   use Snames;

with Stand;    use Stand;

with Stylesw;  use Stylesw;

with Uname;    use Uname;

package body Errout is

   Errors_Must_Be_Ignored : Boolean := False;

   --  Set to True by procedure Set_Ignore_Errors (True), when calls to error

   --  message procedures should be ignored (when parsing irrelevant text in

   --  sources being preprocessed).

   Finalize_Called : Boolean := False;

   --  Set True if the Finalize routine has been called

   Warn_On_Instance : Boolean;

   --  Flag set true for warning message to be posted on instance

   ------------------------------------

   -- Table of Non-Instance Messages --

   ------------------------------------

   --  This table contains an entry for every error message processed by the

   --  Error_Msg routine that is not posted on generic (or inlined) instance.

   --  As explained in further detail in the Error_Msg procedure body, this

   --  table is used to avoid posting redundant messages on instances.

   type NIM_Record is record

      Msg : String_Ptr;

      Loc : Source_Ptr;

   end record;

   --  Type used to store text and location of one message

   package Non_Instance_Msgs is new Table.Table (

     Table_Component_Type => NIM_Record,

     Table_Index_Type     => Int,

     Table_Low_Bound      => 1,

     Table_Initial        => 100,

     Table_Increment      => 100,

     Table_Name           => "Non_Instance_Msgs");

   -----------------------

   -- Local Subprograms --

   -----------------------

   procedure Error_Msg_Internal

     (Msg      : String;

      Sptr     : Source_Ptr;

      Optr     : Source_Ptr;

      Msg_Cont : Boolean);

   --  This is the low level routine used to post messages after dealing with

   --  the issue of messages placed on instantiations (which get broken up

   --  into separate calls in Error_Msg). Sptr is the location on which the

   --  flag will be placed in the output. In the case where the flag is on

   --  the template, this points directly to the template, not to one of the

   --  instantiation copies of the template. Optr is the original location

   --  used to flag the error, and this may indeed point to an instantiation

   --  copy. So typically we can see Optr pointing to the template location

   --  in an instantiation copy when Sptr points to the source location of

   --  the actual instantiation (i.e the line with the new). Msg_Cont is

   --  set true if this is a continuation message.

   function No_Warnings (N : Node_Or_Entity_Id) return Boolean;

   --  Determines if warnings should be suppressed for the given node

   function OK_Node (N : Node_Id) return Boolean;

   --  Determines if a node is an OK node to place an error message on (return

   --  True) or if the error message should be suppressed (return False). A

   --  message is suppressed if the node already has an error posted on it,

   --  or if it refers to an Etype that has an error posted on it, or if

   --  it references an Entity that has an error posted on it.

   procedure Output_Source_Line

     (L     : Physical_Line_Number;

      Sfile : Source_File_Index;

      Errs  : Boolean);

   --  Outputs text of source line L, in file S, together with preceding line

   --  number, as described above for Output_Line_Number. The Errs parameter

   --  indicates if there are errors attached to the line, which forces

   --  listing on, even in the presence of pragma List (Off).

   procedure Set_Msg_Insertion_Column;

   --  Handle column number insertion (@ insertion character)

   procedure Set_Msg_Insertion_Node;

   --  Handle node (name from node) insertion (& insertion character)

   procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr);

   --  Handle type reference (right brace insertion character). Flag is the

   --  location of the flag, which is provided for the internal call to

   --  Set_Msg_Insertion_Line_Number,

   procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True);

   --  Handle unit name insertion ($ insertion character). Depending on Boolean

   --  parameter Suffix, (spec) or (body) is appended after the unit name.

   procedure Set_Msg_Node (Node : Node_Id);

   --  Add the sequence of characters for the name associated with the given

   --  node to the current message. For N_Designator, N_Selected_Component,

   --  N_Defining_Program_Unit_Name, and N_Expanded_Name, the Prefix is

   --  included as well.

   procedure Set_Msg_Text (Text : String; Flag : Source_Ptr);

   --  Add a sequence of characters to the current message. The characters may

   --  be one of the special insertion characters (see documentation in spec).

   --  Flag is the location at which the error is to be posted, which is used

   --  to determine whether or not the # insertion needs a file name. The

   --  variables Msg_Buffer, Msglen, Is_Style_Msg, Is_Warning_Msg, and

   --  Is_Unconditional_Msg are set on return.

   procedure Set_Posted (N : Node_Id);

   --  Sets the Error_Posted flag on the given node, and all its parents

   --  that are subexpressions and then on the parent non-subexpression

   --  construct that contains the original expression (this reduces the

   --  number of cascaded messages). Note that this call only has an effect

   --  for a serious error. For a non-serious error, it has no effect.

   procedure Set_Qualification (N : Nat; E : Entity_Id);

   --  Outputs up to N levels of qualification for the given entity. For

   --  example, the entity A.B.C.D will output B.C. if N = 2.

   function Special_Msg_Delete

     (Msg : String;

      N   : Node_Or_Entity_Id;

      E   : Node_Or_Entity_Id) return Boolean;

   --  This function is called from Error_Msg_NEL, passing the message Msg,

   --  node N on which the error is to be posted, and the entity or node E

   --  to be used for an & insertion in the message if any. The job of this

   --  procedure is to test for certain cascaded messages that we would like

   --  to suppress. If the message is to be suppressed then we return True.

   --  If the message should be generated (the normal case) False is returned.

   procedure Unwind_Internal_Type (Ent : in out Entity_Id);

   --  This procedure is given an entity id for an internal type, i.e. a type

   --  with an internal name. It unwinds the type to try to get to something

   --  reasonably printable, generating prefixes like "subtype of", "access

   --  to", etc along the way in the buffer. The value in Ent on return is the

   --  final name to be printed. Hopefully this is not an internal name, but in

   --  some internal name cases, it is an internal name, and has to be printed

   --  anyway (although in this case the message has been killed if possible).

   --  The global variable Class_Flag is set to True if the resulting entity

   --  should have 'Class appended to its name (see Add_Class procedure), and

   --  is otherwise unchanged.

   procedure VMS_Convert;

   --  This procedure has no effect if called when the host is not OpenVMS. If

   --  the host is indeed OpenVMS, then the error message stored in Msg_Buffer

   --  is scanned for appearances of switch names which need converting to

   --  corresponding VMS qualifier names. See Gnames/Vnames table in Errout

   --  spec for precise definition of the conversion that is performed by this

   --  routine in OpenVMS mode.

   -----------------------

   -- Change_Error_Text --

   -----------------------

   procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String) is

      Save_Next : Error_Msg_Id;

      Err_Id    : Error_Msg_Id := Error_Id;

   begin

      Set_Msg_Text (New_Msg, Errors.Table (Error_Id).Sptr);

      Errors.Table (Error_Id).Text := new String'(Msg_Buffer (1 .. Msglen));

      --  If in immediate error message mode, output modified error message now

      --  This is just a bit tricky, because we want to output just a single

      --  message, and the messages we modified is already linked in. We solve

      --  this by temporarily resetting its forward pointer to empty.

      if Debug_Flag_OO then

         Save_Next := Errors.Table (Error_Id).Next;

         Errors.Table (Error_Id).Next := No_Error_Msg;

         Write_Eol;

         Output_Source_Line

           (Errors.Table (Error_Id).Line, Errors.Table (Error_Id).Sfile, True);

         Output_Error_Msgs (Err_Id);

         Errors.Table (Error_Id).Next := Save_Next;

      end if;

   end Change_Error_Text;

   ------------------------

   -- Compilation_Errors --

   ------------------------

   function Compilation_Errors return Boolean is

   begin

      if not Finalize_Called then

         raise Program_Error;

      else

         return Erroutc.Compilation_Errors;

      end if;

   end Compilation_Errors;

   ---------------

   -- Error_Msg --

   ---------------

   --  Error_Msg posts a flag at the given location, except that if the

   --  Flag_Location points within a generic template and corresponds to an

   --  instantiation of this generic template, then the actual message will be

   --  posted on the generic instantiation, along with additional messages

   --  referencing the generic declaration.

   procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is

      Sindex : Source_File_Index;

      --  Source index for flag location

      Orig_Loc : Source_Ptr;

      --  Original location of Flag_Location (i.e. location in original

      --  template in instantiation case, otherwise unchanged).

   begin

      --  It is a fatal error to issue an error message when scanning from the

      --  internal source buffer (see Sinput for further documentation)

      pragma Assert (Sinput.Source /= Internal_Source_Ptr);

      --  Return if all errors are to be ignored

      if Errors_Must_Be_Ignored then

         return;

      end if;

      --  If we already have messages, and we are trying to place a message at

      --  No_Location or in package Standard, then just ignore the attempt

      --  since we assume that what is happening is some cascaded junk. Note

      --  that this is safe in the sense that proceeding will surely bomb.

      if Flag_Location < First_Source_Ptr

        and then Total_Errors_Detected > 0

      then

         return;

      end if;

      --  Start of processing for new message

      Sindex := Get_Source_File_Index (Flag_Location);

      Test_Style_Warning_Serious_Msg (Msg);

      Orig_Loc := Original_Location (Flag_Location);

      --  If the current location is in an instantiation, the issue arises of

      --  whether to post the message on the template or the instantiation.

      --  The way we decide is to see if we have posted the same message on

      --  the template when we compiled the template (the template is always

      --  compiled before any instantiations). For this purpose, we use a

      --  separate table of messages. The reason we do this is twofold:

      --     First, the messages can get changed by various processing

      --     including the insertion of tokens etc, making it hard to

      --     do the comparison.

      --     Second, we will suppress a warning on a template if it is not in

      --     the current extended source unit. That's reasonable and means we

      --     don't want the warning on the instantiation here either, but it

      --     does mean that the main error table would not in any case include

      --     the message.

      if Flag_Location = Orig_Loc then

         Non_Instance_Msgs.Append ((new String'(Msg), Flag_Location));

         Warn_On_Instance := False;

      --  Here we have an instance message

      else

         --  Delete if debug flag off, and this message duplicates a message

         --  already posted on the corresponding template

         if not Debug_Flag_GG then

            for J in Non_Instance_Msgs.First .. Non_Instance_Msgs.Last loop

               if Msg = Non_Instance_Msgs.Table (J).Msg.all

                 and then Non_Instance_Msgs.Table (J).Loc = Orig_Loc

               then

                  return;

               end if;

            end loop;

         end if;

         --  No duplicate, so error/warning will be posted on instance

         Warn_On_Instance := Is_Warning_Msg;

      end if;

      --  Ignore warning message that is suppressed for this location. Note

      --  that style checks are not considered warning messages for this

      --  purpose.

      if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then

         return;

      --  For style messages, check too many messages so far

      elsif Is_Style_Msg

        and then Maximum_Messages /= 0

        and then Warnings_Detected >= Maximum_Messages

      then

         return;

      end if;

      --  The idea at this stage is that we have two kinds of messages

      --  First, we have those messages that are to be placed as requested at

      --  Flag_Location. This includes messages that have nothing to do with

      --  generics, and also messages placed on generic templates that reflect

      --  an error in the template itself. For such messages we simply call

      --  Error_Msg_Internal to place the message in the requested location.

      if Instantiation (Sindex) = No_Location then

         Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False);

         return;

      end if;

      --  If we are trying to flag an error in an instantiation, we may have

      --  a generic contract violation. What we generate in this case is:

      --     instantiation error at ...

      --     original error message

      --  or

      --     warning: in instantiation at

      --     warning: original warning message

      --  All these messages are posted at the location of the top level

      --  instantiation. If there are nested instantiations, then the

      --  instantiation error message can be repeated, pointing to each

      --  of the relevant instantiations.

      --  Note: the instantiation mechanism is also shared for inlining of

      --  subprogram bodies when front end inlining is done. In this case the

      --  messages have the form:

      --     in inlined body at ...

      --     original error message

      --  or

      --     warning: in inlined body at

      --     warning: original warning message

      --  OK, here we have an instantiation error, and we need to generate the

      --  error on the instantiation, rather than on the template.

      declare

         Actual_Error_Loc : Source_Ptr;

         --  Location of outer level instantiation in instantiation case, or

         --  just a copy of Flag_Location in the normal case. This is the

         --  location where all error messages will actually be posted.

         Save_Error_Msg_Sloc : constant Source_Ptr := Error_Msg_Sloc;

         --  Save possible location set for caller's message. We need to use

         --  Error_Msg_Sloc for the location of the instantiation error but we

         --  have to preserve a possible original value.

         X : Source_File_Index;

         Msg_Cont_Status : Boolean;

         --  Used to label continuation lines in instantiation case with

         --  proper Msg_Cont status.

      begin

         --  Loop to find highest level instantiation, where all error

         --  messages will be placed.

         X := Sindex;

         loop

            Actual_Error_Loc := Instantiation (X);

            X := Get_Source_File_Index (Actual_Error_Loc);

            exit when Instantiation (X) = No_Location;

         end loop;

         --  Since we are generating the messages at the instantiation point in

         --  any case, we do not want the references to the bad lines in the

         --  instance to be annotated with the location of the instantiation.

         Suppress_Instance_Location := True;

         Msg_Cont_Status := False;

         --  Loop to generate instantiation messages

         Error_Msg_Sloc := Flag_Location;

         X := Get_Source_File_Index (Flag_Location);

         while Instantiation (X) /= No_Location loop

            --  Suppress instantiation message on continuation lines

            if Msg (Msg'First) /= '\' then

               --  Case of inlined body

               if Inlined_Body (X) then

                  if Is_Warning_Msg or else Is_Style_Msg then

                     Error_Msg_Internal

                       ("?in inlined body #",

                        Actual_Error_Loc, Flag_Location, Msg_Cont_Status);

                  else

                     Error_Msg_Internal

                       ("error in inlined body #",

                        Actual_Error_Loc, Flag_Location, Msg_Cont_Status);

                  end if;

               --  Case of generic instantiation

               else

                  if Is_Warning_Msg or else Is_Style_Msg then

                     Error_Msg_Internal

                       ("?in instantiation #",

                        Actual_Error_Loc, Flag_Location, Msg_Cont_Status);

                  else

                     Error_Msg_Internal

                       ("instantiation error #",

                        Actual_Error_Loc, Flag_Location, Msg_Cont_Status);

                  end if;

               end if;

            end if;

            Error_Msg_Sloc := Instantiation (X);

            X := Get_Source_File_Index (Error_Msg_Sloc);

            Msg_Cont_Status := True;

         end loop;

         Suppress_Instance_Location := False;

         Error_Msg_Sloc := Save_Error_Msg_Sloc;

         --  Here we output the original message on the outer instantiation

         Error_Msg_Internal

           (Msg, Actual_Error_Loc, Flag_Location, Msg_Cont_Status);

      end;

   end Error_Msg;

   ------------------

   -- Error_Msg_AP --

   ------------------

   procedure Error_Msg_AP (Msg : String) is

      S1 : Source_Ptr;

      C  : Character;

   begin

      --  If we had saved the Scan_Ptr value after scanning the previous

      --  token, then we would have exactly the right place for putting

      --  the flag immediately at hand. However, that would add at least

      --  two instructions to a Scan call *just* to service the possibility

      --  of an Error_Msg_AP call. So instead we reconstruct that value.

      --  We have two possibilities, start with Prev_Token_Ptr and skip over

      --  the current token, which is made harder by the possibility that this

      --  token may be in error, or start with Token_Ptr and work backwards.

      --  We used to take the second approach, but it's hard because of

      --  comments, and harder still because things that look like comments

      --  can appear inside strings. So now we take the first approach.

      --  Note: in the case where there is no previous token, Prev_Token_Ptr

      --  is set to Source_First, which is a reasonable position for the

      --  error flag in this situation.

      S1 := Prev_Token_Ptr;

      C := Source (S1);

      --  If the previous token is a string literal, we need a special approach

      --  since there may be white space inside the literal and we don't want

      --  to stop on that white space.

      --  Note: since this is an error recovery issue anyway, it is not worth

      --  worrying about special UTF_32 line terminator characters here.

      if Prev_Token = Tok_String_Literal then

         loop

            S1 := S1 + 1;

            if Source (S1) = C then

               S1 := S1 + 1;

               exit when Source (S1) /= C;

            elsif Source (S1) in Line_Terminator then

               exit;

            end if;

         end loop;

      --  Character literal also needs special handling

      elsif Prev_Token = Tok_Char_Literal then

         S1 := S1 + 3;

      --  Otherwise we search forward for the end of the current token, marked

      --  by a line terminator, white space, a comment symbol or if we bump

      --  into the following token (i.e. the current token).

      --  Again, it is not worth worrying about UTF_32 special line terminator

      --  characters in this context, since this is only for error recovery.

      else

         while Source (S1) not in Line_Terminator

           and then Source (S1) /= ' '

           and then Source (S1) /= ASCII.HT

           and then (Source (S1) /= '-' or else Source (S1 + 1) /= '-')

           and then S1 /= Token_Ptr

         loop

            S1 := S1 + 1;

         end loop;

      end if;

      --  S1 is now set to the location for the flag

      Error_Msg (Msg, S1);

   end Error_Msg_AP;

   ------------------

   -- Error_Msg_BC --

   ------------------

   procedure Error_Msg_BC (Msg : String) is

   begin

      --  If we are at end of file, post the flag after the previous token

      if Token = Tok_EOF then

         Error_Msg_AP (Msg);

      --  If we are at start of file, post the flag at the current token

      elsif Token_Ptr = Source_First (Current_Source_File) then

         Error_Msg_SC (Msg);

      --  If the character before the current token is a space or a horizontal

      --  tab, then we place the flag on this character (in the case of a tab

      --  we would really like to place it in the "last" character of the tab

      --  space, but that it too much trouble to worry about).

      elsif Source (Token_Ptr - 1) = ' '

         or else Source (Token_Ptr - 1) = ASCII.HT

      then

         Error_Msg (Msg, Token_Ptr - 1);

      --  If there is no space or tab before the current token, then there is

      --  no room to place the flag before the token, so we place it on the

      --  token instead (this happens for example at the start of a line).

      else

         Error_Msg (Msg, Token_Ptr);

      end if;

   end Error_Msg_BC;

   -------------------

   -- Error_Msg_CRT --

   -------------------

   procedure Error_Msg_CRT (Feature : String; N : Node_Id) is

      CNRT : constant String := " not allowed in no run time mode";

      CCRT : constant String := " not supported by configuration>";

      S : String (1 .. Feature'Length + 1 + CCRT'Length);

      L : Natural;

   begin

      S (1) := '|';

      S (2 .. Feature'Length + 1) := Feature;

      L := Feature'Length + 2;

      if No_Run_Time_Mode then

         S (L .. L + CNRT'Length - 1) := CNRT;

         L := L + CNRT'Length - 1;

      else pragma Assert (Configurable_Run_Time_Mode);

         S (L .. L + CCRT'Length - 1) := CCRT;

         L := L + CCRT'Length - 1;

      end if;

      Error_Msg_N (S (1 .. L), N);

      Configurable_Run_Time_Violations := Configurable_Run_Time_Violations + 1;

   end Error_Msg_CRT;

   ------------------

   -- Error_Msg_PT --

   ------------------

   procedure Error_Msg_PT (Typ : Node_Id; Subp : Node_Id) is

   begin

      --  Error message below needs rewording (remember comma in -gnatj

      --  mode) ???

      Error_Msg_NE

        ("first formal of & must be of mode `OUT`, `IN OUT` or " &

         "access-to-variable", Typ, Subp);

      Error_Msg_N

        ("\in order to be overridden by protected procedure or entry " &

         "(RM 9.4(11.9/2))", Typ);

   end Error_Msg_PT;

   -----------------

   -- Error_Msg_F --

   -----------------

   procedure Error_Msg_F (Msg : String; N : Node_Id) is

   begin

      Error_Msg_NEL (Msg, N, N, Sloc (First_Node (N)));

   end Error_Msg_F;

   ------------------

   -- Error_Msg_FE --

   ------------------

   procedure Error_Msg_FE

     (Msg : String;

      N   : Node_Id;

      E   : Node_Or_Entity_Id)

   is

   begin

      Error_Msg_NEL (Msg, N, E, Sloc (First_Node (N)));

   end Error_Msg_FE;

   ------------------------

   -- Error_Msg_Internal --

   ------------------------

   procedure Error_Msg_Internal

     (Msg      : String;

      Sptr     : Source_Ptr;

      Optr     : Source_Ptr;

      Msg_Cont : Boolean)

   is

      Next_Msg : Error_Msg_Id;

      --  Pointer to next message at insertion point

      Prev_Msg : Error_Msg_Id;

      --  Pointer to previous message at insertion point

      Temp_Msg : Error_Msg_Id;

      procedure Handle_Serious_Error;

      --  Internal procedure to do all error message handling for a serious

      --  error message, other than bumping the error counts and arranging

      --  for the message to be output.

      --------------------------

      -- Handle_Serious_Error --

      --------------------------

      procedure Handle_Serious_Error is

      begin

         --  Turn off code generation if not done already

         if Operating_Mode = Generate_Code then

            Operating_Mode := Check_Semantics;

            Expander_Active := False;

         end if;

         --  Set the fatal error flag in the unit table unless we are in

         --  Try_Semantics mode. This stops the semantics from being performed

         --  if we find a serious error. This is skipped if we are currently

         --  dealing with the configuration pragma file.

         if not Try_Semantics and then Current_Source_Unit /= No_Unit then

            Set_Fatal_Error (Get_Source_Unit (Sptr));

         end if;

      end Handle_Serious_Error;

   --  Start of processing for Error_Msg_Internal

   begin

      if Raise_Exception_On_Error /= 0 then

         raise Error_Msg_Exception;

      end if;

      Continuation := Msg_Cont;

      Continuation_New_Line := False;

      Suppress_Message := False;

      Kill_Message := False;

      Set_Msg_Text (Msg, Sptr);

      --  Kill continuation if parent message killed

      if Continuation and Last_Killed then

         return;

      end if;

      --  Return without doing anything if message is suppressed

      if Suppress_Message

        and then not All_Errors_Mode

        and then not Is_Warning_Msg

        and then Msg (Msg'Last) /= '!'

      then

         if not Continuation then

            Last_Killed := True;

         end if;

         return;

      end if;

      --  Return without doing anything if message is killed and this is not

      --  the first error message. The philosophy is that if we get a weird

      --  error message and we already have had a message, then we hope the

      --  weird message is a junk cascaded message

      if Kill_Message

        and then not All_Errors_Mode

        and then Total_Errors_Detected /= 0

      then

         if not Continuation then

            Last_Killed := True;

         end if;

         return;

      end if;

      --  Special check for warning message to see if it should be output

      if Is_Warning_Msg then

         --  Immediate return if warning message and warnings are suppressed

         if Warnings_Suppressed (Optr) or else Warnings_Suppressed (Sptr) then

            Cur_Msg := No_Error_Msg;

            return;

         end if;

         --  If the flag location is in the main extended source unit then for

         --  sure we want the warning since it definitely belongs

         if In_Extended_Main_Source_Unit (Sptr) then

            null;

         --  If the main unit has not been read yet. the warning must be on

         --  a configuration file: gnat.adc or user-defined. This means we

         --  are not parsing the main unit yet, so skip following checks.

         elsif No (Cunit (Main_Unit)) then

            null;

         --  If the flag location is not in the main extended source unit, then

         --  we want to eliminate the warning, unless it is in the extended

         --  main code unit and we want warnings on the instance.

         elsif In_Extended_Main_Code_Unit (Sptr) and then Warn_On_Instance then

            null;

         --  Keep warning if debug flag G set

         elsif Debug_Flag_GG then

            null;

         --  Keep warning if message text ends in !!

         elsif Msg (Msg'Last) = '!' and then Msg (Msg'Last - 1) = '!' then

            null;

         --  Here is where we delete a warning from a with'ed unit

         else

            Cur_Msg := No_Error_Msg;

            if not Continuation then

               Last_Killed := True;

            end if;