diff options
Diffstat (limited to 'gcc/ada/erroutc.ads')
| -rw-r--r-- | gcc/ada/erroutc.ads | 221 |
1 files changed, 205 insertions, 16 deletions
diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 3f080a5..2d8499a 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -27,10 +27,16 @@ -- reporting packages, including Errout and Prj.Err. with Table; +with Errsw; use Errsw; +with Errid; use Errid; +with Osint; use Osint; with Types; use Types; package Erroutc is + Exit_Code : Exit_Code_Type := E_Success; + -- Exit_Code used at the end of the compilation + type Error_Msg_Type is (Error, -- Default value Non_Serious_Error, @@ -76,15 +82,14 @@ package Erroutc is -- Set true to indicate that the current message originates from a -- Compile_Time_Warning or Compile_Time_Error pragma. + Is_Runtime_Raise_Msg : Boolean := False; + -- Set to True to indicate that the current message is a constraint error + -- that will be raised at runtime (contains [). + Is_Unconditional_Msg : Boolean := False; -- Set True to indicate that the current message contains the insertion -- character ! and is thus to be treated as an unconditional message. - Is_Runtime_Raise : Boolean := False; - -- Set to True to indicate that the current message is a warning about a - -- constraint error that will be raised at runtime (contains [ and switch - -- -gnatwE was given).. - Error_Msg_Kind : Error_Msg_Type := Error; Warning_Msg_Char : String (1 .. 2); @@ -177,6 +182,95 @@ package Erroutc is -- The following record type and table are used to represent error -- messages, with one entry in the table being allocated for each message. + type Labeled_Span_Id is new Int; + No_Labeled_Span : constant Labeled_Span_Id := 0; + + type Labeled_Span_Type is record + Label : String_Ptr := null; + -- Text associated with the span + + Span : Source_Span := (others => No_Location); + -- Textual region in the source code + + Is_Primary : Boolean := True; + -- Primary spans are used to indicate the primary location of the + -- diagnostic. Typically there should just be one primary span per + -- diagnostic. + -- Non-primary spans are used to indicate secondary locations and + -- typically are formatted in a different way or omitted in some + -- contexts. + + Is_Region : Boolean := False; + -- Regional spans are multiline spans that have a unique way of being + -- displayed in the pretty output. + + Next : Labeled_Span_Id := No_Labeled_Span; + + end record; + + No_Labeled_Span_Object : Labeled_Span_Type := (others => <>); + + package Locations is new Table.Table ( + Table_Component_Type => Labeled_Span_Type, + Table_Index_Type => Labeled_Span_Id, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 200, + Table_Name => "Location"); + + type Edit_Id is new Int; + No_Edit : constant Edit_Id := 0; + + type Edit_Type is record + Span : Source_Span; + -- Region of the file to be removed + + Text : String_Ptr; + -- Text to be inserted at the start location of the span + + Next : Edit_Id := No_Edit; + end record; + + package Edits is new Table.Table ( + Table_Component_Type => Edit_Type, + Table_Index_Type => Edit_Id, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 200, + Table_Name => "Edit"); + + type Fix_Id is new Int; + No_Fix : constant Fix_Id := 0; + + type Fix_Type is record + Description : String_Ptr := null; + -- Message describing the fix that will be displayed to the user. + + Edits : Edit_Id := No_Edit; + -- File changes for the fix. + + Next : Fix_Id := No_Fix; + end record; + + package Fixes is new Table.Table ( + Table_Component_Type => Fix_Type, + Table_Index_Type => Fix_Id, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 200, + Table_Name => "Fix"); + + type Warning_As_Error_Kind is + (None, From_Pragma, From_Warn_As_Err, From_Run_Time_As_Err); + -- The reason for a warning to be converted as an error: + -- * None - Regular warning. Default value for non-warning messages. + -- * From_Pragma - Warning converted to an error due to a pragma + -- Warning_As_Error. + -- * From_Warn_As_Err - Warning converted to an error because the + -- Warning_Mode was set to Treat_As_Errors by -gnatwe. + -- * From_Run_Time_As_Err - Warning converted to an error because the + -- Warning_Mode was set to Treat_Run_Time_Warnings_As_Errors by -gnatwE. + type Error_Msg_Object is record Text : String_Ptr; -- Text of error message, fully expanded with all insertions @@ -224,9 +318,11 @@ package Erroutc is -- True if the message originates from a Compile_Time_Warning or -- Compile_Time_Error pragma - Warn_Err : Boolean; - -- True if this is a warning message which is to be treated as an error - -- as a result of a match with a Warning_As_Error pragma. + Warn_Err : Warning_As_Error_Kind; + -- By default this is None. If the warning was converted by some reason + -- to an error then it has a different value. Depending on the value + -- the warning will be printed in a different way due to historical + -- reasons. Warn_Chr : String (1 .. 2); -- See Warning_Msg_Char @@ -248,6 +344,27 @@ package Erroutc is -- in the circuit for deleting duplicate/redundant error messages. Kind : Error_Msg_Type; + -- The kind of the error message. This determines how the message + -- should be handled and what kind of prefix should be added before the + -- message text. + + Switch : Switch_Id := No_Switch_Id; + -- Identifier for a given switch that enabled the diagnostic + + Id : Diagnostic_Id := No_Diagnostic_Id; + -- Unique error code for the given message + + Locations : Labeled_Span_Id := No_Labeled_Span; + -- Identifier to the first location identified by the error message. + -- These locations are marked with an underlying span line and + -- optionally given a short label. + + Fixes : Fix_Id := No_Fix; + -- Identifier to the first fix object for the error message. The fix + -- contains a suggestion to prevent the error from being triggered. + -- This includes edits that can be made to the source code. An edit + -- contians a region of the code that needs to be changed and the new + -- text that should be inserted to that region. end record; package Errors is new Table.Table ( @@ -268,6 +385,56 @@ package Erroutc is -- as the physically last entry in the error message table, since messages -- are not always inserted in sequence. + procedure Next_Error_Msg (E : in out Error_Msg_Id); + -- Update E to point to the next error message in the list of error + -- messages. Skip deleted and continuation messages. + + procedure Next_Continuation_Msg (E : in out Error_Msg_Id); + -- Update E to point to the next continuation message + + function Kind_To_String (E : Error_Msg_Object) return String is + (if E.Warn_Err in From_Pragma | From_Run_Time_As_Err then "error" + else + (case E.Kind is + when Error | Non_Serious_Error => "error", + when Warning => "warning", + when Style => "style", + when Info => "info", + when Low_Check => "low", + when Medium_Check => "medium", + when High_Check => "high")); + -- Returns the name of the error message kind. If it is a warning that has + -- been turned to an error then it returns "error". + + function Get_Doc_Switch (E : Error_Msg_Object) return String; + -- Returns the documentation switch for a given Error_Msg_Object. + -- + -- This either the name of the switch encased in brackets. E.g [-gnatwx]. + -- + -- If the Warn_Char is "* " is then it will return [restriction warning]. + -- + -- Otherwise for messages without a switch it will return + -- [enabled by default] . + + function Primary_Location (E : Error_Msg_Object) return Labeled_Span_Id; + -- Returns the first Primary Labeled_Span associated with the error + -- message. Otherwise it returns No_Labeled_Span. + + function Get_Human_Id (E : Error_Msg_Object) return String_Ptr; + -- Returns a longer human readable name for the switch associated with the + -- error message. + + function Get_Switch (E : Error_Msg_Object) return Switch_Type; + -- Returns the Switch information for the given error message + + function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id; + -- Returns the Switch information identifier for the given error message + + function Get_Switch_Id + (Kind : Error_Msg_Type; Warn_Chr : String) return Switch_Id; + -- Returns the Switch information identifier based on the error kind and + -- the warning character. + -------------------------- -- Warning Mode Control -- -------------------------- @@ -422,6 +589,14 @@ package Erroutc is function SGR_Locus return String is (SGR_Seq (Color_Bold)); + function Get_SGR_Code (E_Msg : Error_Msg_Object) return String is + (if E_Msg.Warn_Err /= None then SGR_Error + else + (case E_Msg.Kind is + when Warning | Style => SGR_Warning, + when Info => SGR_Note, + when others => SGR_Error)); + ----------------- -- Subprograms -- ----------------- @@ -443,8 +618,8 @@ package Erroutc is -- buffer, and preceded by a space. function Compilation_Errors return Boolean; - -- Returns true if errors have been detected, or warnings in -gnatwe - -- (treat warnings as errors) mode. + -- Returns true if errors have been detected, or warnings that are treated + -- as errors. procedure dmsg (Id : Error_Msg_Id); -- Debugging routine to dump an error message @@ -462,16 +637,14 @@ package Erroutc is -- redundant. If so, the message to be deleted and all its continuations -- are marked with the Deleted flag set to True. - function Count_Compile_Time_Pragma_Warnings return Int; - -- Returns the number of warnings in the Errors table that were triggered - -- by a Compile_Time_Warning pragma. - function Get_Warning_Option (Id : Error_Msg_Id) return String; + function Get_Warning_Option (E : Error_Msg_Object) return String; -- Returns the warning switch causing this warning message or an empty -- string is there is none.. function Get_Warning_Tag (Id : Error_Msg_Id) return String; - -- Given an error message ID, return tag showing warning message class, or + function Get_Warning_Tag (E : Error_Msg_Object) return String; + -- Given an error message, return tag showing warning message class, or -- the null string if this option is not enabled or this is not a warning. procedure Increase_Error_Msg_Count (E : Error_Msg_Object); @@ -513,7 +686,7 @@ package Erroutc is -- splits the line generating multiple lines of output, and in this case -- the last line has no terminating end of line character. - procedure Output_Text_Within (Txt : String_Ptr; Line_Length : Nat); + procedure Output_Text_Within (Txt : String; Line_Length : Nat); -- Output the text in Txt, splitting it into lines of at most the size of -- Line_Length. @@ -549,6 +722,18 @@ package Erroutc is -- Note that the call has no effect for continuation messages (those whose -- first character is '\') except for the Has_Insertion_Line setting. + -- Definitions for valid message kind prefixes within error messages. + + Info_Prefix : constant String := "info: "; + Low_Prefix : constant String := "low: "; + Medium_Prefix : constant String := "medium: "; + High_Prefix : constant String := "high: "; + Style_Prefix : constant String := "(style) "; + + Warn_As_Err_Tag : constant String := "[warning-as-error]"; + -- Tag used at the end of warning messages that were converted by + -- pragma Warning_As_Error. + procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr); -- All error messages whose location is in the range From .. To (not -- including the end points) will be deleted from the error listing. @@ -705,6 +890,10 @@ package Erroutc is -- given by Warning_As_Error pragmas, as stored in the Warnings_As_Errors -- table. + function Warning_Treated_As_Error (E : Error_Msg_Object) return Boolean; + -- Returns true if a Warning_As_Error pragma matches either the error text + -- or the warning tag of the message. + procedure Write_Error_Summary; -- Write error summary |