diff options
Diffstat (limited to 'gcc/ada/erroutc.adb')
| -rw-r--r-- | gcc/ada/erroutc.adb | 461 |
1 files changed, 260 insertions, 201 deletions
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index c8de60d..14a11ff 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -225,49 +225,11 @@ package body Erroutc is ------------------------ function Compilation_Errors return Boolean is - Warnings_Count : constant Int := Warnings_Detected; begin - if Total_Errors_Detected /= 0 then - return True; - - elsif Warnings_Treated_As_Errors /= 0 then - return True; - - -- We should never treat warnings that originate from a - -- Compile_Time_Warning pragma as an error. Warnings_Count is the sum - -- of both "normal" and Compile_Time_Warning warnings. This means that - -- there are only one or more non-Compile_Time_Warning warnings when - -- Warnings_Count is greater than Count_Compile_Time_Pragma_Warnings. - - elsif Warning_Mode = Treat_As_Error - and then Warnings_Count > Count_Compile_Time_Pragma_Warnings - then - return True; - end if; - - return False; + return Total_Errors_Detected /= 0 + or else Warnings_Treated_As_Errors /= 0; end Compilation_Errors; - ---------------------------------------- - -- Count_Compile_Time_Pragma_Warnings -- - ---------------------------------------- - - function Count_Compile_Time_Pragma_Warnings return Int is - Result : Int := 0; - begin - for J in 1 .. Errors.Last loop - begin - if Errors.Table (J).Kind = Warning - and then Errors.Table (J).Compile_Time_Pragma - and then not Errors.Table (J).Deleted - then - Result := Result + 1; - end if; - end; - end loop; - return Result; - end Count_Compile_Time_Pragma_Warnings; - ------------------------------ -- Decrease_Error_Msg_Count -- ------------------------------ @@ -282,6 +244,10 @@ package body Erroutc is when Warning | Style => Warnings_Detected := Warnings_Detected - 1; + if E.Warn_Err /= None then + Warnings_Treated_As_Errors := Warnings_Treated_As_Errors - 1; + end if; + when High_Check | Medium_Check | Low_Check => Check_Messages := Check_Messages - 1; @@ -340,7 +306,7 @@ package body Erroutc is w (" Line = ", Int (E.Line)); w (" Col = ", Int (E.Col)); w (" Kind = ", E.Kind'Img); - w (" Warn_Err = ", E.Warn_Err); + w (" Warn_Err = ", E.Warn_Err'Img); w (" Warn_Chr = '" & E.Warn_Chr & '''); w (" Uncond = ", E.Uncond); w (" Msg_Cont = ", E.Msg_Cont); @@ -372,11 +338,16 @@ package body Erroutc is ------------------------ function Get_Warning_Option (Id : Error_Msg_Id) return String is - Is_Style : constant Boolean := Errors.Table (Id).Kind in Style; - Warn_Chr : constant String (1 .. 2) := Errors.Table (Id).Warn_Chr; + begin + return Get_Warning_Option (Errors.Table (Id)); + end Get_Warning_Option; + + function Get_Warning_Option (E : Error_Msg_Object) return String is + Is_Style : constant Boolean := E.Kind in Style; + Warn_Chr : constant String (1 .. 2) := E.Warn_Chr; begin - if Has_Switch_Tag (Errors.Table (Id)) + if Has_Switch_Tag (E) and then Warn_Chr (1) /= '?' then if Warn_Chr = "$ " then @@ -398,11 +369,16 @@ package body Erroutc is --------------------- function Get_Warning_Tag (Id : Error_Msg_Id) return String is - Warn_Chr : constant String (1 .. 2) := Errors.Table (Id).Warn_Chr; - Option : constant String := Get_Warning_Option (Id); + begin + return Get_Warning_Tag (Errors.Table (Id)); + end Get_Warning_Tag; + + function Get_Warning_Tag (E : Error_Msg_Object) return String is + Warn_Chr : constant String (1 .. 2) := E.Warn_Chr; + Option : constant String := Get_Warning_Option (E); begin - if Has_Switch_Tag (Id) then + if Has_Switch_Tag (E) then if Warn_Chr = "? " then return "[enabled by default]"; elsif Warn_Chr = "* " then @@ -429,6 +405,24 @@ package body Erroutc is when Warning | Style => Warnings_Detected := Warnings_Detected + 1; + if E.Warn_Err /= None then + Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1; + + -- Propagate Warn_Err to all of the preceeding continuation + -- messages and the main message. + + for J in reverse 1 .. Errors.Last loop + if Errors.Table (J).Warn_Err = None then + Errors.Table (J).Warn_Err := E.Warn_Err; + + Warnings_Treated_As_Errors := + Warnings_Treated_As_Errors + 1; + end if; + + exit when not Errors.Table (J).Msg_Cont; + end loop; + end if; + when High_Check | Medium_Check | Low_Check => Check_Messages := Check_Messages + 1; @@ -491,6 +485,134 @@ package body Erroutc is E_Msg.Kind in Warning | Info | Style and then E_Msg.Warn_Chr /= " "; end Has_Switch_Tag; + -------------------- + -- Next_Error_Msg -- + -------------------- + + procedure Next_Error_Msg (E : in out Error_Msg_Id) is + begin + loop + E := Errors.Table (E).Next; + exit when E = No_Error_Msg; + exit when not Errors.Table (E).Deleted + and then not Errors.Table (E).Msg_Cont; + end loop; + end Next_Error_Msg; + + --------------------------- + -- Next_Continuation_Msg -- + --------------------------- + + procedure Next_Continuation_Msg (E : in out Error_Msg_Id) is + begin + E := Errors.Table (E).Next; + + if E = No_Error_Msg or else not Errors.Table (E).Msg_Cont then + E := No_Error_Msg; + end if; + end Next_Continuation_Msg; + + ---------------------- + -- Primary_Location -- + ---------------------- + + function Primary_Location (E : Error_Msg_Object) return Labeled_Span_Id is + L : Labeled_Span_Id; + begin + L := E.Locations; + while L /= No_Labeled_Span loop + if Locations.Table (L).Is_Primary then + return L; + end if; + + L := Locations.Table (L).Next; + end loop; + + return No_Labeled_Span; + end Primary_Location; + + ------------------ + -- Get_Human_Id -- + ------------------ + + function Get_Human_Id (E : Error_Msg_Object) return String_Ptr is + begin + if E.Switch = No_Switch_Id then + return Diagnostic_Entries (E.Id).Human_Id; + else + return Get_Switch (E).Human_Id; + end if; + end Get_Human_Id; + + -------------------- + -- Get_Doc_Switch -- + -------------------- + + function Get_Doc_Switch (E : Error_Msg_Object) return String is + begin + if Warning_Doc_Switch + and then E.Warn_Chr /= " " + and then E.Kind in Info + | Style + | Warning + then + if E.Switch = No_Switch_Id then + if E.Warn_Chr = "* " then + return "[restriction warning]"; + + -- Info messages can have a switch tag but they should not have + -- a default switch tag. + + elsif E.Kind /= Info then + + -- For Default_Warning + + return "[enabled by default]"; + end if; + else + declare + S : constant Switch_Type := Get_Switch (E); + begin + return "[-" & S.Short_Name.all & "]"; + end; + end if; + end if; + + return ""; + end Get_Doc_Switch; + + ---------------- + -- Get_Switch -- + ---------------- + + function Get_Switch (E : Error_Msg_Object) return Switch_Type is + begin + return Get_Switch (E.Switch); + end Get_Switch; + + ------------------- + -- Get_Switch_Id -- + ------------------- + + function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id is + begin + return Get_Switch_Id (E.Kind, E.Warn_Chr); + end Get_Switch_Id; + + function Get_Switch_Id + (Kind : Error_Msg_Type; Warn_Chr : String) return Switch_Id is + begin + if Warn_Chr = "$ " then + return Get_Switch_Id ("gnatel"); + elsif Kind in Warning | Info then + return Get_Switch_Id ("gnatw" & Warn_Chr); + elsif Kind = Style then + return Get_Switch_Id ("gnaty" & Warn_Chr); + else + return No_Switch_Id; + end if; + end Get_Switch_Id; + ------------- -- Matches -- ------------- @@ -752,7 +874,7 @@ package body Erroutc is -- Output_Text_Within -- ------------------------ - procedure Output_Text_Within (Txt : String_Ptr; Line_Length : Nat) is + procedure Output_Text_Within (Txt : String; Line_Length : Nat) is Offs : constant Nat := Column - 1; -- Offset to start of message, used for continuations @@ -869,98 +991,59 @@ package body Erroutc is procedure Output_Msg_Text (E : Error_Msg_Id) is - E_Msg : Error_Msg_Object renames Errors.Table (E); - Text : constant String_Ptr := E_Msg.Text; - Tag : constant String := Get_Warning_Tag (E); - Txt : String_Ptr; - - Line_Length : constant Nat := + E_Msg : Error_Msg_Object renames Errors.Table (E); + Text : constant String_Ptr := E_Msg.Text; + Tag : constant String := Get_Warning_Tag (E); + SGR_Code : constant String := Get_SGR_Code (E_Msg); + Kind_Prefix : constant String := + (if E_Msg.Kind = Style then Style_Prefix + else Kind_To_String (E_Msg) & ": "); + Buf : Bounded_String (Max_Msg_Length); + Line_Length : constant Nat := (if Error_Msg_Line_Length = 0 then Nat'Last else Error_Msg_Line_Length); begin - -- Postfix warning tag to message if needed - - if Tag /= "" and then Warning_Doc_Switch then - Txt := new String'(Text.all & ' ' & Tag); - else - Txt := Text; + -- Prefix with "error:" rather than warning. + -- Additionally include the style suffix when needed. + + if E_Msg.Warn_Err in From_Pragma | From_Run_Time_As_Err then + Append + (Buf, + SGR_Error & "error: " & SGR_Reset & + (if E_Msg.Kind = Style then Style_Prefix else "")); + + -- Print the message kind prefix + -- * Info/Style/Warning messages + -- * Check messages that are not continuations in the pretty printer + -- * Error messages when error tags are allowed + + elsif E_Msg.Kind in Info | Style | Warning + or else + (E_Msg.Kind in High_Check | Medium_Check | Low_Check + and then not (E_Msg.Msg_Cont and then Debug_Flag_FF)) + or else + (E_Msg.Kind in Error | Non_Serious_Error + and then Opt.Unique_Error_Tag) + then + Append (Buf, SGR_Code & Kind_Prefix & SGR_Reset); end if; - -- If -gnatdF is used, continuation messages follow the main message - -- with only an indentation of two space characters, without repeating - -- any prefix. - - if Debug_Flag_FF and then E_Msg.Msg_Cont then - null; - - -- For info messages, prefix message with "info: " - - elsif E_Msg.Kind = Info then - Txt := new String'(SGR_Note & "info: " & SGR_Reset & Txt.all); - - -- Warning treated as error - - elsif E_Msg.Warn_Err then - - -- We prefix with "error:" rather than warning: and postfix - -- [warning-as-error] at the end. - - Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1; - Txt := new String'(SGR_Error & "error: " & SGR_Reset - & Txt.all & " [warning-as-error]"); - - -- Normal warning, prefix with "warning: " - - 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.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)); - end if; - - -- No prefix needed for check message, severity is there already - - elsif E_Msg.Kind in High_Check | Medium_Check | Low_Check then - - -- The message format is "severity: ..." - -- - -- Enclose the severity with an SGR control string if requested + Append (Buf, Text.all); - if Use_SGR_Control then - declare - Msg : String renames Text.all; - Colon : Natural := 0; - begin - -- Find first colon - - for J in Msg'Range loop - if Msg (J) = ':' then - Colon := J; - exit; - end if; - end loop; - - pragma Assert (Colon > 0); + -- Postfix warning tag to message if needed - Txt := new String'(SGR_Error - & Msg (Msg'First .. Colon) - & SGR_Reset - & Msg (Colon + 1 .. Msg'Last)); - end; - end if; + if Tag /= "" and then Warning_Doc_Switch then + Append (Buf, ' ' & Tag); + end if; - -- All other cases, add "error: " if unique error tag set + -- Postfix [warning-as-error] at the end - elsif Opt.Unique_Error_Tag then - Txt := new String'(SGR_Error & "error: " & SGR_Reset & Txt.all); + if E_Msg.Warn_Err = From_Pragma then + Append (Buf, " " & Warn_As_Err_Tag); end if; - Output_Text_Within (Txt, Line_Length); + Output_Text_Within (To_String (Buf), Line_Length); end Output_Msg_Text; --------------------- @@ -1051,41 +1134,51 @@ package body Erroutc is Error_Msg_Kind := Error; Is_Unconditional_Msg := False; - Is_Runtime_Raise := False; + Is_Runtime_Raise_Msg := False; Warning_Msg_Char := " "; -- Check style message - if Msg'Length > 7 - and then Msg (Msg'First .. Msg'First + 6) = "(style)" + if Msg'Length > Style_Prefix'Length + and then + Msg (Msg'First .. Msg'First + Style_Prefix'Length - 1) = + Style_Prefix then Error_Msg_Kind := Style; -- Check info message - elsif Msg'Length > 6 - and then Msg (Msg'First .. Msg'First + 5) = "info: " + elsif Msg'Length > Info_Prefix'Length + and then + Msg (Msg'First .. Msg'First + Info_Prefix'Length - 1) = + Info_Prefix then Error_Msg_Kind := Info; -- Check high check message - elsif Msg'Length > 6 - and then Msg (Msg'First .. Msg'First + 5) = "high: " + elsif Msg'Length > High_Prefix'Length + and then + Msg (Msg'First .. Msg'First + High_Prefix'Length - 1) = + High_Prefix then Error_Msg_Kind := High_Check; -- Check medium check message - elsif Msg'Length > 8 - and then Msg (Msg'First .. Msg'First + 7) = "medium: " + elsif Msg'Length > Medium_Prefix'Length + and then + Msg (Msg'First .. Msg'First + Medium_Prefix'Length - 1) = + Medium_Prefix then Error_Msg_Kind := Medium_Check; -- Check low check message - elsif Msg'Length > 5 - and then Msg (Msg'First .. Msg'First + 4) = "low: " + elsif Msg'Length > Low_Prefix'Length + and then + Msg (Msg'First .. Msg'First + Low_Prefix'Length - 1) = + Low_Prefix then Error_Msg_Kind := Low_Check; end if; @@ -1211,6 +1304,8 @@ package body Erroutc is E := First_Error_Msg; while E /= No_Error_Msg loop while To_Be_Purged (Errors.Table (E).Next) loop + Errors.Table (Errors.Table (E).Next).Deleted := True; + Errors.Table (E).Next := Errors.Table (Errors.Table (E).Next).Next; end loop; @@ -2004,6 +2099,14 @@ package body Erroutc is return False; end Warning_Treated_As_Error; + function Warning_Treated_As_Error (E : Error_Msg_Object) return Boolean is + + begin + return + Warning_Treated_As_Error (E.Text.all) + or else Warning_Treated_As_Error (Get_Warning_Tag (E)); + end Warning_Treated_As_Error; + ------------------------- -- Warnings_Suppressed -- ------------------------- @@ -2080,76 +2183,32 @@ package body Erroutc is Write_Str (" errors"); end if; - -- We now need to output warnings. When using -gnatwe, all warnings - -- should be treated as errors, except for warnings originating from - -- the use of the Compile_Time_Warning pragma. Another situation - -- where a warning might be treated as an error is when the source - -- code contains a Warning_As_Error pragma. - -- When warnings are treated as errors, we still log them as - -- warnings, but we add a message denoting how many of these warnings - -- are also errors. - - declare - Warnings_Count : constant Int := Warnings_Detected; - - Compile_Time_Warnings : Int; - -- Number of warnings that come from a Compile_Time_Warning - -- pragma. + if Warnings_Detected > 0 then + Write_Str (", "); + Write_Int (Warnings_Detected); + Write_Str (" warning"); - Non_Compile_Time_Warnings : Int; - -- Number of warnings that do not come from a Compile_Time_Warning - -- pragmas. + if Warnings_Detected > 1 then + Write_Char ('s'); + end if; - begin - if Warnings_Count > 0 then - Write_Str (", "); - Write_Int (Warnings_Count); - Write_Str (" warning"); + if Warnings_Treated_As_Errors > 0 then + Write_Str (" ("); - if Warnings_Count > 1 then - Write_Char ('s'); + if Warnings_Treated_As_Errors /= Warnings_Detected then + Write_Int (Warnings_Treated_As_Errors); + Write_Str (" "); end if; - Compile_Time_Warnings := Count_Compile_Time_Pragma_Warnings; - Non_Compile_Time_Warnings := - Warnings_Count - Compile_Time_Warnings; - - if Warning_Mode = Treat_As_Error - and then Non_Compile_Time_Warnings > 0 - then - Write_Str (" ("); - - if Compile_Time_Warnings > 0 then - Write_Int (Non_Compile_Time_Warnings); - Write_Str (" "); - end if; - - Write_Str ("treated as error"); - - if Non_Compile_Time_Warnings > 1 then - Write_Char ('s'); - end if; + Write_Str ("treated as error"); - Write_Char (')'); - - elsif Warnings_Treated_As_Errors > 0 then - Write_Str (" ("); - - if Warnings_Treated_As_Errors /= Warnings_Count then - Write_Int (Warnings_Treated_As_Errors); - Write_Str (" "); - end if; - - Write_Str ("treated as error"); - - if Warnings_Treated_As_Errors > 1 then - Write_Str ("s"); - end if; - - Write_Str (")"); + if Warnings_Treated_As_Errors > 1 then + Write_Str ("s"); end if; + + Write_Str (")"); end if; - end; + end if; if Info_Messages /= 0 then Write_Str (", "); |