diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/diagnostics-converter.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/diagnostics-switch_repository.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/diagnostics-utils.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/diagnostics.adb | 38 | ||||
| -rw-r--r-- | gcc/ada/diagnostics.ads | 11 | ||||
| -rw-r--r-- | gcc/ada/errout.adb | 208 | ||||
| -rw-r--r-- | gcc/ada/erroutc.adb | 176 | ||||
| -rw-r--r-- | gcc/ada/erroutc.ads | 84 | ||||
| -rw-r--r-- | gcc/ada/errutil.adb | 63 |
9 files changed, 279 insertions, 330 deletions
diff --git a/gcc/ada/diagnostics-converter.adb b/gcc/ada/diagnostics-converter.adb index e1613f6..f02c213 100644 --- a/gcc/ada/diagnostics-converter.adb +++ b/gcc/ada/diagnostics-converter.adb @@ -51,9 +51,10 @@ package body Diagnostics.Converter is function Get_Diagnostics_Kind (E_Msg : Error_Msg_Object) return Diagnostic_Kind - is (if E_Msg.Warn then Get_Warning_Kind (E_Msg) - elsif E_Msg.Style then Style - elsif E_Msg.Info then Info + is (if E_Msg.Kind = Erroutc.Warning then Get_Warning_Kind (E_Msg) + elsif E_Msg.Kind = Erroutc.Style then Style + elsif E_Msg.Kind = Erroutc.Info then Info + elsif E_Msg.Kind = Erroutc.Non_Serious_Error then Non_Serious_Error else Error); ----------------------------------- @@ -126,14 +127,12 @@ package body Diagnostics.Converter is D.Kind := Get_Diagnostics_Kind (E_Msg); - if E_Msg.Warn or E_Msg.Style or E_Msg.Info then + if E_Msg.Kind in Erroutc.Warning | Erroutc.Style | Erroutc.Info then D.Switch := Get_Switch_Id (E_Msg); end if; D.Warn_Err := E_Msg.Warn_Err; - D.Serious := E_Msg.Serious; - -- Convert the primary location Add_Location (D, Primary_Labeled_Span (E_Msg.Sptr)); diff --git a/gcc/ada/diagnostics-switch_repository.adb b/gcc/ada/diagnostics-switch_repository.adb index d609901..1795663 100644 --- a/gcc/ada/diagnostics-switch_repository.adb +++ b/gcc/ada/diagnostics-switch_repository.adb @@ -582,14 +582,16 @@ package body Diagnostics.Switch_Repository is ------------------- function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id is - + Switch_Name : constant String := + (if E.Warn_Chr = "$ " then "gnatel" + elsif E.Warn_Chr in "? " | " " then "" + elsif E.Kind in Erroutc.Warning | Erroutc.Info + then "gnatw" & E.Warn_Chr + elsif E.Kind in Erroutc.Style then "gnatw" & E.Warn_Chr + else ""); begin - if E.Warn_Chr = "$ " then - return Get_Switch_Id ("gnatel"); - elsif E.Warn or E.Info then - return Get_Switch_Id ("gnatw" & E.Warn_Chr); - elsif E.Style then - return Get_Switch_Id ("gnaty" & E.Warn_Chr); + if Switch_Name /= "" then + return Get_Switch_Id (Switch_Name); else return No_Switch_Id; end if; diff --git a/gcc/ada/diagnostics-utils.adb b/gcc/ada/diagnostics-utils.adb index a590536..11649cc 100644 --- a/gcc/ada/diagnostics-utils.adb +++ b/gcc/ada/diagnostics-utils.adb @@ -219,7 +219,7 @@ package body Diagnostics.Utils is (if D.Warn_Err then "error" else (case D.Kind is - when Diagnostics.Error => "error", + when Diagnostics.Error | Non_Serious_Error => "error", when Warning | Restriction_Warning | Default_Warning | Tagless_Warning => "warning", when Style => "style", diff --git a/gcc/ada/diagnostics.adb b/gcc/ada/diagnostics.adb index c9c5483..d45279f 100644 --- a/gcc/ada/diagnostics.adb +++ b/gcc/ada/diagnostics.adb @@ -197,21 +197,29 @@ package body Diagnostics is procedure Update_Diagnostic_Count (Diagnostic : Diagnostic_Type) is begin - if Diagnostic.Kind = Error then - Total_Errors_Detected := Total_Errors_Detected + 1; - - if Diagnostic.Serious then + case Diagnostic.Kind is + when Error => + Total_Errors_Detected := Total_Errors_Detected + 1; Serious_Errors_Detected := Serious_Errors_Detected + 1; - end if; - elsif Diagnostic.Kind in Warning | Style then - Warnings_Detected := Warnings_Detected + 1; - - if Diagnostic.Warn_Err then - Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1; - end if; - elsif Diagnostic.Kind in Info then - Info_Messages := Info_Messages + 1; - end if; + + when Non_Serious_Error => + Total_Errors_Detected := Total_Errors_Detected + 1; + + when Warning + | Default_Warning + | Tagless_Warning + | Restriction_Warning + | Style + => + Warnings_Detected := Warnings_Detected + 1; + + if Diagnostic.Warn_Err then + Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1; + end if; + + when Info => + Info_Messages := Info_Messages + 1; + end case; end Update_Diagnostic_Count; procedure Handle_Serious_Error; @@ -265,7 +273,7 @@ package body Diagnostics is Update_Diagnostic_Count (Diagnostic); end if; - if Diagnostic.Kind = Error and then Diagnostic.Serious then + if Diagnostic.Kind = Error then Handle_Serious_Error; end if; end Record_Diagnostic; diff --git a/gcc/ada/diagnostics.ads b/gcc/ada/diagnostics.ads index 67800d9..0df0382 100644 --- a/gcc/ada/diagnostics.ads +++ b/gcc/ada/diagnostics.ads @@ -305,6 +305,11 @@ package Diagnostics is type Diagnostic_Kind is (Error, + Non_Serious_Error, + -- Typically all errors are considered serious and the compiler should + -- stop its processing since the tree is essentially invalid. However, + -- some errors are not serious and the compiler can continue its + -- processing to discover more critical errors. Warning, Default_Warning, -- Warning representing the old warnings created with the '??' insertion @@ -349,12 +354,6 @@ package Diagnostics is -- error. This needs to be set during the message emission as this -- behavior depends on the context of the code. - Serious : Boolean := True; - -- Typically all errors are considered serious and the compiler should - -- stop its processing since the tree is essentially invalid. However, - -- some errors are not serious and the compiler can continue its - -- processing to discover more critical errors. - Locations : Labeled_Span_List := Labeled_Span_Lists.Nil; Sub_Diagnostics : Sub_Diagnostic_List := Sub_Diagnostic_Lists.Nil; diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index de2413a..a569b61 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -411,21 +411,21 @@ package body Errout is -- No duplicate, so error/warning will be posted on instance - Warn_On_Instance := Is_Warning_Msg; + Warn_On_Instance := Error_Msg_Kind = Warning; end if; -- Ignore warning message that is suppressed for this location. Note -- that style checks are not considered warning messages for this -- purpose. - if Is_Warning_Msg + if Error_Msg_Kind = Warning and then Warnings_Suppressed (Orig_Loc) /= No_String then return; -- For style messages, check too many messages so far - elsif Is_Style_Msg + elsif Error_Msg_Kind = Style and then Maximum_Messages /= 0 and then Warnings_Detected >= Maximum_Messages then @@ -435,7 +435,7 @@ package body Errout is -- probably null (i.e. when loop executes only if invalid values -- present). In either case warnings in the loop are likely to be junk. - elsif Is_Warning_Msg and then Present (N) then + elsif Error_Msg_Kind = Warning and then Present (N) then declare P : Node_Id; @@ -556,21 +556,21 @@ package body Errout is -- Case of inlined body if Inlined_Body (X) then - if Is_Info_Msg then + if Error_Msg_Kind = Info then Error_Msg_Internal (Msg => "info: in inlined body #", Span => To_Span (Actual_Error_Loc), Opan => Flag_Span, Msg_Cont => Msg_Cont_Status); - elsif Is_Warning_Msg then + elsif Error_Msg_Kind = Warning then Error_Msg_Internal (Msg => Warn_Insertion & "in inlined body #", Span => To_Span (Actual_Error_Loc), Opan => Flag_Span, Msg_Cont => Msg_Cont_Status); - elsif Is_Style_Msg then + elsif Error_Msg_Kind = Style then Error_Msg_Internal (Msg => "style: in inlined body #", Span => To_Span (Actual_Error_Loc), @@ -588,21 +588,21 @@ package body Errout is -- Case of generic instantiation else - if Is_Info_Msg then + if Error_Msg_Kind = Info then Error_Msg_Internal (Msg => "info: in instantiation #", Span => To_Span (Actual_Error_Loc), Opan => Flag_Span, Msg_Cont => Msg_Cont_Status); - elsif Is_Warning_Msg then + elsif Error_Msg_Kind = Warning then Error_Msg_Internal (Msg => Warn_Insertion & "in instantiation #", Span => To_Span (Actual_Error_Loc), Opan => Flag_Span, Msg_Cont => Msg_Cont_Status); - elsif Is_Style_Msg then + elsif Error_Msg_Kind = Style then Error_Msg_Internal (Msg => "style: in instantiation #", Span => To_Span (Actual_Error_Loc), @@ -1016,7 +1016,7 @@ package body Errout is if Suppress_Message and then not All_Errors_Mode - and then not Is_Warning_Msg + and then Error_Msg_Kind /= Warning and then not Is_Unconditional_Msg then if not Continuation then @@ -1042,7 +1042,7 @@ package body Errout is return; end if; - if Is_Info_Msg then + if Error_Msg_Kind = Info then -- Immediate return if info messages are suppressed @@ -1074,17 +1074,14 @@ package body Errout is return; end if; - end if; - -- Special check for warning message to see if it should be output - if Is_Warning_Msg then + elsif Error_Msg_Kind = Warning then -- Immediate return if warning message and warnings are suppressed if Warnings_Suppressed (Optr) /= No_String - or else - Warnings_Suppressed (Sptr) /= No_String + or else Warnings_Suppressed (Sptr) /= No_String then Cur_Msg := No_Error_Msg; return; @@ -1137,7 +1134,7 @@ package body Errout is -- where we do this special processing, bypassing message output. if Ignore_Errors_Enable > 0 then - if Is_Serious_Error then + if Error_Msg_Kind = Erroutc.Error then Handle_Serious_Error; end if; @@ -1223,9 +1220,9 @@ package body Errout is -- Update warning msg flag and message doc char if needed - if Is_Warning_Msg then - if not Errors.Table (Cur_Msg).Warn then - Errors.Table (Cur_Msg).Warn := True; + if Error_Msg_Kind = Warning then + if Errors.Table (Cur_Msg).Kind /= Warning then + Errors.Table (Cur_Msg).Kind := Warning; Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char; elsif Warning_Msg_Char /= " " then @@ -1237,11 +1234,6 @@ package body Errout is return; end if; - -- Warning, Style and Info attributes are mutually exclusive - - pragma Assert (Boolean'Pos (Is_Warning_Msg) + Boolean'Pos (Is_Info_Msg) + - Boolean'Pos (Is_Style_Msg) <= 1); - -- Here we build a new error object Errors.Append @@ -1250,42 +1242,40 @@ package body Errout is Prev => No_Error_Msg, Sptr => Span, Optr => Opan, - Insertion_Sloc => (if Has_Insertion_Line then Error_Msg_Sloc - else No_Location), + Insertion_Sloc => + (if Has_Insertion_Line then Error_Msg_Sloc else No_Location), Sfile => Get_Source_File_Index (Sptr), Line => Get_Physical_Line_Number (Sptr), Col => Get_Column_Number (Sptr), Compile_Time_Pragma => Is_Compile_Time_Msg, - Warn => Is_Warning_Msg, - Info => Is_Info_Msg, - Check => Is_Check_Msg, Warn_Err => False, -- reset below Warn_Chr => Warning_Msg_Char, Warn_Runtime_Raise => Is_Runtime_Raise, - Style => Is_Style_Msg, - Serious => Is_Serious_Error, Uncond => Is_Unconditional_Msg, Msg_Cont => Continuation, - Deleted => False)); + Deleted => False, + Kind => Error_Msg_Kind)); Cur_Msg := Errors.Last; -- Test if warning to be treated as error Warn_Err := - (Is_Warning_Msg or Is_Style_Msg) - and then (Warning_Treated_As_Error (Msg_Buffer (1 .. Msglen)) - or else - Warning_Treated_As_Error (Get_Warning_Tag (Cur_Msg))); + Error_Msg_Kind in Warning | Style + and then (Warning_Treated_As_Error (Msg_Buffer (1 .. Msglen)) + or else Warning_Treated_As_Error + (Get_Warning_Tag (Cur_Msg))); -- Propagate Warn_Err to this message and preceding continuations. - -- Likewise, propagate Is_Warning_Msg and Is_Runtime_Raise, because the + -- Likewise, propagate Error_Msg_Kind and Is_Runtime_Raise, because the -- current continued message could have been escalated from warning to -- error. for J in reverse 1 .. Errors.Last loop - Errors.Table (J).Warn_Err := Warn_Err; - Errors.Table (J).Warn := Is_Warning_Msg; + Errors.Table (J).Warn_Err := Warn_Err; + + Errors.Table (J).Kind := Error_Msg_Kind; Errors.Table (J).Warn_Runtime_Raise := Is_Runtime_Raise; + exit when not Errors.Table (J).Msg_Cont; end loop; @@ -1311,13 +1301,14 @@ package body Errout is -- there are lots of messages. if Last_Error_Msg /= No_Error_Msg - and then Errors.Table (Cur_Msg).Sfile = - Errors.Table (Last_Error_Msg).Sfile + and then Errors.Table (Cur_Msg).Sfile + = Errors.Table (Last_Error_Msg).Sfile and then (Sptr > Errors.Table (Last_Error_Msg).Sptr.Ptr - or else - (Sptr = Errors.Table (Last_Error_Msg).Sptr.Ptr - and then - Optr > Errors.Table (Last_Error_Msg).Optr.Ptr)) + or else (Sptr = Errors.Table (Last_Error_Msg).Sptr.Ptr + and then Optr + > Errors.Table (Last_Error_Msg) + .Optr + .Ptr)) then Prev_Msg := Last_Error_Msg; Next_Msg := No_Error_Msg; @@ -1333,10 +1324,10 @@ package body Errout is if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile then - exit when Sptr < Errors.Table (Next_Msg).Sptr.Ptr + exit when + Sptr < Errors.Table (Next_Msg).Sptr.Ptr or else (Sptr = Errors.Table (Next_Msg).Sptr.Ptr - and then - Optr < Errors.Table (Next_Msg).Optr.Ptr); + and then Optr < Errors.Table (Next_Msg).Optr.Ptr); end if; Prev_Msg := Next_Msg; @@ -1354,10 +1345,9 @@ package body Errout is -- 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 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 @@ -1365,9 +1355,7 @@ package body Errout is -- 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 + 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 @@ -1375,13 +1363,8 @@ package body Errout is -- message. This helps to avoid junk extra messages from -- cascaded parsing errors - if not (Errors.Table (Prev_Msg).Warn - or else - Errors.Table (Prev_Msg).Style) - or else - (Errors.Table (Cur_Msg).Warn - or else - Errors.Table (Cur_Msg).Style) + if Errors.Table (Prev_Msg).Kind not in Warning | Style + or else Errors.Table (Cur_Msg).Kind in Warning | Style then -- All tests passed, delete the message by simply returning -- without any further processing. @@ -1413,42 +1396,26 @@ package body Errout is end if; end if; - -- Bump appropriate statistics counts - - if Errors.Table (Cur_Msg).Info then - Info_Messages := Info_Messages + 1; - - elsif Errors.Table (Cur_Msg).Warn - or else Errors.Table (Cur_Msg).Style - then - Warnings_Detected := Warnings_Detected + 1; + Increase_Error_Msg_Count (Errors.Table (Cur_Msg)); - elsif Errors.Table (Cur_Msg).Check then - Check_Messages := Check_Messages + 1; + if Errors.Table (Cur_Msg).Kind = Erroutc.Error then + Handle_Serious_Error; - else - Total_Errors_Detected := Total_Errors_Detected + 1; - - if Errors.Table (Cur_Msg).Serious then - Serious_Errors_Detected := Serious_Errors_Detected + 1; - Handle_Serious_Error; + -- If not serious error, set Fatal_Error to indicate ignored error - -- If not serious error, set Fatal_Error to indicate ignored error - - else - declare - U : constant Unit_Number_Type := Get_Source_Unit (Sptr); - begin - if Fatal_Error (U) = None then - Set_Fatal_Error (U, Error_Ignored); - end if; - end; - end if; + elsif Errors.Table (Cur_Msg).Kind = Non_Serious_Error then + declare + U : constant Unit_Number_Type := Get_Source_Unit (Sptr); + begin + if Fatal_Error (U) = None then + Set_Fatal_Error (U, Error_Ignored); + end if; + end; end if; -- Record warning message issued - if Errors.Table (Cur_Msg).Warn + if Errors.Table (Cur_Msg).Kind = Warning and then not Errors.Table (Cur_Msg).Msg_Cont then Warning_Msg := Cur_Msg; @@ -1478,10 +1445,7 @@ package body Errout is Has_Insertion_Line := False; Error_Msg_Internal - (Msg => Msg, - Span => Span, - Opan => Opan, - Msg_Cont => True); + (Msg => Msg, Span => Span, Opan => Opan, Msg_Cont => True); end; end if; end Error_Msg_Internal; @@ -1553,7 +1517,7 @@ package body Errout is -- Special handling for warning messages - if Is_Warning_Msg then + if Error_Msg_Kind = Warning then -- Suppress if no warnings set for either entity or node @@ -1570,7 +1534,7 @@ package body Errout is if All_Errors_Mode or else Is_Unconditional_Msg - or else Is_Warning_Msg + or else Error_Msg_Kind = Warning or else OK_Node (N) or else (Msg (Msg'First) = '\' and then not Last_Killed) then @@ -1715,7 +1679,7 @@ package body Errout is Tag : constant String := Get_Warning_Tag (Cur); begin - if CE.Warn + if CE.Kind = Warning and then not CE.Deleted and then (Warning_Specifically_Suppressed (CE.Sptr.Ptr, CE.Text, Tag) @@ -2498,9 +2462,15 @@ package body Errout is Write_Str ("{""kind"":"); - if Errors.Table (E).Warn and then not Errors.Table (E).Warn_Err then + if Errors.Table (E).Kind = Warning and then not Errors.Table (E).Warn_Err + then Write_Str ("""warning"""); - elsif Errors.Table (E).Info or else Errors.Table (E).Check then + elsif Errors.Table (E).Kind in + Info + | High_Check + | Medium_Check + | Low_Check + then Write_Str ("""note"""); else Write_Str ("""error"""); @@ -2629,7 +2599,7 @@ package body Errout is if Debug_Flag_FF then if Errors.Table (E).Msg_Cont then Write_Str (" "); - elsif not Errors.Table (E).Info then + elsif Errors.Table (E).Kind /= Info then Write_Eol; end if; end if; @@ -2648,7 +2618,7 @@ package body Errout is -- continuation messages. if Debug_Flag_FF - and then not Errors.Table (E).Info + and then Errors.Table (E).Kind /= Info then if Errors.Table (E).Msg_Cont then declare @@ -2664,8 +2634,8 @@ package body Errout is else declare SGR_Span : constant String := - (if Errors.Table (E).Info then SGR_Note - elsif Errors.Table (E).Warn + (if Errors.Table (E).Kind = Info then SGR_Note + elsif Errors.Table (E).Kind = Warning and then not Errors.Table (E).Warn_Err then SGR_Warning else SGR_Error); @@ -3644,7 +3614,7 @@ package body Errout is -- not remove style messages here. They are warning messages -- but not ones we want removed in this context. - and then (Errors.Table (E).Warn + and then (Errors.Table (E).Kind = Warning or else Errors.Table (E).Warn_Runtime_Raise) @@ -3652,7 +3622,7 @@ package body Errout is and then not Errors.Table (E).Uncond then - if Errors.Table (E).Warn then + if Errors.Table (E).Kind = Warning then Warnings_Detected := Warnings_Detected - 1; end if; @@ -3876,9 +3846,9 @@ package body Errout is K : Node_Kind; begin - Suppress_Message := Error_Msg_Node_1 in Error | Any_Type; + Suppress_Message := Error_Msg_Node_1 in Types.Error | Any_Type; - if Error_Msg_Node_1 = Error then + if Error_Msg_Node_1 = Types.Error then Set_Msg_Blank; Set_Msg_Str ("<error>"); @@ -4291,9 +4261,9 @@ package body Errout is Msglen := 0; Flag_Source := Get_Source_File_Index (Flag); - -- Skip info: at start, we have recorded this in Is_Info_Msg, and this - -- will be used (Info field in error message object) to put back the - -- string when it is printed. We need to do this, or we get confused + -- Skip info: at start, we have recorded this in Error_Msg_Kind, and + -- this will be used (Info field in error message object) to put back + -- the string when it is printed. We need to do this, or we get confused -- with instantiation continuations. if Text'Length > 6 @@ -4413,16 +4383,16 @@ package body Errout is else -- Switch the message from a warning to an error if the flag -- -gnatwE is specified to treat run-time exception warnings - -- as errors. + -- as non-serious errors. - if Is_Warning_Msg + if Error_Msg_Kind = Warning and then Warning_Mode = Treat_Run_Time_Warnings_As_Errors then - Is_Warning_Msg := False; + Error_Msg_Kind := Non_Serious_Error; Is_Runtime_Raise := True; end if; - if Is_Warning_Msg then + if Error_Msg_Kind = Warning then Set_Msg_Str ("will be raised at run time"); else Set_Msg_Str ("would have been raised at run time"); @@ -4432,7 +4402,7 @@ package body Errout is -- ']' (may be/might have been raised at run time) when ']' => - if Is_Warning_Msg then + if Error_Msg_Kind = Warning then Set_Msg_Str ("may be raised at run time"); else Set_Msg_Str ("might have been raised at run time"); @@ -4454,7 +4424,7 @@ package body Errout is P : Node_Id; begin - if Is_Serious_Error then + if Error_Msg_Kind = Erroutc.Error then -- We always set Error_Posted on the node itself diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 606600c..32197ad 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -145,29 +145,7 @@ package body Erroutc is loop Errors.Table (D).Deleted := True; - -- Adjust error message count - - if Errors.Table (D).Info then - - Info_Messages := Info_Messages - 1; - - elsif Errors.Table (D).Warn or else Errors.Table (D).Style then - Warnings_Detected := Warnings_Detected - 1; - - -- Note: we do not need to decrement Warnings_Treated_As_Errors - -- because this only gets incremented if we actually output the - -- message, which we won't do if we are deleting it here! - - elsif Errors.Table (D).Check then - Check_Messages := Check_Messages - 1; - - else - Total_Errors_Detected := Total_Errors_Detected - 1; - - if Errors.Table (D).Serious then - Serious_Errors_Detected := Serious_Errors_Detected - 1; - end if; - end if; + Decrease_Error_Msg_Count (Errors.Table (D)); -- Substitute shorter of the two error messages @@ -278,7 +256,7 @@ package body Erroutc is begin for J in 1 .. Errors.Last loop begin - if Errors.Table (J).Warn + if Errors.Table (J).Kind = Warning and then Errors.Table (J).Compile_Time_Pragma and then not Errors.Table (J).Deleted then @@ -289,6 +267,32 @@ package body Erroutc is return Result; end Count_Compile_Time_Pragma_Warnings; + ------------------------------ + -- Decrease_Error_Msg_Count -- + ------------------------------ + + procedure Decrease_Error_Msg_Count (E : Error_Msg_Object) is + + begin + case E.Kind is + when Info => + Info_Messages := Info_Messages - 1; + + when Warning | Style => + Warnings_Detected := Warnings_Detected - 1; + + when High_Check | Medium_Check | Low_Check => + Check_Messages := Check_Messages - 1; + + when Error => + Total_Errors_Detected := Total_Errors_Detected - 1; + Serious_Errors_Detected := Serious_Errors_Detected - 1; + + when Non_Serious_Error => + Total_Errors_Detected := Total_Errors_Detected - 1; + end case; + end Decrease_Error_Msg_Count; + ------------------ -- Debug_Output -- ------------------ @@ -334,13 +338,10 @@ package body Erroutc is w (" Line = ", Int (E.Line)); w (" Col = ", Int (E.Col)); - w (" Info = ", E.Info); - w (" Warn = ", E.Warn); + w (" Kind = ", E.Kind'Img); w (" Warn_Err = ", E.Warn_Err); w (" Warn_Runtime_Raise = ", E.Warn_Runtime_Raise); w (" Warn_Chr = '" & E.Warn_Chr & '''); - w (" Style = ", E.Style); - w (" Serious = ", E.Serious); w (" Uncond = ", E.Uncond); w (" Msg_Cont = ", E.Msg_Cont); w (" Deleted = ", E.Deleted); @@ -371,7 +372,7 @@ package body Erroutc is ------------------------ function Get_Warning_Option (Id : Error_Msg_Id) return String is - Style : constant Boolean := Errors.Table (Id).Style; + Is_Style : constant Boolean := Errors.Table (Id).Kind in Style; Warn_Chr : constant String (1 .. 2) := Errors.Table (Id).Warn_Chr; begin @@ -380,7 +381,7 @@ package body Erroutc is then if Warn_Chr = "$ " then return "-gnatel"; - elsif Style then + elsif Is_Style then return "-gnaty" & Warn_Chr (1); elsif Warn_Chr (2) = ' ' then return "-gnatw" & Warn_Chr (1); @@ -414,6 +415,32 @@ package body Erroutc is return ""; end Get_Warning_Tag; + ------------------------------ + -- Increase_Error_Msg_Count -- + ------------------------------ + + procedure Increase_Error_Msg_Count (E : Error_Msg_Object) is + + begin + case E.Kind is + when Info => + Info_Messages := Info_Messages + 1; + + when Warning | Style => + Warnings_Detected := Warnings_Detected + 1; + + when High_Check | Medium_Check | Low_Check => + Check_Messages := Check_Messages + 1; + + when Error => + Total_Errors_Detected := Total_Errors_Detected + 1; + Serious_Errors_Detected := Serious_Errors_Detected + 1; + + when Non_Serious_Error => + Total_Errors_Detected := Total_Errors_Detected + 1; + end case; + end Increase_Error_Msg_Count; + -------------------- -- Has_Switch_Tag -- -------------------- @@ -421,14 +448,10 @@ package body Erroutc is function Has_Switch_Tag (Id : Error_Msg_Id) return Boolean is (Has_Switch_Tag (Errors.Table (Id))); - function Has_Switch_Tag (E_Msg : Error_Msg_Object) return Boolean - is - Warn : constant Boolean := E_Msg.Warn; - Style : constant Boolean := E_Msg.Style; - Info : constant Boolean := E_Msg.Info; - Warn_Chr : constant String (1 .. 2) := E_Msg.Warn_Chr; + function Has_Switch_Tag (E_Msg : Error_Msg_Object) return Boolean is begin - return (Warn or Style or Info) and then Warn_Chr /= " "; + return + E_Msg.Kind in Warning | Info | Style and then E_Msg.Warn_Chr /= " "; end Has_Switch_Tag; ------------- @@ -836,7 +859,7 @@ package body Erroutc is -- For info messages, prefix message with "info: " - elsif E_Msg.Info then + elsif E_Msg.Kind = Info then Txt := new String'(SGR_Note & "info: " & SGR_Reset & Txt.all); -- Warning treated as error @@ -852,12 +875,12 @@ package body Erroutc is -- Normal warning, prefix with "warning: " - elsif E_Msg.Warn then + elsif E_Msg.Kind = Warning then Txt := new String'(SGR_Warning & "warning: " & SGR_Reset & Txt.all); -- No prefix needed for style message, "(style)" is there already - elsif E_Msg.Style then + elsif E_Msg.Kind = Style then if Txt (Txt'First .. Txt'First + 6) = "(style)" then Txt := new String'(SGR_Warning & "(style)" & SGR_Reset & Txt (Txt'First + 7 .. Txt'Last)); @@ -865,7 +888,7 @@ package body Erroutc is -- No prefix needed for check message, severity is there already - elsif E_Msg.Check then + elsif E_Msg.Kind in High_Check | Medium_Check | Low_Check then -- The message format is "severity: ..." -- @@ -989,35 +1012,46 @@ package body Erroutc is -- Set initial values of globals (may be changed during scan) - Is_Serious_Error := True; + Error_Msg_Kind := Error; Is_Unconditional_Msg := False; - Is_Warning_Msg := False; Is_Runtime_Raise := False; Warning_Msg_Char := " "; -- Check style message - Is_Style_Msg := - Msg'Length > 7 - and then Msg (Msg'First .. Msg'First + 6) = "(style)"; + if Msg'Length > 7 + and then Msg (Msg'First .. Msg'First + 6) = "(style)" + then + Error_Msg_Kind := Style; - -- Check info message + -- Check info message - Is_Info_Msg := - Msg'Length > 6 - and then Msg (Msg'First .. Msg'First + 5) = "info: "; + elsif Msg'Length > 6 + and then Msg (Msg'First .. Msg'First + 5) = "info: " + then + Error_Msg_Kind := Info; + + -- Check high check message + + elsif Msg'Length > 6 + and then Msg (Msg'First .. Msg'First + 5) = "high: " + then + Error_Msg_Kind := High_Check; + + -- Check medium check message - -- Check check message + elsif Msg'Length > 8 + and then Msg (Msg'First .. Msg'First + 7) = "medium: " + then + Error_Msg_Kind := Medium_Check; - Is_Check_Msg := - (Msg'Length > 8 - and then Msg (Msg'First .. Msg'First + 7) = "medium: ") - or else - (Msg'Length > 6 - and then Msg (Msg'First .. Msg'First + 5) = "high: ") - or else - (Msg'Length > 5 - and then Msg (Msg'First .. Msg'First + 4) = "low: "); + -- Check low check message + + elsif Msg'Length > 5 + and then Msg (Msg'First .. Msg'First + 4) = "low: " + then + Error_Msg_Kind := Low_Check; + end if; end if; Has_Double_Exclam := False; @@ -1045,7 +1079,10 @@ package body Erroutc is -- characters and not the generic ? or ?? warning insertion -- characters. - Is_Warning_Msg := not (Is_Style_Msg or else Is_Info_Msg); + if Error_Msg_Kind not in Style | Info then + Error_Msg_Kind := Warning; + end if; + J := J + 1; Warning_Msg_Char := Parse_Message_Class; @@ -1079,7 +1116,7 @@ package body Erroutc is -- Non-serious error (| insertion) elsif Msg (J) = '|' then - Is_Serious_Error := False; + Error_Msg_Kind := Non_Serious_Error; J := J + 1; -- Error code ([] insertion) @@ -1095,10 +1132,6 @@ package body Erroutc is J := J + 1; end if; end loop; - - if Is_Info_Msg or Is_Warning_Msg or Is_Style_Msg or Is_Check_Msg then - Is_Serious_Error := False; - end if; end Prescan_Message; -------------------- @@ -1122,16 +1155,7 @@ package body Erroutc is and then Errors.Table (E).Sptr.Ptr > From and then Errors.Table (E).Sptr.Ptr < To then - if Errors.Table (E).Warn or else Errors.Table (E).Style then - Warnings_Detected := Warnings_Detected - 1; - - else - Total_Errors_Detected := Total_Errors_Detected - 1; - - if Errors.Table (E).Serious then - Serious_Errors_Detected := Serious_Errors_Detected - 1; - end if; - end if; + Decrease_Error_Msg_Count (Errors.Table (E)); return True; diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 6c3b9da..dac4772 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -31,6 +31,19 @@ with Types; use Types; package Erroutc is + type Error_Msg_Type is + (Error, -- Default value + Non_Serious_Error, + -- An error message that is not considered fatal an the analys of + -- the source file can resume. + Warning, + Style, -- A special kind of warning only triggered by a style check + Info, + Low_Check, -- A type of GNATProve Check messages + Medium_Check, -- A type of GNATProve Check messages + High_Check -- A type of GNATProve Check messages + ); + 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 @@ -63,34 +76,19 @@ package Erroutc is -- Set true to indicate that the current message originates from a -- Compile_Time_Warning or Compile_Time_Error pragma. - Is_Serious_Error : Boolean := False; - -- Set True for a serious error (i.e. any message that is not a warning - -- or style message, and that does not contain a | insertion character). - 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_Warning_Msg : Boolean := False; - -- Set True to indicate if current message is warning message (contains ? - -- or contains < and Error_Msg_Warn is True). - 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). + -- -gnatwE was given).. - Is_Info_Msg : Boolean := False; - -- Set True to indicate that the current message starts with the characters - -- "info: " and is to be treated as an information message. This string - -- will be prepended to the message and all its continuations. - - Is_Check_Msg : Boolean := False; - -- Set True to indicate that the current message starts with one of - -- "high: ", "medium: ", "low: " and is to be treated as a check message. + Error_Msg_Kind : Error_Msg_Type := Error; Warning_Msg_Char : String (1 .. 2); - -- Warning switch, valid only if Is_Warning_Msg is True + -- Diagnostics switch: -- " " -- ? or < appeared on its own in message -- "? " -- ?? or << appeared in message -- "x " -- ?x? or <x< appeared in message @@ -100,10 +98,6 @@ package Erroutc is -- In the case of the < sequences, this is set only if the message is -- actually a warning, i.e. if Error_Msg_Warn is True - Is_Style_Msg : Boolean := False; - -- Set True to indicate if the current message is a style message - -- (i.e. a message whose text starts with the characters "(style)"). - Kill_Message : Boolean := False; -- A flag used to kill weird messages (e.g. those containing uninterpreted -- implicit type references) if we have already seen at least one message @@ -230,15 +224,6 @@ package Erroutc is -- True if the message originates from a Compile_Time_Warning or -- Compile_Time_Error pragma - Warn : Boolean; - -- True if warning message - - Info : Boolean; - -- True if info message - - Check : Boolean; - -- True if check message - 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. @@ -250,12 +235,6 @@ package Erroutc is Warn_Chr : String (1 .. 2); -- See Warning_Msg_Char - Style : Boolean; - -- True if style message (starts with "(style)") - - Serious : Boolean; - -- True if serious error message (not a warning and no | character) - Uncond : Boolean; -- True if unconditional message (i.e. insertion character ! appeared) @@ -271,6 +250,8 @@ package Erroutc is Deleted : Boolean; -- If this flag is set, the message is not printed. This is used -- in the circuit for deleting duplicate/redundant error messages. + + Kind : Error_Msg_Type; end record; package Errors is new Table.Table ( @@ -472,6 +453,8 @@ package Erroutc is procedure dmsg (Id : Error_Msg_Id); -- Debugging routine to dump an error message + procedure Decrease_Error_Msg_Count (E : Error_Msg_Object); + 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. @@ -495,6 +478,9 @@ package Erroutc is -- Given an error message ID, 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); + -- Increase the error count for the given kind of error message + function Matches (S : String; P : String) return Boolean; -- Returns true if the String S matches the pattern P, which can contain -- wildcard chars (*). The entire pattern must match the entire string. @@ -533,19 +519,6 @@ package Erroutc is procedure Prescan_Message (Msg : String); -- Scans message text and sets the following variables: -- - -- Is_Warning_Msg is set True if Msg is a warning message (contains a - -- question mark character), and False otherwise. - -- - -- Is_Style_Msg is set True if Msg is a style message (starts with - -- "(style)") and False otherwise. - -- - -- Is_Info_Msg is set True if Msg is an information message (starts - -- with "info: ". Such messages must contain a ? sequence since they - -- are also considered to be warning messages, and get a tag. - -- - -- Is_Serious_Error is set to True unless the message is a warning or - -- style message or contains the character | (non-serious error). - -- -- Is_Unconditional_Msg is set True if the message contains the character -- ! and is otherwise set False. -- @@ -558,6 +531,17 @@ package Erroutc is -- Has_Insertion_Line is set True if the message contains the character # -- and is otherwise set False. -- + -- Error_Msg_Kind is set to one of the following values: + -- * Style - if the message starts with "(style)" + -- * Info - if the message starts with "info: " + -- * Warning - if the message contains a "?" and they + -- are neither Info or Style messages. + -- * Low_Check - if the message starts with "low: " + -- * Medium_Check - if the message starts with "medium: " + -- * High_Check - if the message starts with "high: " + -- * Non_Serious_Error - if the message contains "|" + -- * Error - otherwise + -- -- We need to know right away these aspects of a message, since we will -- test these values before doing the full error scan. -- diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb index 795b2f2..450be6b 100644 --- a/gcc/ada/errutil.adb +++ b/gcc/ada/errutil.adb @@ -66,8 +66,7 @@ package body Errutil is -- be one of the special insertion characters (see documentation in spec). -- Flag is the location at which the error is to be posted, which is used -- to determine whether or not the # insertion needs a file name. The - -- variables Msg_Buffer, Msglen, Is_Style_Msg, Is_Warning_Msg, and - -- Is_Unconditional_Msg are set on return. + -- variables Msg_Buffer, Msglen and Is_Unconditional_Msg are set on return. ------------------ -- Error_Msg_AP -- @@ -194,16 +193,13 @@ package body Errutil is -- Immediate return if warning message and warnings are suppressed. -- Note that style messages are not warnings for this purpose. - if Is_Warning_Msg and then Warnings_Suppressed (Sptr) /= No_String then + if Error_Msg_Kind = Warning + and then Warnings_Suppressed (Sptr) /= No_String + then Cur_Msg := No_Error_Msg; return; end if; - -- Warning, Style and Info attributes are mutually exclusive - - pragma Assert (Boolean'Pos (Is_Warning_Msg) + Boolean'Pos (Is_Info_Msg) + - Boolean'Pos (Is_Style_Msg) <= 1); - -- Otherwise build error message object for new message Errors.Append @@ -218,19 +214,15 @@ package body Errutil is Line => Get_Physical_Line_Number (Sptr), Col => Get_Column_Number (Sptr), Compile_Time_Pragma => Is_Compile_Time_Msg, - Warn => Is_Warning_Msg, - Info => Is_Info_Msg, - Check => Is_Check_Msg, Warn_Err => Warning_Mode = Treat_As_Error, Warn_Runtime_Raise => Is_Runtime_Raise, Warn_Chr => Warning_Msg_Char, - Style => Is_Style_Msg, - Serious => Is_Serious_Error, Uncond => Is_Unconditional_Msg, Msg_Cont => Continuation, - Deleted => False)); + Deleted => False, + Kind => Error_Msg_Kind)); - Cur_Msg := Errors.Last; + Cur_Msg := Errors.Last; Prev_Msg := No_Error_Msg; Next_Msg := First_Error_Msg; @@ -257,18 +249,14 @@ package body Errutil is -- 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 Errors.Table (Prev_Msg).Line = Errors.Table (Cur_Msg).Line + and then Errors.Table (Prev_Msg).Sfile = Errors.Table (Cur_Msg).Sfile 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 + 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. @@ -276,13 +264,8 @@ package body Errutil is -- 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 (Prev_Msg).Style) - or else - (Errors.Table (Cur_Msg).Warn - or else - Errors.Table (Cur_Msg).Style) + if Errors.Table (Prev_Msg).Kind not in Warning | Erroutc.Style + or else Errors.Table (Cur_Msg).Kind in Warning | Erroutc.Style then -- All tests passed, delete the message by simply returning -- without any further processing. @@ -310,27 +293,7 @@ package body Errutil is Errors.Table (Cur_Msg).Next := Next_Msg; - -- Bump appropriate statistics counts - - if Errors.Table (Cur_Msg).Info then - Info_Messages := Info_Messages + 1; - - elsif Errors.Table (Cur_Msg).Warn - or else Errors.Table (Cur_Msg).Style - then - Warnings_Detected := Warnings_Detected + 1; - - elsif Errors.Table (Cur_Msg).Check then - Check_Messages := Check_Messages + 1; - - else - Total_Errors_Detected := Total_Errors_Detected + 1; - - if Errors.Table (Cur_Msg).Serious then - Serious_Errors_Detected := Serious_Errors_Detected + 1; - end if; - end if; - + Increase_Error_Msg_Count (Errors.Table (Cur_Msg)); end Error_Msg; ----------------- |