X-Git-Url: https://oss.titaniummirror.com/gitweb?a=blobdiff_plain;f=gcc%2Fada%2Ferrout.adb;fp=gcc%2Fada%2Ferrout.adb;h=0000000000000000000000000000000000000000;hb=6fed43773c9b0ce596dca5686f37ac3fc0fa11c0;hp=92d3e09a5a5a5cd337ac3d51958453581a190521;hpb=27b11d56b743098deb193d510b337ba22dc52e5c;p=msp430-gcc.git diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb deleted file mode 100644 index 92d3e09a..00000000 --- a/gcc/ada/errout.adb +++ /dev/null @@ -1,3121 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- E R R O U T -- --- -- --- B o d y -- --- -- --- $Revision: 1.5.10.1 $ --- -- --- 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. -- --- 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 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. Initialized 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 : 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 - -- 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 Errors_Detected > 0 - then - return; - end if; - - Sindex := Get_Source_File_Index (Flag_Location); - 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 - - ----------------------- - -- 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. - - ------------------- - -- To_Be_Removed -- - ------------------- - - 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; - - if Nkind (N) = N_Raise_Constraint_Error - and then Original_Node (N) /= N - then - -- Warnings may have been posted on subexpressions of - -- the original tree. We temporarily replace the raise - -- statement with the original expression to remove - -- those warnings, whose sloc do not match those of - -- any node in the current tree. - - declare - Old : Node_Id := N; - Status : Traverse_Result; - - begin - Rewrite (N, Original_Node (N)); - Status := Check_For_Warning (N); - Rewrite (N, Old); - return Status; - end; - - else - return OK; - end if; - end Check_For_Warning; - - -- Start of processing for Remove_Warning_Messages - - begin - if Warnings_Detected /= 0 then - declare - Discard : Traverse_Result; - begin - Discard := Check_All_Warnings (N); - end; - 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 (""); - - 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 (""); - - 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 (""); - - elsif Error_Msg_Node_1 = Error then - Set_Msg_Blank; - Set_Msg_Str (""); - - 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 (""); - - 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;