diff options
Diffstat (limited to 'gcc/ada/errout.adb')
| -rw-r--r-- | gcc/ada/errout.adb | 3083 |
1 files changed, 3083 insertions, 0 deletions
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb new file mode 100644 index 0000000..ad64a5f --- /dev/null +++ b/gcc/ada/errout.adb @@ -0,0 +1,3083 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E R R O U T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.208 $ +-- -- +-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- 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 Fname; use Fname; +with Hostparm; +with Lib; use Lib; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Scans; use Scans; +with Sinput; use Sinput; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Style; +with Uintp; use Uintp; +with Uname; use Uname; + +package body Errout is + + Class_Flag : Boolean := False; + -- This flag is set True when outputting a reference to a class-wide + -- type, and is used by Add_Class to insert 'Class at the proper point + + Continuation : Boolean; + -- Indicates if current message is a continuation. Intialized from the + -- Msg_Cont parameter in Error_Msg_Internal and then set True if a \ + -- insertion character is encountered. + + Cur_Msg : Error_Msg_Id; + -- Id of most recently posted error message + + Flag_Source : Source_File_Index; + -- Source file index for source file where error is being posted + + Is_Warning_Msg : Boolean; + -- Set by Set_Msg_Text to indicate if current message is warning message + + Is_Unconditional_Msg : Boolean; + -- Set by Set_Msg_Text to indicate if current message is unconditional + + Kill_Message : Boolean; + -- A flag used to kill weird messages (e.g. those containing uninterpreted + -- implicit type references) if we have already seen at least one message + -- already. The idea is that we hope the weird message is a junk cascaded + -- message that should be suppressed. + + Last_Killed : Boolean := False; + -- Set True if the most recently posted non-continuation message was + -- killed. This is used to determine the processing of any continuation + -- messages that follow. + + List_Pragmas_Index : Int; + -- Index into List_Pragmas table + + List_Pragmas_Mode : Boolean; + -- Starts True, gets set False by pragma List (Off), True by List (On) + + Manual_Quote_Mode : Boolean; + -- Set True in manual quotation mode + + Max_Msg_Length : constant := 80 + 2 * Hostparm.Max_Line_Length; + -- Maximum length of error message. The addition of Max_Line_Length + -- ensures that two insertion tokens of maximum length can be accomodated. + + Msg_Buffer : String (1 .. Max_Msg_Length); + -- Buffer used to prepare error messages + + Msglen : Integer; + -- Number of characters currently stored in the message buffer + + Suppress_Message : Boolean; + -- A flag used to suppress certain obviously redundant messages (i.e. + -- those referring to a node whose type is Any_Type). This suppression + -- is effective only if All_Errors_Mode is off. + + Suppress_Instance_Location : Boolean := False; + -- Normally, if a # location in a message references a location within + -- a generic template, then a note is added giving the location of the + -- instantiation. If this variable is set True, then this note is not + -- output. This is used for internal processing for the case of an + -- illegal instantiation. See Error_Msg routine for further details. + + ----------------------------------- + -- Error Message Data Structures -- + ----------------------------------- + + -- The error messages are stored as a linked list of error message objects + -- sorted into ascending order by the source location (Sloc). Each object + -- records the text of the message and its source location. + + -- The following record type and table are used to represent error + -- messages, with one entry in the table being allocated for each message. + + type Error_Msg_Object is record + Text : String_Ptr; + -- Text of error message, fully expanded with all insertions + + Next : Error_Msg_Id; + -- Pointer to next message in error chain + + Sfile : Source_File_Index; + -- Source table index of source file. In the case of an error that + -- refers to a template, always references the original template + -- not an instantiation copy. + + Sptr : Source_Ptr; + -- Flag pointer. In the case of an error that refers to a template, + -- always references the original template, not an instantiation copy. + -- This value is the actual place in the source that the error message + -- will be posted. + + Fptr : Source_Ptr; + -- Flag location used in the call to post the error. This is normally + -- the same as Sptr, except in the case of instantiations, where it + -- is the original flag location value. This may refer to an instance + -- when the actual message (and hence Sptr) references the template. + + Line : Physical_Line_Number; + -- Line number for error message + + Col : Column_Number; + -- Column number for error message + + Warn : Boolean; + -- True if warning message (i.e. insertion character ? appeared) + + Uncond : Boolean; + -- True if unconditional message (i.e. insertion character ! appeared) + + Msg_Cont : Boolean; + -- This is used for logical messages that are composed of multiple + -- individual messages. For messages that are not part of such a + -- group, or that are the first message in such a group. Msg_Cont + -- is set to False. For subsequent messages in a group, Msg_Cont + -- is set to True. This is used to make sure that such a group of + -- messages is either suppressed or retained as a group (e.g. in + -- the circuit that deletes identical messages). + + Deleted : Boolean; + -- If this flag is set, the message is not printed. This is used + -- in the circuit for deleting duplicate/redundant error messages. + end record; + + package Errors is new Table.Table ( + Table_Component_Type => Error_Msg_Object, + Table_Index_Type => Error_Msg_Id, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 200, + Table_Name => "Error"); + + Error_Msgs : Error_Msg_Id; + -- The list of error messages + + -------------------------- + -- Warning Mode Control -- + -------------------------- + + -- Pragma Warnings allows warnings to be turned off for a specified + -- region of code, and the following tabl is the data structure used + -- to keep track of these regions. + + -- It contains pairs of source locations, the first being the start + -- location for a warnings off region, and the second being the end + -- location. When a pragma Warnings (Off) is encountered, a new entry + -- is established extending from the location of the pragma to the + -- end of the current source file. A subsequent pragma Warnings (On) + -- adjusts the end point of this entry appropriately. + + -- If all warnings are suppressed by comamnd switch, then there is a + -- dummy entry (put there by Errout.Initialize) at the start of the + -- table which covers all possible Source_Ptr values. Note that the + -- source pointer values in this table always reference the original + -- template, not an instantiation copy, in the generic case. + + type Warnings_Entry is record + Start : Source_Ptr; + Stop : Source_Ptr; + end record; + + package Warnings is new Table.Table ( + Table_Component_Type => Warnings_Entry, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "Warnings"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Add_Class; + -- Add 'Class to buffer for class wide type case (Class_Flag set) + + function Buffer_Ends_With (S : String) return Boolean; + -- Tests if message buffer ends with given string preceded by a space + + procedure Buffer_Remove (S : String); + -- Removes given string from end of buffer if it is present + -- at end of buffer, and preceded by a space. + + procedure Debug_Output (N : Node_Id); + -- Called from Error_Msg_N and Error_Msg_NE to generate line of debug + -- output giving node number (of node N) if the debug X switch is set. + + procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id); + -- This function is passed the Id values of two error messages. If + -- either M1 or M2 is a continuation message, or is already deleted, + -- the call is ignored. Otherwise a check is made to see if M1 and M2 + -- are duplicated or redundant. If so, the message to be deleted and + -- all its continuations are marked with the Deleted flag set to True. + + procedure Error_Msg_Internal + (Msg : String; + Flag_Location : Source_Ptr; + Msg_Cont : Boolean); + -- This is like Error_Msg, except that Flag_Location is known not to be + -- a location within a instantiation of a generic template. The outer + -- level routine, Error_Msg, takes care of dealing with the generic case. + -- Msg_Cont is set True to indicate that the message is a continuation of + -- a previous message. This means that it must have the same Flag_Location + -- as the previous message. + + procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id); + -- Given a message id, move to next message id, but skip any deleted + -- messages, so that this results in E on output being the first non- + -- deleted message following the input value of E, or No_Error_Msg if + -- the input value of E was either already No_Error_Msg, or was the + -- last non-deleted 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_Error_Msgs (E : in out Error_Msg_Id); + -- Output source line, error flag, and text of stored error message and + -- all subsequent messages for the same line and unit. On return E is + -- set to be one higher than the last message output. + + procedure Output_Line_Number (L : Logical_Line_Number); + -- Output a line number as six digits (with leading zeroes suppressed), + -- followed by a period and a blank (note that this is 8 characters which + -- means that tabs in the source line will not get messed up). Line numbers + -- that match or are less than the last Source_Reference pragma are listed + -- as all blanks, avoiding output of junk line numbers. + + procedure Output_Msg_Text (E : Error_Msg_Id); + -- Outputs characters of text in the text of the error message E, excluding + -- any final exclamation point. Note that no end of line is output, the + -- caller is responsible for adding the end of line. + + 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). + + function Same_Error (M1, M2 : Error_Msg_Id) return Boolean; + -- See if two messages have the same text. Returns true if the text + -- of the two messages is identical, or if one of them is the same + -- as the other with an appended "instance at xxx" tag. + + procedure Set_Msg_Blank; + -- Sets a single blank in the message if the preceding character is a + -- non-blank character other than a left parenthesis. Has no effect if + -- manual quote mode is turned on. + + procedure Set_Msg_Blank_Conditional; + -- Sets a single blank in the message if the preceding character is a + -- non-blank character other than a left parenthesis or quote. Has no + -- effect if manual quote mode is turned on. + + procedure Set_Msg_Char (C : Character); + -- Add a single character to the current message. This routine does not + -- check for special insertion characters (they are just treated as text + -- characters if they occur). + + procedure Set_Msg_Insertion_Column; + -- Handle column number insertion (@ insertion character) + + procedure Set_Msg_Insertion_Name; + -- Handle name insertion (% insertion character) + + procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr); + -- Handle line number insertion (# insertion character). Loc is the + -- location to be referenced, and Flag is the location at which the + -- flag is posted (used to determine whether to add "in file xxx") + + procedure Set_Msg_Insertion_Node; + -- Handle node (name from node) insertion (& insertion character) + + procedure Set_Msg_Insertion_Reserved_Name; + -- Handle insertion of reserved word name (* insertion character). + + procedure Set_Msg_Insertion_Reserved_Word + (Text : String; + J : in out Integer); + -- Handle reserved word insertion (upper case letters). The Text argument + -- is the current error message input text, and J is an index which on + -- entry points to the first character of the reserved word, and on exit + -- points past the last character of the reserved word. + + 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_Uint; + -- Handle Uint insertion (^ insertion character) + + procedure Set_Msg_Insertion_Unit_Name; + -- Handle unit name insertion ($ insertion character) + + procedure Set_Msg_Insertion_File_Name; + -- Handle file name insertion (left brace insertion character) + + procedure Set_Msg_Int (Line : Int); + -- Set the decimal representation of the argument in the error message + -- buffer with no leading zeroes output. + + procedure Set_Msg_Name_Buffer; + -- Output name from Name_Buffer, with surrounding quotes unless manual + -- quotation mode is in effect. + + procedure Set_Msg_Node (Node : Node_Id); + -- Add the sequence of characters for the name associated with the + -- given node to the current message. + + procedure Set_Msg_Quote; + -- Set quote if in normal quote mode, nothing if in manual quote mode + + procedure Set_Msg_Str (Text : String); + -- Add a sequence of characters to the current message. This routine does + -- not check for special insertion characters (they are just treated as + -- text characters if they occur). + + 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_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) + + 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. + + procedure Test_Warning_Msg (Msg : String); + -- Sets Is_Warning_Msg true if Msg is a warning message (contains a + -- question mark character), and False otherwise. + + 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. + + function Warnings_Suppressed (Loc : Source_Ptr) return Boolean; + -- Determines if given location is covered by a warnings off suppression + -- range in the warnings table (or is suppressed by compilation option, + -- which generates a warning range for the whole source file). + + --------------- + -- Add_Class -- + --------------- + + procedure Add_Class is + begin + if Class_Flag then + Class_Flag := False; + Set_Msg_Char ('''); + Get_Name_String (Name_Class); + Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); + Set_Msg_Name_Buffer; + end if; + end Add_Class; + + ---------------------- + -- Buffer_Ends_With -- + ---------------------- + + function Buffer_Ends_With (S : String) return Boolean is + Len : constant Natural := S'Length; + + begin + return + Msglen > Len + and then Msg_Buffer (Msglen - Len) = ' ' + and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S; + end Buffer_Ends_With; + + ------------------- + -- Buffer_Remove -- + ------------------- + + procedure Buffer_Remove (S : String) is + begin + if Buffer_Ends_With (S) then + Msglen := Msglen - S'Length; + end if; + end Buffer_Remove; + + ----------------------- + -- 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; + + ----------------------------- + -- Check_Duplicate_Message -- + ----------------------------- + + procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is + L1, L2 : Error_Msg_Id; + N1, N2 : Error_Msg_Id; + + procedure Delete_Msg (Delete, Keep : Error_Msg_Id); + -- Called to delete message Delete, keeping message Keep. Marks + -- all messages of Delete with deleted flag set to True, and also + -- makes sure that for the error messages that are retained the + -- preferred message is the one retained (we prefer the shorter + -- one in the case where one has an Instance tag). Note that we + -- always know that Keep has at least as many continuations as + -- Delete (since we always delete the shorter sequence). + + procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is + D, K : Error_Msg_Id; + + begin + D := Delete; + K := Keep; + + loop + Errors.Table (D).Deleted := True; + + -- Adjust error message count + + if Errors.Table (D).Warn then + Warnings_Detected := Warnings_Detected - 1; + else + Errors_Detected := Errors_Detected - 1; + end if; + + -- Substitute shorter of the two error messages + + if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then + Errors.Table (K).Text := Errors.Table (D).Text; + end if; + + D := Errors.Table (D).Next; + K := Errors.Table (K).Next; + + if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then + return; + end if; + end loop; + end Delete_Msg; + + -- Start of processing for Check_Duplicate_Message + + begin + -- Both messages must be non-continuation messages and not deleted + + if Errors.Table (M1).Msg_Cont + or else Errors.Table (M2).Msg_Cont + or else Errors.Table (M1).Deleted + or else Errors.Table (M2).Deleted + then + return; + end if; + + -- Definitely not equal if message text does not match + + if not Same_Error (M1, M2) then + return; + end if; + + -- Same text. See if all continuations are also identical + + L1 := M1; + L2 := M2; + + loop + N1 := Errors.Table (L1).Next; + N2 := Errors.Table (L2).Next; + + -- If M1 continuations have run out, we delete M1, either the + -- messages have the same number of continuations, or M2 has + -- more and we prefer the one with more anyway. + + if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then + Delete_Msg (M1, M2); + return; + + -- If M2 continuatins have run out, we delete M2 + + elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then + Delete_Msg (M2, M1); + return; + + -- Otherwise see if continuations are the same, if not, keep both + -- sequences, a curious case, but better to keep everything! + + elsif not Same_Error (N1, N2) then + return; + + -- If continuations are the same, continue scan + + else + L1 := N1; + L2 := N2; + end if; + end loop; + end Check_Duplicate_Message; + + ------------------------ + -- Compilation_Errors -- + ------------------------ + + function Compilation_Errors return Boolean is + begin + return Errors_Detected /= 0 + or else (Warnings_Detected /= 0 + and then Warning_Mode = Treat_As_Error); + end Compilation_Errors; + + ------------------ + -- Debug_Output -- + ------------------ + + procedure Debug_Output (N : Node_Id) is + begin + if Debug_Flag_1 then + Write_Str ("*** following error message posted on node id = #"); + Write_Int (Int (N)); + Write_Str (" ***"); + Write_Eol; + end if; + end Debug_Output; + + ---------- + -- dmsg -- + ---------- + + procedure dmsg (Id : Error_Msg_Id) is + E : Error_Msg_Object renames Errors.Table (Id); + + begin + w ("Dumping error message, Id = ", Int (Id)); + w (" Text = ", E.Text.all); + w (" Next = ", Int (E.Next)); + w (" Sfile = ", Int (E.Sfile)); + + Write_Str + (" Sptr = "); + Write_Location (E.Sptr); + Write_Eol; + + Write_Str + (" Fptr = "); + Write_Location (E.Fptr); + Write_Eol; + + w (" Line = ", Int (E.Line)); + w (" Col = ", Int (E.Col)); + w (" Warn = ", E.Warn); + w (" Uncond = ", E.Uncond); + w (" Msg_Cont = ", E.Msg_Cont); + w (" Deleted = ", E.Deleted); + + Write_Eol; + end dmsg; + + --------------- + -- 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 : constant Source_File_Index := + Get_Source_File_Index (Flag_Location); + + Orig_Loc : Source_Ptr; + -- Original location of Flag_Location (i.e. location in original + -- template in instantiation case, otherwise unchanged). + + begin + Test_Warning_Msg (Msg); + + -- It is a fatal error to issue an error message when scanning from + -- the internal source buffer (see Sinput for further documentation) + + pragma Assert (Source /= Internal_Source_Ptr); + + -- Ignore warning message that is suppressed + + Orig_Loc := Original_Location (Flag_Location); + + if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then + return; + end if; + + -- The idea at this stage is that we have two kinds of messages. + + -- First, we have those 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, 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. + + -- However, before we do this, we need to worry about the case where + -- indeed we are in an instantiation, but the message is a warning + -- message. In this case, it almost certainly a warning for the + -- template itself and so it is posted on the template. At least + -- this is the default mode, it can be cancelled (resulting the + -- warning being placed on the instance as in the error case) by + -- setting the global Warn_On_Instance True. + + if (not Warn_On_Instance) and then Is_Warning_Msg then + Error_Msg_Internal (Msg, Flag_Location, False); + return; + end if; + + -- Second, we need to worry about the case where there was a real error + -- in the template, and we are getting a repeat of this error in the + -- instantiation. We don't want to complain about the instantiation + -- in this case, since we have already flagged the template. + + -- To deal with this case, just see if we have posted a message at + -- the template location already. If so, assume that the current + -- message is redundant. There could be cases in which this is not + -- a correct assumption, but it is not terrible to lose a message + -- about an incorrect instantiation given that we have already + -- flagged a message on the template. + + for Err in Errors.First .. Errors.Last loop + if Errors.Table (Err).Sptr = Orig_Loc then + + -- If the current message is a real error, as opposed to a + -- warning, then we don't want to let a warning on the + -- template inhibit a real error on the instantiation. + + if Is_Warning_Msg + or else not Errors.Table (Err).Warn + then + return; + end if; + end if; + end loop; + + -- OK, this is the case where we have an instantiation error, and + -- we need to generate the error on the instantiation, rather than + -- on the template. First, see if we have posted this exact error + -- before, and if so suppress it. It is not so easy to use the main + -- list of errors for this, since they have already been split up + -- according to the processing below. Consequently we use an auxiliary + -- data structure that just records these types of messages (it will + -- never have very many entries). + + 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 (1) /= '\' then + if Is_Warning_Msg then + Error_Msg_Internal + ("?in instantiation #", + Actual_Error_Loc, Msg_Cont_Status); + + else + Error_Msg_Internal + ("instantiation error #", + Actual_Error_Loc, Msg_Cont_Status); + 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, 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. + + 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) + + 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_Internal -- + ------------------------ + + procedure Error_Msg_Internal + (Msg : String; + Flag_Location : 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; + + Orig_Loc : constant Source_Ptr := Original_Location (Flag_Location); + + procedure Handle_Fatal_Error; + -- Internal procedure to do all error message handling other than + -- bumping the error count and arranging for the message to be output. + + procedure Handle_Fatal_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 parser 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 (Orig_Loc)); + end if; + end Handle_Fatal_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; + Suppress_Message := False; + Kill_Message := False; + Set_Msg_Text (Msg, Orig_Loc); + + -- 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 not All_Errors_Mode + and not (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 Errors_Detected /= 0 + then + if not Continuation then + Last_Killed := True; + end if; + + return; + end if; + + -- Immediate return if warning message and warnings are suppressed + + if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then + Cur_Msg := No_Error_Msg; + return; + end if; + + -- If message is to be ignored in special ignore message mode, this is + -- where we do this special processing, bypassing message output. + + if Ignore_Errors_Enable > 0 then + Handle_Fatal_Error; + return; + end if; + + -- Otherwise build error message object for new message + + Errors.Increment_Last; + Cur_Msg := Errors.Last; + Errors.Table (Cur_Msg).Text := new String'(Msg_Buffer (1 .. Msglen)); + Errors.Table (Cur_Msg).Next := No_Error_Msg; + Errors.Table (Cur_Msg).Sptr := Orig_Loc; + Errors.Table (Cur_Msg).Fptr := Flag_Location; + Errors.Table (Cur_Msg).Sfile := Get_Source_File_Index (Orig_Loc); + Errors.Table (Cur_Msg).Line := Get_Physical_Line_Number (Orig_Loc); + Errors.Table (Cur_Msg).Col := Get_Column_Number (Orig_Loc); + Errors.Table (Cur_Msg).Warn := Is_Warning_Msg; + Errors.Table (Cur_Msg).Uncond := Is_Unconditional_Msg; + Errors.Table (Cur_Msg).Msg_Cont := Continuation; + Errors.Table (Cur_Msg).Deleted := False; + + -- If immediate errors mode set, output error message now. Also output + -- now if the -d1 debug flag is set (so node number message comes out + -- just before actual error message) + + if Debug_Flag_OO or else Debug_Flag_1 then + Write_Eol; + Output_Source_Line (Errors.Table (Cur_Msg).Line, + Errors.Table (Cur_Msg).Sfile, True); + Temp_Msg := Cur_Msg; + Output_Error_Msgs (Temp_Msg); + + -- If not in immediate errors mode, then we insert the message in the + -- error chain for later output by Finalize. The messages are sorted + -- first by unit (main unit comes first), and within a unit by source + -- location (earlier flag location first in the chain). + + else + Prev_Msg := No_Error_Msg; + Next_Msg := Error_Msgs; + + while Next_Msg /= No_Error_Msg loop + exit when + Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile; + + if Errors.Table (Cur_Msg).Sfile = + Errors.Table (Next_Msg).Sfile + then + exit when Orig_Loc < Errors.Table (Next_Msg).Sptr; + end if; + + Prev_Msg := Next_Msg; + Next_Msg := Errors.Table (Next_Msg).Next; + end loop; + + -- Now we insert the new message in the error chain. The insertion + -- point for the message is after Prev_Msg and before Next_Msg. + + -- The possible insertion point for the new message is after Prev_Msg + -- and before Next_Msg. However, this is where we do a special check + -- for redundant parsing messages, defined as messages posted on the + -- same line. The idea here is that probably such messages are junk + -- from the parser recovering. In full errors mode, we don't do this + -- deletion, but otherwise such messages are discarded at this stage. + + if Prev_Msg /= No_Error_Msg + and then Errors.Table (Prev_Msg).Line = + Errors.Table (Cur_Msg).Line + and then Errors.Table (Prev_Msg).Sfile = + Errors.Table (Cur_Msg).Sfile + and then Compiler_State = Parsing + and then not All_Errors_Mode + then + -- Don't delete unconditional messages and at this stage, + -- don't delete continuation lines (we attempted to delete + -- those earlier if the parent message was deleted. + + if not Errors.Table (Cur_Msg).Uncond + and then not Continuation + then + + -- Don't delete if prev msg is warning and new msg is + -- an error. This is because we don't want a real error + -- masked by a warning. In all other cases (that is parse + -- errors for the same line that are not unconditional) + -- we do delete the message. This helps to avoid + -- junk extra messages from cascaded parsing errors + + if not Errors.Table (Prev_Msg).Warn + or else Errors.Table (Cur_Msg).Warn + then + -- All tests passed, delete the message by simply + -- returning without any further processing. + + if not Continuation then + Last_Killed := True; + end if; + + return; + end if; + end if; + end if; + + -- Come here if message is to be inserted in the error chain + + if not Continuation then + Last_Killed := False; + end if; + + if Prev_Msg = No_Error_Msg then + Error_Msgs := Cur_Msg; + else + Errors.Table (Prev_Msg).Next := Cur_Msg; + end if; + + Errors.Table (Cur_Msg).Next := Next_Msg; + end if; + + -- Bump appropriate statistics count + + if Errors.Table (Cur_Msg).Warn then + Warnings_Detected := Warnings_Detected + 1; + else + Errors_Detected := Errors_Detected + 1; + Handle_Fatal_Error; + end if; + + -- Terminate if max errors reached + + if Errors_Detected + Warnings_Detected = Maximum_Errors then + raise Unrecoverable_Error; + end if; + + end Error_Msg_Internal; + + ----------------- + -- Error_Msg_N -- + ----------------- + + procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is + begin + if No_Warnings (N) then + Test_Warning_Msg (Msg); + + if Is_Warning_Msg then + return; + end if; + end if; + + if All_Errors_Mode + or else Msg (Msg'Last) = '!' + or else OK_Node (N) + or else (Msg (1) = '\' and not Last_Killed) + then + Debug_Output (N); + Error_Msg_Node_1 := N; + Error_Msg (Msg, Sloc (N)); + + else + Last_Killed := True; + end if; + + if not Is_Warning_Msg then + Set_Posted (N); + end if; + end Error_Msg_N; + + ------------------ + -- Error_Msg_NE -- + ------------------ + + procedure Error_Msg_NE + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id) + is + begin + if No_Warnings (N) or else No_Warnings (E) then + Test_Warning_Msg (Msg); + + if Is_Warning_Msg then + return; + end if; + end if; + + if All_Errors_Mode + or else Msg (Msg'Last) = '!' + or else OK_Node (N) + or else (Msg (1) = '\' and not Last_Killed) + then + Debug_Output (N); + Error_Msg_Node_1 := E; + Error_Msg (Msg, Sloc (N)); + + else + Last_Killed := True; + end if; + + if not Is_Warning_Msg then + Set_Posted (N); + end if; + end Error_Msg_NE; + + ----------------- + -- Error_Msg_S -- + ----------------- + + procedure Error_Msg_S (Msg : String) is + begin + Error_Msg (Msg, Scan_Ptr); + end Error_Msg_S; + + ------------------ + -- Error_Msg_SC -- + ------------------ + + procedure Error_Msg_SC (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); + + -- For all other cases the message is posted at the current token + -- pointer position + + else + Error_Msg (Msg, Token_Ptr); + end if; + end Error_Msg_SC; + + ------------------ + -- Error_Msg_SP -- + ------------------ + + procedure Error_Msg_SP (Msg : String) is + begin + -- 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 + + Error_Msg (Msg, Prev_Token_Ptr); + end Error_Msg_SP; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + Cur : Error_Msg_Id; + Nxt : Error_Msg_Id; + E, F : Error_Msg_Id; + Err_Flag : Boolean; + + begin + -- Reset current error source file if the main unit has a pragma + -- Source_Reference. This ensures outputting the proper name of + -- the source file in this situation. + + if Num_SRef_Pragmas (Main_Source_File) /= 0 then + Current_Error_Source_File := No_Source_File; + end if; + + -- Eliminate any duplicated error messages from the list. This is + -- done after the fact to avoid problems with Change_Error_Text. + + Cur := Error_Msgs; + while Cur /= No_Error_Msg loop + Nxt := Errors.Table (Cur).Next; + + F := Nxt; + while F /= No_Error_Msg + and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr + loop + Check_Duplicate_Message (Cur, F); + F := Errors.Table (F).Next; + end loop; + + Cur := Nxt; + end loop; + + -- Brief Error mode + + if Brief_Output or (not Full_List and not Verbose_Mode) then + E := Error_Msgs; + Set_Standard_Error; + + while E /= No_Error_Msg loop + if not Errors.Table (E).Deleted and then not Debug_Flag_KK then + Write_Name (Reference_Name (Errors.Table (E).Sfile)); + Write_Char (':'); + Write_Int (Int (Physical_To_Logical + (Errors.Table (E).Line, + Errors.Table (E).Sfile))); + Write_Char (':'); + + if Errors.Table (E).Col < 10 then + Write_Char ('0'); + end if; + + Write_Int (Int (Errors.Table (E).Col)); + Write_Str (": "); + Output_Msg_Text (E); + Write_Eol; + end if; + + E := Errors.Table (E).Next; + end loop; + + Set_Standard_Output; + end if; + + -- Full source listing case + + if Full_List then + List_Pragmas_Index := 1; + List_Pragmas_Mode := True; + E := Error_Msgs; + Write_Eol; + + -- First list initial main source file with its error messages + + for N in 1 .. Last_Source_Line (Main_Source_File) loop + Err_Flag := + E /= No_Error_Msg + and then Errors.Table (E).Line = N + and then Errors.Table (E).Sfile = Main_Source_File; + + Output_Source_Line (N, Main_Source_File, Err_Flag); + + if Err_Flag then + Output_Error_Msgs (E); + + if not Debug_Flag_2 then + Write_Eol; + end if; + end if; + + end loop; + + -- Then output errors, if any, for subsidiary units + + while E /= No_Error_Msg + and then Errors.Table (E).Sfile /= Main_Source_File + loop + Write_Eol; + Output_Source_Line + (Errors.Table (E).Line, Errors.Table (E).Sfile, True); + Output_Error_Msgs (E); + end loop; + end if; + + -- Verbose mode (error lines only with error flags) + + if Verbose_Mode and not Full_List then + E := Error_Msgs; + + -- Loop through error lines + + while E /= No_Error_Msg loop + Write_Eol; + Output_Source_Line + (Errors.Table (E).Line, Errors.Table (E).Sfile, True); + Output_Error_Msgs (E); + end loop; + end if; + + -- Output error summary if verbose or full list mode + + if Verbose_Mode or else Full_List then + + -- Extra blank line if error messages or source listing were output + + if Errors_Detected + Warnings_Detected > 0 or else Full_List then + Write_Eol; + end if; + + -- Message giving number of lines read and number of errors detected. + -- This normally goes to Standard_Output. The exception is when brief + -- mode is not set, verbose mode (or full list mode) is set, and + -- there are errors. In this case we send the message to standard + -- error to make sure that *something* appears on standard error in + -- an error situation. + + -- Formerly, only the "# errors" suffix was sent to stderr, whereas + -- "# lines:" appeared on stdout. This caused problems on VMS when + -- the stdout buffer was flushed, giving an extra line feed after + -- the prefix. + + if Errors_Detected + Warnings_Detected /= 0 + and then not Brief_Output + and then (Verbose_Mode or Full_List) + then + Set_Standard_Error; + end if; + + -- Message giving total number of lines + + Write_Str (" "); + Write_Int (Num_Source_Lines (Main_Source_File)); + + if Num_Source_Lines (Main_Source_File) = 1 then + Write_Str (" line: "); + else + Write_Str (" lines: "); + end if; + + if Errors_Detected = 0 then + Write_Str ("No errors"); + + elsif Errors_Detected = 1 then + Write_Str ("1 error"); + + else + Write_Int (Errors_Detected); + Write_Str (" errors"); + end if; + + if Warnings_Detected /= 0 then + Write_Str (", "); + Write_Int (Warnings_Detected); + Write_Str (" warning"); + + if Warnings_Detected /= 1 then + Write_Char ('s'); + end if; + + if Warning_Mode = Treat_As_Error then + Write_Str (" (treated as error"); + + if Warnings_Detected /= 1 then + Write_Char ('s'); + end if; + + Write_Char (')'); + end if; + end if; + + Write_Eol; + Set_Standard_Output; + end if; + + if Maximum_Errors /= 0 + and then Errors_Detected + Warnings_Detected = Maximum_Errors + then + Set_Standard_Error; + Write_Str ("fatal error: maximum errors reached"); + Write_Eol; + Set_Standard_Output; + end if; + + if Warning_Mode = Treat_As_Error then + Errors_Detected := Errors_Detected + Warnings_Detected; + Warnings_Detected := 0; + end if; + + end Finalize; + + ------------------ + -- Get_Location -- + ------------------ + + function Get_Location (E : Error_Msg_Id) return Source_Ptr is + begin + return Errors.Table (E).Sptr; + end Get_Location; + + ---------------- + -- Get_Msg_Id -- + ---------------- + + function Get_Msg_Id return Error_Msg_Id is + begin + return Cur_Msg; + end Get_Msg_Id; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Errors.Init; + Error_Msgs := No_Error_Msg; + Errors_Detected := 0; + Warnings_Detected := 0; + Cur_Msg := No_Error_Msg; + List_Pragmas.Init; + + -- Initialize warnings table, if all warnings are suppressed, supply + -- an initial dummy entry covering all possible source locations. + + Warnings.Init; + + if Warning_Mode = Suppress then + Warnings.Increment_Last; + Warnings.Table (Warnings.Last).Start := Source_Ptr'First; + Warnings.Table (Warnings.Last).Stop := Source_Ptr'Last; + end if; + + end Initialize; + + ----------------- + -- No_Warnings -- + ----------------- + + function No_Warnings (N : Node_Or_Entity_Id) return Boolean is + begin + if Error_Posted (N) then + return True; + + elsif Nkind (N) in N_Entity and then Warnings_Off (N) then + return True; + + elsif Is_Entity_Name (N) + and then Present (Entity (N)) + and then Warnings_Off (Entity (N)) + then + return True; + + else + return False; + end if; + end No_Warnings; + + ------------- + -- OK_Node -- + ------------- + + function OK_Node (N : Node_Id) return Boolean is + K : constant Node_Kind := Nkind (N); + + begin + if Error_Posted (N) then + return False; + + elsif K in N_Has_Etype + and then Present (Etype (N)) + and then Error_Posted (Etype (N)) + then + return False; + + elsif (K in N_Op + or else K = N_Attribute_Reference + or else K = N_Character_Literal + or else K = N_Expanded_Name + or else K = N_Identifier + or else K = N_Operator_Symbol) + and then Present (Entity (N)) + and then Error_Posted (Entity (N)) + then + return False; + else + return True; + end if; + end OK_Node; + + ----------------------- + -- Output_Error_Msgs -- + ----------------------- + + procedure Output_Error_Msgs (E : in out Error_Msg_Id) is + P : Source_Ptr; + T : Error_Msg_Id; + S : Error_Msg_Id; + + Flag_Num : Pos; + Mult_Flags : Boolean := False; + + begin + S := E; + + -- Skip deleted messages at start + + if Errors.Table (S).Deleted then + Set_Next_Non_Deleted_Msg (S); + end if; + + -- Figure out if we will place more than one error flag on this line + + T := S; + while T /= No_Error_Msg + and then Errors.Table (T).Line = Errors.Table (E).Line + and then Errors.Table (T).Sfile = Errors.Table (E).Sfile + loop + if Errors.Table (T).Sptr > Errors.Table (E).Sptr then + Mult_Flags := True; + end if; + + Set_Next_Non_Deleted_Msg (T); + end loop; + + -- Output the error flags. The circuit here makes sure that the tab + -- characters in the original line are properly accounted for. The + -- eight blanks at the start are to match the line number. + + if not Debug_Flag_2 then + Write_Str (" "); + P := Line_Start (Errors.Table (E).Sptr); + Flag_Num := 1; + + -- Loop through error messages for this line to place flags + + T := S; + while T /= No_Error_Msg + and then Errors.Table (T).Line = Errors.Table (E).Line + and then Errors.Table (T).Sfile = Errors.Table (E).Sfile + loop + -- Loop to output blanks till current flag position + + while P < Errors.Table (T).Sptr loop + if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then + Write_Char (ASCII.HT); + else + Write_Char (' '); + end if; + + P := P + 1; + end loop; + + -- Output flag (unless already output, this happens if more + -- than one error message occurs at the same flag position). + + if P = Errors.Table (T).Sptr then + if (Flag_Num = 1 and then not Mult_Flags) + or else Flag_Num > 9 + then + Write_Char ('|'); + else + Write_Char (Character'Val (Character'Pos ('0') + Flag_Num)); + end if; + + P := P + 1; + end if; + + Set_Next_Non_Deleted_Msg (T); + Flag_Num := Flag_Num + 1; + end loop; + + Write_Eol; + end if; + + -- Now output the error messages + + T := S; + while T /= No_Error_Msg + and then Errors.Table (T).Line = Errors.Table (E).Line + and then Errors.Table (T).Sfile = Errors.Table (E).Sfile + + loop + Write_Str (" >>> "); + Output_Msg_Text (T); + + if Debug_Flag_2 then + while Column < 74 loop + Write_Char (' '); + end loop; + + Write_Str (" <<<"); + end if; + + Write_Eol; + Set_Next_Non_Deleted_Msg (T); + end loop; + + E := T; + end Output_Error_Msgs; + + ------------------------ + -- Output_Line_Number -- + ------------------------ + + procedure Output_Line_Number (L : Logical_Line_Number) is + D : Int; -- next digit + C : Character; -- next character + Z : Boolean; -- flag for zero suppress + N, M : Int; -- temporaries + + begin + if L = No_Line_Number then + Write_Str (" "); + + else + Z := False; + N := Int (L); + + M := 100_000; + while M /= 0 loop + D := Int (N / M); + N := N rem M; + M := M / 10; + + if D = 0 then + if Z then + C := '0'; + else + C := ' '; + end if; + else + Z := True; + C := Character'Val (D + 48); + end if; + + Write_Char (C); + end loop; + + Write_Str (". "); + end if; + end Output_Line_Number; + + --------------------- + -- Output_Msg_Text -- + --------------------- + + procedure Output_Msg_Text (E : Error_Msg_Id) is + begin + if Errors.Table (E).Warn then + if Errors.Table (E).Text'Length > 7 + and then Errors.Table (E).Text (1 .. 7) /= "(style)" + then + Write_Str ("warning: "); + end if; + + elsif Opt.Unique_Error_Tag then + Write_Str ("error: "); + end if; + + Write_Str (Errors.Table (E).Text.all); + end Output_Msg_Text; + + ------------------------ + -- Output_Source_Line -- + ------------------------ + + procedure Output_Source_Line + (L : Physical_Line_Number; + Sfile : Source_File_Index; + Errs : Boolean) + is + S : Source_Ptr; + C : Character; + + Line_Number_Output : Boolean := False; + -- Set True once line number is output + + begin + if Sfile /= Current_Error_Source_File then + Write_Str ("==============Error messages for source file: "); + Write_Name (Full_File_Name (Sfile)); + Write_Eol; + + if Num_SRef_Pragmas (Sfile) > 0 then + Write_Str ("--------------Line numbers from file: "); + Write_Name (Full_Ref_Name (Sfile)); + + -- Write starting line, except do not write it if we had more + -- than one source reference pragma, since in this case there + -- is no very useful number to write. + + Write_Str (" (starting at line "); + Write_Int (Int (First_Mapped_Line (Sfile))); + Write_Char (')'); + Write_Eol; + end if; + + Current_Error_Source_File := Sfile; + end if; + + if Errs or List_Pragmas_Mode then + Output_Line_Number (Physical_To_Logical (L, Sfile)); + Line_Number_Output := True; + end if; + + S := Line_Start (L, Sfile); + + loop + C := Source_Text (Sfile) (S); + exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF; + + -- Deal with matching entry in List_Pragmas table + + if Full_List + and then List_Pragmas_Index <= List_Pragmas.Last + and then S = List_Pragmas.Table (List_Pragmas_Index).Ploc + then + case List_Pragmas.Table (List_Pragmas_Index).Ptyp is + when Page => + Write_Char (C); + + -- Ignore if on line with errors so that error flags + -- get properly listed with the error line . + + if not Errs then + Write_Char (ASCII.FF); + end if; + + when List_On => + List_Pragmas_Mode := True; + + if not Line_Number_Output then + Output_Line_Number (Physical_To_Logical (L, Sfile)); + Line_Number_Output := True; + end if; + + Write_Char (C); + + when List_Off => + Write_Char (C); + List_Pragmas_Mode := False; + end case; + + List_Pragmas_Index := List_Pragmas_Index + 1; + + -- Normal case (no matching entry in List_Pragmas table) + + else + if Errs or List_Pragmas_Mode then + Write_Char (C); + end if; + end if; + + S := S + 1; + end loop; + + if Line_Number_Output then + Write_Eol; + end if; + end Output_Source_Line; + + -------------------- + -- Purge_Messages -- + -------------------- + + procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is + E : Error_Msg_Id; + + function To_Be_Purged (E : Error_Msg_Id) return Boolean; + -- Returns True for a message that is to be purged. Also adjusts + -- error counts appropriately. + + function To_Be_Purged (E : Error_Msg_Id) return Boolean is + begin + if E /= No_Error_Msg + and then Errors.Table (E).Sptr > From + and then Errors.Table (E).Sptr < To + then + if Errors.Table (E).Warn then + Warnings_Detected := Warnings_Detected - 1; + else + Errors_Detected := Errors_Detected - 1; + end if; + + return True; + + else + return False; + end if; + end To_Be_Purged; + + -- Start of processing for Purge_Messages + + begin + while To_Be_Purged (Error_Msgs) loop + Error_Msgs := Errors.Table (Error_Msgs).Next; + end loop; + + E := Error_Msgs; + while E /= No_Error_Msg loop + while To_Be_Purged (Errors.Table (E).Next) loop + Errors.Table (E).Next := + Errors.Table (Errors.Table (E).Next).Next; + end loop; + + E := Errors.Table (E).Next; + end loop; + end Purge_Messages; + + ----------------------------- + -- Remove_Warning_Messages -- + ----------------------------- + + procedure Remove_Warning_Messages (N : Node_Id) is + + function Check_For_Warning (N : Node_Id) return Traverse_Result; + -- This function checks one node for a possible warning message. + + function Check_All_Warnings is new + Traverse_Func (Check_For_Warning); + -- This defines the traversal operation + + Discard : Traverse_Result; + + ----------------------- + -- Check_For_Warning -- + ----------------------- + + function Check_For_Warning (N : Node_Id) return Traverse_Result is + Loc : constant Source_Ptr := Sloc (N); + E : Error_Msg_Id; + + function To_Be_Removed (E : Error_Msg_Id) return Boolean; + -- Returns True for a message that is to be removed. Also adjusts + -- warning count appropriately. + + function To_Be_Removed (E : Error_Msg_Id) return Boolean is + begin + if E /= No_Error_Msg + and then Errors.Table (E).Fptr = Loc + and then Errors.Table (E).Warn + then + Warnings_Detected := Warnings_Detected - 1; + return True; + else + return False; + end if; + end To_Be_Removed; + + -- Start of processing for Check_For_Warnings + + begin + while To_Be_Removed (Error_Msgs) loop + Error_Msgs := Errors.Table (Error_Msgs).Next; + end loop; + + E := Error_Msgs; + while E /= No_Error_Msg loop + while To_Be_Removed (Errors.Table (E).Next) loop + Errors.Table (E).Next := + Errors.Table (Errors.Table (E).Next).Next; + end loop; + + E := Errors.Table (E).Next; + end loop; + + return OK; + end Check_For_Warning; + + -- Start of processing for Remove_Warning_Messages + + begin + if Warnings_Detected /= 0 then + Discard := Check_All_Warnings (N); + end if; + end Remove_Warning_Messages; + + ---------------- + -- Same_Error -- + ---------------- + + function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is + Msg1 : constant String_Ptr := Errors.Table (M1).Text; + Msg2 : constant String_Ptr := Errors.Table (M2).Text; + + Msg2_Len : constant Integer := Msg2'Length; + Msg1_Len : constant Integer := Msg1'Length; + + begin + return + Msg1.all = Msg2.all + or else + (Msg1_Len - 10 > Msg2_Len + and then + Msg2.all = Msg1.all (1 .. Msg2_Len) + and then + Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance") + or else + (Msg2_Len - 10 > Msg1_Len + and then + Msg1.all = Msg2.all (1 .. Msg1_Len) + and then + Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance"); + end Same_Error; + + ------------------- + -- Set_Msg_Blank -- + ------------------- + + procedure Set_Msg_Blank is + begin + if Msglen > 0 + and then Msg_Buffer (Msglen) /= ' ' + and then Msg_Buffer (Msglen) /= '(' + and then not Manual_Quote_Mode + then + Set_Msg_Char (' '); + end if; + end Set_Msg_Blank; + + ------------------------------- + -- Set_Msg_Blank_Conditional -- + ------------------------------- + + procedure Set_Msg_Blank_Conditional is + begin + if Msglen > 0 + and then Msg_Buffer (Msglen) /= ' ' + and then Msg_Buffer (Msglen) /= '(' + and then Msg_Buffer (Msglen) /= '"' + and then not Manual_Quote_Mode + then + Set_Msg_Char (' '); + end if; + end Set_Msg_Blank_Conditional; + + ------------------ + -- Set_Msg_Char -- + ------------------ + + procedure Set_Msg_Char (C : Character) is + begin + + -- The check for message buffer overflow is needed to deal with cases + -- where insertions get too long (in particular a child unit name can + -- be very long). + + if Msglen < Max_Msg_Length then + Msglen := Msglen + 1; + Msg_Buffer (Msglen) := C; + end if; + end Set_Msg_Char; + + ------------------------------ + -- Set_Msg_Insertion_Column -- + ------------------------------ + + procedure Set_Msg_Insertion_Column is + begin + if Style.RM_Column_Check then + Set_Msg_Str (" in column "); + Set_Msg_Int (Int (Error_Msg_Col) + 1); + end if; + end Set_Msg_Insertion_Column; + + --------------------------------- + -- Set_Msg_Insertion_File_Name -- + --------------------------------- + + procedure Set_Msg_Insertion_File_Name is + begin + if Error_Msg_Name_1 = No_Name then + null; + + elsif Error_Msg_Name_1 = Error_Name then + Set_Msg_Blank; + Set_Msg_Str ("<error>"); + + else + Set_Msg_Blank; + Get_Name_String (Error_Msg_Name_1); + Set_Msg_Quote; + Set_Msg_Name_Buffer; + Set_Msg_Quote; + end if; + + -- The following assignments ensure that the second and third percent + -- insertion characters will correspond to the Error_Msg_Name_2 and + -- Error_Msg_Name_3 as required. + + Error_Msg_Name_1 := Error_Msg_Name_2; + Error_Msg_Name_2 := Error_Msg_Name_3; + + end Set_Msg_Insertion_File_Name; + + ----------------------------------- + -- Set_Msg_Insertion_Line_Number -- + ----------------------------------- + + procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is + Sindex_Loc : Source_File_Index; + Sindex_Flag : Source_File_Index; + + begin + Set_Msg_Blank; + + if Loc = No_Location then + Set_Msg_Str ("at unknown location"); + + elsif Loc <= Standard_Location then + Set_Msg_Str ("in package Standard"); + + if Loc = Standard_ASCII_Location then + Set_Msg_Str (".ASCII"); + end if; + + else + -- Add "at file-name:" if reference is to other than the source + -- file in which the error message is placed. Note that we check + -- full file names, rather than just the source indexes, to + -- deal with generic instantiations from the current file. + + Sindex_Loc := Get_Source_File_Index (Loc); + Sindex_Flag := Get_Source_File_Index (Flag); + + if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then + Set_Msg_Str ("at "); + Get_Name_String + (Reference_Name (Get_Source_File_Index (Loc))); + Set_Msg_Name_Buffer; + Set_Msg_Char (':'); + + -- If in current file, add text "at line " + + else + Set_Msg_Str ("at line "); + end if; + + -- Output line number for reference + + Set_Msg_Int (Int (Get_Logical_Line_Number (Loc))); + + -- Deal with the instantiation case. We may have a reference to, + -- e.g. a type, that is declared within a generic template, and + -- what we are really referring to is the occurrence in an instance. + -- In this case, the line number of the instantiation is also of + -- interest, and we add a notation: + + -- , instance at xxx + + -- where xxx is a line number output using this same routine (and + -- the recursion can go further if the instantiation is itself in + -- a generic template). + + -- The flag location passed to us in this situation is indeed the + -- line number within the template, but as described in Sinput.L + -- (file sinput-l.ads, section "Handling Generic Instantiations") + -- we can retrieve the location of the instantiation itself from + -- this flag location value. + + -- Note: this processing is suppressed if Suppress_Instance_Location + -- is set True. This is used to prevent redundant annotations of the + -- location of the instantiation in the case where we are placing + -- the messages on the instantiation in any case. + + if Instantiation (Sindex_Loc) /= No_Location + and then not Suppress_Instance_Location + then + Set_Msg_Str (", instance "); + Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag); + end if; + end if; + end Set_Msg_Insertion_Line_Number; + + ---------------------------- + -- Set_Msg_Insertion_Name -- + ---------------------------- + + procedure Set_Msg_Insertion_Name is + begin + if Error_Msg_Name_1 = No_Name then + null; + + elsif Error_Msg_Name_1 = Error_Name then + Set_Msg_Blank; + Set_Msg_Str ("<error>"); + + else + Set_Msg_Blank_Conditional; + Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1); + + -- Remove %s or %b at end. These come from unit names. If the + -- caller wanted the (unit) or (body), then they would have used + -- the $ insertion character. Certainly no error message should + -- ever have %b or %s explicitly occurring. + + if Name_Len > 2 + and then Name_Buffer (Name_Len - 1) = '%' + and then (Name_Buffer (Name_Len) = 'b' + or else + Name_Buffer (Name_Len) = 's') + then + Name_Len := Name_Len - 2; + end if; + + -- Remove upper case letter at end, again, we should not be getting + -- such names, and what we hope is that the remainder makes sense. + + if Name_Len > 1 + and then Name_Buffer (Name_Len) in 'A' .. 'Z' + then + Name_Len := Name_Len - 1; + end if; + + -- If operator name or character literal name, just print it as is + -- Also print as is if it ends in a right paren (case of x'val(nnn)) + + if Name_Buffer (1) = '"' + or else Name_Buffer (1) = ''' + or else Name_Buffer (Name_Len) = ')' + then + Set_Msg_Name_Buffer; + + -- Else output with surrounding quotes in proper casing mode + + else + Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); + Set_Msg_Quote; + Set_Msg_Name_Buffer; + Set_Msg_Quote; + end if; + end if; + + -- The following assignments ensure that the second and third percent + -- insertion characters will correspond to the Error_Msg_Name_2 and + -- Error_Msg_Name_3 as required. + + Error_Msg_Name_1 := Error_Msg_Name_2; + Error_Msg_Name_2 := Error_Msg_Name_3; + + end Set_Msg_Insertion_Name; + + ---------------------------- + -- Set_Msg_Insertion_Node -- + ---------------------------- + + procedure Set_Msg_Insertion_Node is + begin + Suppress_Message := + Error_Msg_Node_1 = Error + or else Error_Msg_Node_1 = Any_Type; + + if Error_Msg_Node_1 = Empty then + Set_Msg_Blank_Conditional; + Set_Msg_Str ("<empty>"); + + elsif Error_Msg_Node_1 = Error then + Set_Msg_Blank; + Set_Msg_Str ("<error>"); + + elsif Error_Msg_Node_1 = Standard_Void_Type then + Set_Msg_Blank; + Set_Msg_Str ("procedure name"); + + else + Set_Msg_Blank_Conditional; + + -- Skip quotes for operator case + + if Nkind (Error_Msg_Node_1) in N_Op then + Set_Msg_Node (Error_Msg_Node_1); + + else + Set_Msg_Quote; + Set_Qualification (Error_Msg_Qual_Level, Error_Msg_Node_1); + Set_Msg_Node (Error_Msg_Node_1); + Set_Msg_Quote; + end if; + end if; + + -- The following assignment ensures that a second ampersand insertion + -- character will correspond to the Error_Msg_Node_2 parameter. + + Error_Msg_Node_1 := Error_Msg_Node_2; + + end Set_Msg_Insertion_Node; + + ------------------------------------- + -- Set_Msg_Insertion_Reserved_Name -- + ------------------------------------- + + procedure Set_Msg_Insertion_Reserved_Name is + begin + Set_Msg_Blank_Conditional; + Get_Name_String (Error_Msg_Name_1); + Set_Msg_Quote; + Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case); + Set_Msg_Name_Buffer; + Set_Msg_Quote; + end Set_Msg_Insertion_Reserved_Name; + + ------------------------------------- + -- Set_Msg_Insertion_Reserved_Word -- + ------------------------------------- + + procedure Set_Msg_Insertion_Reserved_Word + (Text : String; + J : in out Integer) + is + begin + Set_Msg_Blank_Conditional; + Name_Len := 0; + + while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Text (J); + J := J + 1; + end loop; + + Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case); + Set_Msg_Quote; + Set_Msg_Name_Buffer; + Set_Msg_Quote; + end Set_Msg_Insertion_Reserved_Word; + + -------------------------------------- + -- Set_Msg_Insertion_Type_Reference -- + -------------------------------------- + + procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr) is + Ent : Entity_Id; + + begin + Set_Msg_Blank; + + if Error_Msg_Node_1 = Standard_Void_Type then + Set_Msg_Str ("package or procedure name"); + return; + + elsif Error_Msg_Node_1 = Standard_Exception_Type then + Set_Msg_Str ("exception name"); + return; + + elsif Error_Msg_Node_1 = Any_Access + or else Error_Msg_Node_1 = Any_Array + or else Error_Msg_Node_1 = Any_Boolean + or else Error_Msg_Node_1 = Any_Character + or else Error_Msg_Node_1 = Any_Composite + or else Error_Msg_Node_1 = Any_Discrete + or else Error_Msg_Node_1 = Any_Fixed + or else Error_Msg_Node_1 = Any_Integer + or else Error_Msg_Node_1 = Any_Modular + or else Error_Msg_Node_1 = Any_Numeric + or else Error_Msg_Node_1 = Any_Real + or else Error_Msg_Node_1 = Any_Scalar + or else Error_Msg_Node_1 = Any_String + then + Get_Unqualified_Decoded_Name_String (Chars (Error_Msg_Node_1)); + Set_Msg_Name_Buffer; + return; + + elsif Error_Msg_Node_1 = Universal_Real then + Set_Msg_Str ("type universal real"); + return; + + elsif Error_Msg_Node_1 = Universal_Integer then + Set_Msg_Str ("type universal integer"); + return; + + elsif Error_Msg_Node_1 = Universal_Fixed then + Set_Msg_Str ("type universal fixed"); + return; + end if; + + -- Special case of anonymous array + + if Nkind (Error_Msg_Node_1) in N_Entity + and then Is_Array_Type (Error_Msg_Node_1) + and then Present (Related_Array_Object (Error_Msg_Node_1)) + then + Set_Msg_Str ("type of "); + Set_Msg_Node (Related_Array_Object (Error_Msg_Node_1)); + Set_Msg_Str (" declared"); + Set_Msg_Insertion_Line_Number + (Sloc (Related_Array_Object (Error_Msg_Node_1)), Flag); + return; + end if; + + -- If we fall through, it is not a special case, so first output + -- the name of the type, preceded by private for a private type + + if Is_Private_Type (Error_Msg_Node_1) then + Set_Msg_Str ("private type "); + else + Set_Msg_Str ("type "); + end if; + + Ent := Error_Msg_Node_1; + + if Is_Internal_Name (Chars (Ent)) then + Unwind_Internal_Type (Ent); + end if; + + -- Types in Standard are displayed as "Standard.name" + + if Sloc (Ent) <= Standard_Location then + Set_Msg_Quote; + Set_Msg_Str ("Standard."); + Set_Msg_Node (Ent); + Add_Class; + Set_Msg_Quote; + + -- Types in other language defined units are displayed as + -- "package-name.type-name" + + elsif + Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Ent))) + then + Get_Unqualified_Decoded_Name_String + (Unit_Name (Get_Source_Unit (Ent))); + Name_Len := Name_Len - 2; + Set_Msg_Quote; + Set_Casing (Mixed_Case); + Set_Msg_Name_Buffer; + Set_Msg_Char ('.'); + Set_Casing (Mixed_Case); + Set_Msg_Node (Ent); + Add_Class; + Set_Msg_Quote; + + -- All other types display as "type name" defined at line xxx + -- possibly qualified if qualification is requested. + + else + Set_Msg_Quote; + Set_Qualification (Error_Msg_Qual_Level, Ent); + Set_Msg_Node (Ent); + Add_Class; + Set_Msg_Quote; + end if; + + -- If the original type did not come from a predefined + -- file, add the location where the type was defined. + + if Sloc (Error_Msg_Node_1) > Standard_Location + and then + not Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Error_Msg_Node_1))) + then + Set_Msg_Str (" defined"); + Set_Msg_Insertion_Line_Number (Sloc (Error_Msg_Node_1), Flag); + + -- If it did come from a predefined file, deal with the case where + -- this was a file with a generic instantiation from elsewhere. + + else + if Sloc (Error_Msg_Node_1) > Standard_Location then + declare + Iloc : constant Source_Ptr := + Instantiation_Location (Sloc (Error_Msg_Node_1)); + + begin + if Iloc /= No_Location + and then not Suppress_Instance_Location + then + Set_Msg_Str (" from instance"); + Set_Msg_Insertion_Line_Number (Iloc, Flag); + end if; + end; + end if; + end if; + + end Set_Msg_Insertion_Type_Reference; + + ---------------------------- + -- Set_Msg_Insertion_Uint -- + ---------------------------- + + procedure Set_Msg_Insertion_Uint is + begin + Set_Msg_Blank; + UI_Image (Error_Msg_Uint_1); + + for J in 1 .. UI_Image_Length loop + Set_Msg_Char (UI_Image_Buffer (J)); + end loop; + + -- The following assignment ensures that a second carret insertion + -- character will correspond to the Error_Msg_Uint_2 parameter. + + Error_Msg_Uint_1 := Error_Msg_Uint_2; + end Set_Msg_Insertion_Uint; + + --------------------------------- + -- Set_Msg_Insertion_Unit_Name -- + --------------------------------- + + procedure Set_Msg_Insertion_Unit_Name is + begin + if Error_Msg_Unit_1 = No_Name then + null; + + elsif Error_Msg_Unit_1 = Error_Name then + Set_Msg_Blank; + Set_Msg_Str ("<error>"); + + else + Get_Unit_Name_String (Error_Msg_Unit_1); + Set_Msg_Blank; + Set_Msg_Quote; + Set_Msg_Name_Buffer; + Set_Msg_Quote; + end if; + + -- The following assignment ensures that a second percent insertion + -- character will correspond to the Error_Msg_Unit_2 parameter. + + Error_Msg_Unit_1 := Error_Msg_Unit_2; + + end Set_Msg_Insertion_Unit_Name; + + ----------------- + -- Set_Msg_Int -- + ----------------- + + procedure Set_Msg_Int (Line : Int) is + begin + if Line > 9 then + Set_Msg_Int (Line / 10); + end if; + + Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10))); + end Set_Msg_Int; + + ------------------------- + -- Set_Msg_Name_Buffer -- + ------------------------- + + procedure Set_Msg_Name_Buffer is + begin + for J in 1 .. Name_Len loop + Set_Msg_Char (Name_Buffer (J)); + end loop; + end Set_Msg_Name_Buffer; + + ------------------ + -- Set_Msg_Node -- + ------------------ + + procedure Set_Msg_Node (Node : Node_Id) is + Ent : Entity_Id; + Nam : Name_Id; + + begin + if Nkind (Node) = N_Designator then + Set_Msg_Node (Name (Node)); + Set_Msg_Char ('.'); + Set_Msg_Node (Identifier (Node)); + return; + + elsif Nkind (Node) = N_Defining_Program_Unit_Name then + Set_Msg_Node (Name (Node)); + Set_Msg_Char ('.'); + Set_Msg_Node (Defining_Identifier (Node)); + return; + + elsif Nkind (Node) = N_Selected_Component then + Set_Msg_Node (Prefix (Node)); + Set_Msg_Char ('.'); + Set_Msg_Node (Selector_Name (Node)); + return; + end if; + + -- The only remaining possibilities are identifiers, defining + -- identifiers, pragmas, and pragma argument associations, i.e. + -- nodes that have a Chars field. + + -- Internal names generally represent something gone wrong. An exception + -- is the case of internal type names, where we try to find a reasonable + -- external representation for the external name + + if Is_Internal_Name (Chars (Node)) + and then + ((Is_Entity_Name (Node) + and then Present (Entity (Node)) + and then Is_Type (Entity (Node))) + or else + (Nkind (Node) = N_Defining_Identifier and then Is_Type (Node))) + then + if Nkind (Node) = N_Identifier then + Ent := Entity (Node); + else + Ent := Node; + end if; + + Unwind_Internal_Type (Ent); + Nam := Chars (Ent); + + else + Nam := Chars (Node); + end if; + + -- At this stage, the name to output is in Nam + + Get_Unqualified_Decoded_Name_String (Nam); + + -- Remove trailing upper case letters from the name (useful for + -- dealing with some cases of internal names. + + while Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' loop + Name_Len := Name_Len - 1; + end loop; + + -- If we have any of the names from standard that start with the + -- characters "any " (e.g. Any_Type), then kill the message since + -- almost certainly it is a junk cascaded message. + + if Name_Len > 4 + and then Name_Buffer (1 .. 4) = "any " + then + Kill_Message := True; + end if; + + -- Now we have to set the proper case. If we have a source location + -- then do a check to see if the name in the source is the same name + -- as the name in the Names table, except for possible differences + -- in case, which is the case when we can copy from the source. + + declare + Src_Loc : constant Source_Ptr := Sloc (Error_Msg_Node_1); + Sbuffer : Source_Buffer_Ptr; + Ref_Ptr : Integer; + Src_Ptr : Source_Ptr; + + begin + Ref_Ptr := 1; + Src_Ptr := Src_Loc; + + -- Determine if the reference we are dealing with corresponds + -- to text at the point of the error reference. This will often + -- be the case for simple identifier references, and is the case + -- where we can copy the spelling from the source. + + if Src_Loc /= No_Location + and then Src_Loc > Standard_Location + then + Sbuffer := Source_Text (Get_Source_File_Index (Src_Loc)); + + while Ref_Ptr <= Name_Len loop + exit when + Fold_Lower (Sbuffer (Src_Ptr)) /= + Fold_Lower (Name_Buffer (Ref_Ptr)); + Ref_Ptr := Ref_Ptr + 1; + Src_Ptr := Src_Ptr + 1; + end loop; + end if; + + -- If we get through the loop without a mismatch, then output + -- the name the way it is spelled in the source program + + if Ref_Ptr > Name_Len then + Src_Ptr := Src_Loc; + + for J in 1 .. Name_Len loop + Name_Buffer (J) := Sbuffer (Src_Ptr); + Src_Ptr := Src_Ptr + 1; + end loop; + + -- Otherwise set the casing using the default identifier casing + + else + Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); + end if; + end; + + Set_Msg_Name_Buffer; + Add_Class; + + -- Add 'Class if class wide type + + if Class_Flag then + Set_Msg_Char ('''); + Get_Name_String (Name_Class); + Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); + Set_Msg_Name_Buffer; + end if; + end Set_Msg_Node; + + ------------------- + -- Set_Msg_Quote -- + ------------------- + + procedure Set_Msg_Quote is + begin + if not Manual_Quote_Mode then + Set_Msg_Char ('"'); + end if; + end Set_Msg_Quote; + + ----------------- + -- Set_Msg_Str -- + ----------------- + + procedure Set_Msg_Str (Text : String) is + begin + for J in Text'Range loop + Set_Msg_Char (Text (J)); + end loop; + end Set_Msg_Str; + + ------------------ + -- Set_Msg_Text -- + ------------------ + + procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is + C : Character; -- Current character + P : Natural; -- Current index; + + begin + Manual_Quote_Mode := False; + Is_Unconditional_Msg := False; + Msglen := 0; + Flag_Source := Get_Source_File_Index (Flag); + P := Text'First; + + while P <= Text'Last loop + C := Text (P); + P := P + 1; + + -- Check for insertion character + + if C = '%' then + Set_Msg_Insertion_Name; + + elsif C = '$' then + Set_Msg_Insertion_Unit_Name; + + elsif C = '{' then + Set_Msg_Insertion_File_Name; + + elsif C = '}' then + Set_Msg_Insertion_Type_Reference (Flag); + + elsif C = '*' then + Set_Msg_Insertion_Reserved_Name; + + elsif C = '&' then + Set_Msg_Insertion_Node; + + elsif C = '#' then + Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag); + + elsif C = '\' then + Continuation := True; + + elsif C = '@' then + Set_Msg_Insertion_Column; + + elsif C = '^' then + Set_Msg_Insertion_Uint; + + elsif C = '`' then + Manual_Quote_Mode := not Manual_Quote_Mode; + Set_Msg_Char ('"'); + + elsif C = '!' then + Is_Unconditional_Msg := True; + + elsif C = '?' then + null; + + elsif C = ''' then + Set_Msg_Char (Text (P)); + P := P + 1; + + -- Upper case letter (start of reserved word if 2 or more) + + elsif C in 'A' .. 'Z' + and then P <= Text'Last + and then Text (P) in 'A' .. 'Z' + then + P := P - 1; + Set_Msg_Insertion_Reserved_Word (Text, P); + + -- Normal character with no special treatment + + else + Set_Msg_Char (C); + end if; + + end loop; + end Set_Msg_Text; + + ------------------------------ + -- Set_Next_Non_Deleted_Msg -- + ------------------------------ + + procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is + begin + if E = No_Error_Msg then + return; + + else + loop + E := Errors.Table (E).Next; + exit when E = No_Error_Msg or else not Errors.Table (E).Deleted; + end loop; + end if; + end Set_Next_Non_Deleted_Msg; + + ---------------- + -- Set_Posted -- + ---------------- + + procedure Set_Posted (N : Node_Id) is + P : Node_Id; + + begin + -- We always set Error_Posted on the node itself + + Set_Error_Posted (N); + + -- If it is a subexpression, then set Error_Posted on parents + -- up to and including the first non-subexpression construct. This + -- helps avoid cascaded error messages within a single expression. + + P := N; + loop + P := Parent (P); + exit when No (P); + Set_Error_Posted (P); + exit when Nkind (P) not in N_Subexpr; + end loop; + end Set_Posted; + + ----------------------- + -- Set_Qualification -- + ----------------------- + + procedure Set_Qualification (N : Nat; E : Entity_Id) is + begin + if N /= 0 and then Scope (E) /= Standard_Standard then + Set_Qualification (N - 1, Scope (E)); + Set_Msg_Node (Scope (E)); + Set_Msg_Char ('.'); + end if; + end Set_Qualification; + + --------------------------- + -- Set_Warnings_Mode_Off -- + --------------------------- + + procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is + begin + -- Don't bother with entries from instantiation copies, since we + -- will already have a copy in the template, which is what matters + + if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then + return; + end if; + + -- If last entry in table already covers us, this is a redundant + -- pragma Warnings (Off) and can be ignored. This also handles the + -- case where all warnings are suppressed by command line switch. + + if Warnings.Last >= Warnings.First + and then Warnings.Table (Warnings.Last).Start <= Loc + and then Loc <= Warnings.Table (Warnings.Last).Stop + then + return; + + -- Otherwise establish a new entry, extending from the location of + -- the pragma to the end of the current source file. This ending + -- point will be adjusted by a subsequent pragma Warnings (On). + + else + Warnings.Increment_Last; + Warnings.Table (Warnings.Last).Start := Loc; + Warnings.Table (Warnings.Last).Stop := + Source_Last (Current_Source_File); + end if; + end Set_Warnings_Mode_Off; + + -------------------------- + -- Set_Warnings_Mode_On -- + -------------------------- + + procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is + begin + -- Don't bother with entries from instantiation copies, since we + -- will already have a copy in the template, which is what matters + + if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then + return; + end if; + + -- Nothing to do unless command line switch to suppress all warnings + -- is off, and the last entry in the warnings table covers this + -- pragma Warnings (On), in which case adjust the end point. + + if (Warnings.Last >= Warnings.First + and then Warnings.Table (Warnings.Last).Start <= Loc + and then Loc <= Warnings.Table (Warnings.Last).Stop) + and then Warning_Mode /= Suppress + then + Warnings.Table (Warnings.Last).Stop := Loc; + end if; + end Set_Warnings_Mode_On; + + ---------------------- + -- Test_Warning_Msg -- + ---------------------- + + procedure Test_Warning_Msg (Msg : String) is + begin + if Msg'Length > 7 and then Msg (1 .. 7) = "(style)" then + Is_Warning_Msg := True; + return; + end if; + + for J in Msg'Range loop + if Msg (J) = '?' + and then (J = Msg'First or else Msg (J - 1) /= ''') + then + Is_Warning_Msg := True; + return; + end if; + end loop; + + Is_Warning_Msg := False; + end Test_Warning_Msg; + + -------------------------- + -- Unwind_Internal_Type -- + -------------------------- + + procedure Unwind_Internal_Type (Ent : in out Entity_Id) is + Derived : Boolean := False; + Mchar : Character; + Old_Ent : Entity_Id; + + begin + -- Undo placement of a quote, since we will put it back later + + Mchar := Msg_Buffer (Msglen); + + if Mchar = '"' then + Msglen := Msglen - 1; + end if; + + -- The loop here deals with recursive types, we are trying to + -- find a related entity that is not an implicit type. Note + -- that the check with Old_Ent stops us from getting "stuck". + -- Also, we don't output the "type derived from" message more + -- than once in the case where we climb up multiple levels. + + loop + Old_Ent := Ent; + + -- Implicit access type, use directly designated type + + if Is_Access_Type (Ent) then + Set_Msg_Str ("access to "); + Ent := Directly_Designated_Type (Ent); + + -- Classwide type + + elsif Is_Class_Wide_Type (Ent) then + Class_Flag := True; + Ent := Root_Type (Ent); + + -- Use base type if this is a subtype + + elsif Ent /= Base_Type (Ent) then + Buffer_Remove ("type "); + + -- Avoid duplication "subtype of subtype of", and also replace + -- "derived from subtype of" simply by "derived from" + + if not Buffer_Ends_With ("subtype of ") + and then not Buffer_Ends_With ("derived from ") + then + Set_Msg_Str ("subtype of "); + end if; + + Ent := Base_Type (Ent); + + -- If this is a base type with a first named subtype, use the + -- first named subtype instead. This is not quite accurate in + -- all cases, but it makes too much noise to be accurate and + -- add 'Base in all cases. Note that we only do this is the + -- first named subtype is not itself an internal name. This + -- avoids the obvious loop (subtype->basetype->subtype) which + -- would otherwise occur!) + + elsif Present (Freeze_Node (Ent)) + and then Present (First_Subtype_Link (Freeze_Node (Ent))) + and then + not Is_Internal_Name + (Chars (First_Subtype_Link (Freeze_Node (Ent)))) + then + Ent := First_Subtype_Link (Freeze_Node (Ent)); + + -- Otherwise use root type + + else + if not Derived then + Buffer_Remove ("type "); + + -- Test for "subtype of type derived from" which seems + -- excessive and is replaced by simply "type derived from" + + Buffer_Remove ("subtype of"); + + -- Avoid duplication "type derived from type derived from" + + if not Buffer_Ends_With ("type derived from ") then + Set_Msg_Str ("type derived from "); + end if; + + Derived := True; + end if; + + Ent := Etype (Ent); + end if; + + -- If we are stuck in a loop, get out and settle for the + -- internal name after all. In this case we set to kill the + -- message if it is not the first error message (we really try + -- hard not to show the dirty laundry of the implementation to + -- the poor user!) + + if Ent = Old_Ent then + Kill_Message := True; + exit; + end if; + + -- Get out if we finally found a non-internal name to use + + exit when not Is_Internal_Name (Chars (Ent)); + end loop; + + if Mchar = '"' then + Set_Msg_Char ('"'); + end if; + + end Unwind_Internal_Type; + + ------------------------- + -- Warnings_Suppressed -- + ------------------------- + + function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is + begin + for J in Warnings.First .. Warnings.Last loop + if Warnings.Table (J).Start <= Loc + and then Loc <= Warnings.Table (J).Stop + then + return True; + end if; + end loop; + + return False; + end Warnings_Suppressed; + +end Errout; |