From b54fd57a1b3429542286c3bea7c38cce931064f7 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 19 Jan 2023 08:43:47 +0000 Subject: ada: Add tags on style messages Similar to tags on warnings [-gnatwx], we add tags on style messages [-gnatyx] when -gnatw.d is enabled. gcc/ada/ * errout.ads: Update comment. * errout.adb (Skip_Msg_Insertion_Warning): Update to take e.g. -gnatyM into account. * erroutc.adb (Get_Warning_Option, Get_Warning_Tag) (Prescan_Message): Add support for Style tags. * par-ch5.adb, par-ch6.adb, par-ch7.adb, par-endh.adb, par-util.adb, style.adb, styleg.adb: Set tag on all style messages. --- gcc/ada/errout.adb | 3 ++- gcc/ada/errout.ads | 6 +++--- gcc/ada/erroutc.adb | 37 ++++++++++++++++++++------------ gcc/ada/par-ch5.adb | 4 ++-- gcc/ada/par-ch6.adb | 2 +- gcc/ada/par-ch7.adb | 2 +- gcc/ada/par-endh.adb | 2 +- gcc/ada/par-util.adb | 4 ++-- gcc/ada/style.adb | 18 ++++++++-------- gcc/ada/styleg.adb | 59 ++++++++++++++++++++++++++-------------------------- 10 files changed, 75 insertions(+), 62 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 96b56ff..49281fd 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -3976,7 +3976,8 @@ package body Errout is P := P + 1; elsif P < Text'Last and then Text (P + 1) = C - and then Text (P) in 'a' .. 'z' | '*' | '$' + and then Text (P) in 'a' .. 'z' | 'A' .. 'Z' | + '0' .. '9' | '*' | '$' then P := P + 2; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 1e09961..f152839 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -307,9 +307,9 @@ package Errout is -- Insertion character ?x? ?.x? ?_x? (warning with switch) -- "x" is a (lower-case) warning switch character. -- Like ??, but if the flag Warn_Doc_Switch is True, adds the string - -- "[-gnatwx]", "[-gnatw.x]", or "[-gnatw_x]", at the end of the - -- warning message. For continuations, use this on each continuation - -- message. + -- "[-gnatwx]", "[-gnatw.x]", "[-gnatw_x]", or "[-gnatyx]" (for style + -- messages), at the end of the warning message. For continuations, use + -- this on each continuation message. -- Insertion character ?*? (restriction warning) -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 291a340..e5caeba 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -367,17 +367,25 @@ package body Erroutc is function Get_Warning_Option (Id : Error_Msg_Id) return String is Warn : constant Boolean := Errors.Table (Id).Warn; + Style : constant Boolean := Errors.Table (Id).Style; Warn_Chr : constant String (1 .. 2) := Errors.Table (Id).Warn_Chr; + begin - if Warn and then Warn_Chr /= " " and then Warn_Chr (1) /= '?' then + if (Warn or Style) + and then Warn_Chr /= " " + and then Warn_Chr (1) /= '?' + then if Warn_Chr = "$ " then return "-gnatel"; + elsif Style then + return "-gnaty" & Warn_Chr (1); elsif Warn_Chr (2) = ' ' then return "-gnatw" & Warn_Chr (1); else return "-gnatw" & Warn_Chr; end if; end if; + return ""; end Get_Warning_Option; @@ -387,10 +395,12 @@ package body Erroutc is function Get_Warning_Tag (Id : Error_Msg_Id) return String is Warn : constant Boolean := Errors.Table (Id).Warn; + Style : constant Boolean := Errors.Table (Id).Style; Warn_Chr : constant String (1 .. 2) := Errors.Table (Id).Warn_Chr; Option : constant String := Get_Warning_Option (Id); + begin - if Warn then + if Warn or Style then if Warn_Chr = "? " then return "[enabled by default]"; elsif Warn_Chr = "* " then @@ -880,7 +890,7 @@ package body Erroutc is J := J + 1; elsif J < Msg'Last and then Msg (J + 1) = C - and then Msg (J) in 'a' .. 'z' | '*' | '$' + and then Msg (J) in 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '*' | '$' then Message_Class := Msg (J) & " "; J := J + 2; @@ -964,19 +974,20 @@ package body Erroutc is -- Warning message (? or < insertion sequence) elsif Msg (J) = '?' or else Msg (J) = '<' then - Is_Warning_Msg := Msg (J) = '?' or else Error_Msg_Warn; - J := J + 1; - - if Is_Warning_Msg then + if Msg (J) = '?' or else Error_Msg_Warn then + Is_Warning_Msg := not Is_Style_Msg; + J := J + 1; Warning_Msg_Char := Parse_Message_Class; - end if; - -- Bomb if untagged warning message. This code can be uncommented - -- for debugging when looking for untagged warning messages. + -- Bomb if untagged warning message. This code can be + -- uncommented for debugging when looking for untagged warning + -- messages. + + -- pragma Assert (Warning_Msg_Char /= " "); - -- if Is_Warning_Msg and then Warning_Msg_Char = ' ' then - -- raise Program_Error; - -- end if; + else + J := J + 1; + end if; -- Unconditional message (! insertion) diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index 418547b..be821f7 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -1196,7 +1196,7 @@ package body Ch5 is and then Start_Column /= Scopes (Scope.Last).Ecol then Error_Msg_Col := Scopes (Scope.Last).Ecol; - Error_Msg_SC ("(style) this token should be@"); + Error_Msg_SC ("(style) this token should be@?l?"); end if; end Check_If_Column; @@ -2206,7 +2206,7 @@ package body Ch5 is and then Token_Is_At_Start_Of_Line and then Start_Column /= Error_Msg_Col then - Error_Msg_SC ("(style) BEGIN in wrong column, should be@"); + Error_Msg_SC ("(style) BEGIN in wrong column, should be@?l?"); else Scopes (Scope.Last).Ecol := Start_Column; diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 2de8cee9..3171c5c 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -1713,7 +1713,7 @@ package body Ch6 is if Style.Mode_In_Check and then Token /= Tok_Out then Error_Msg_SP -- CODEFIX - ("(style) IN should be omitted"); + ("(style) IN should be omitted?I?"); end if; -- Since Ada 2005, formal objects can have an anonymous access type, diff --git a/gcc/ada/par-ch7.adb b/gcc/ada/par-ch7.adb index ae02298..e8a765b 100644 --- a/gcc/ada/par-ch7.adb +++ b/gcc/ada/par-ch7.adb @@ -261,7 +261,7 @@ package body Ch7 is and then Start_Column /= Error_Msg_Col then Error_Msg_SC - ("(style) PRIVATE in wrong column, should be@"); + ("(style) PRIVATE in wrong column, should be@?l?"); end if; end if; diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb index 5ca5004..56275bf 100644 --- a/gcc/ada/par-endh.adb +++ b/gcc/ada/par-endh.adb @@ -1131,7 +1131,7 @@ package body Endh is then Error_Msg_Col := Scopes (Scope.Last).Ecol; Error_Msg - ("(style) END in wrong column, should be@", End_Sloc); + ("(style) END in wrong column, should be@?l?", End_Sloc); end if; end if; diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index b1085c8..fc44ddf 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -165,7 +165,7 @@ package body Util is and then Start_Column <= Scopes (Scope.Last).Ecol then Error_Msg_BC -- CODEFIX - ("(style) incorrect layout"); + ("(style) incorrect layout?l?"); end if; end Check_Bad_Layout; @@ -713,7 +713,7 @@ package body Util is and then Scope.Last = Style_Max_Nesting_Level + 1 then Error_Msg - ("(style) maximum nesting level exceeded", + ("(style) maximum nesting level exceeded?L?", First_Non_Blank_Location); end if; diff --git a/gcc/ada/style.adb b/gcc/ada/style.adb index dda5cd4..e21730b 100644 --- a/gcc/ada/style.adb +++ b/gcc/ada/style.adb @@ -67,7 +67,7 @@ package body Style is end; end if; - Error_Msg_N ("(style) subprogram body has no previous spec", N); + Error_Msg_N ("(style) subprogram body has no previous spec?s?", N); end if; end Body_With_No_Spec; @@ -84,11 +84,11 @@ package body Style is if Style_Check_Array_Attribute_Index then if D = 1 and then Present (E1) then Error_Msg_N -- CODEFIX - ("(style) index number not allowed for one dimensional array", + ("(style) index number not allowed for one dimensional array?A?", E1); elsif D > 1 and then No (E1) then Error_Msg_N -- CODEFIX - ("(style) index number required for multi-dimensional array", + ("(style) index number required for multi-dimensional array?A?", N); end if; end if; @@ -167,7 +167,7 @@ package body Style is Error_Msg_Node_1 := Def; Error_Msg_Sloc := Sloc (Def); Error_Msg -- CODEFIX - ("(style) bad casing of & declared#", Sref, Ref); + ("(style) bad casing of & declared#?r?", Sref, Ref); return; end if; @@ -249,7 +249,7 @@ package body Style is Set_Casing (Cas); Error_Msg_Name_1 := Name_Enter; Error_Msg_N -- CODEFIX - ("(style) bad casing of %% declared in Standard", Ref); + ("(style) bad casing of %% declared in Standard?n?", Ref); end if; end if; end if; @@ -293,16 +293,16 @@ package body Style is if Nkind (N) = N_Subprogram_Body then Error_Msg_NE -- CODEFIX - ("(style) missing OVERRIDING indicator in body of&", N, E); + ("(style) missing OVERRIDING indicator in body of&?O?", N, E); elsif Nkind (N) = N_Abstract_Subprogram_Declaration then Error_Msg_NE -- CODEFIX - ("(style) missing OVERRIDING indicator in declaration of&", + ("(style) missing OVERRIDING indicator in declaration of&?O?", Specification (N), E); else Error_Msg_NE -- CODEFIX - ("(style) missing OVERRIDING indicator in declaration of&", + ("(style) missing OVERRIDING indicator in declaration of&?O?", Nod, E); end if; end if; @@ -316,7 +316,7 @@ package body Style is begin if Style_Check_Order_Subprograms then Error_Msg_N -- CODEFIX - ("(style) subprogram body& not in alphabetical order", Name); + ("(style) subprogram body& not in alphabetical order?o?", Name); end if; end Subprogram_Not_In_Alpha_Order; end Style; diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb index 045842b..0bb406f 100644 --- a/gcc/ada/styleg.adb +++ b/gcc/ada/styleg.adb @@ -173,7 +173,7 @@ package body Styleg is if Style_Check_Attribute_Casing then if Determine_Token_Casing /= Mixed_Case then Error_Msg_SC -- CODEFIX - ("(style) bad capitalization, mixed case required"); + ("(style) bad capitalization, mixed case required?a?"); end if; end if; end Check_Attribute_Name; @@ -263,10 +263,10 @@ package body Styleg is elsif Nkind (Orig) = N_Op_And then Error_Msg -- CODEFIX - ("(style) `AND THEN` required", Sloc (Orig)); + ("(style) `AND THEN` required?B?", Sloc (Orig)); else Error_Msg -- CODEFIX - ("(style) `OR ELSE` required", Sloc (Orig)); + ("(style) `OR ELSE` required?B?", Sloc (Orig)); end if; end; end if; @@ -506,7 +506,7 @@ package body Styleg is and then Source (Scan_Ptr - 1) > ' ' then Error_Msg_S -- CODEFIX - ("(style) space required"); + ("(style) space required?c?"); end if; end if; @@ -520,7 +520,7 @@ package body Styleg is and then not Is_Special_Character (Source (Scan_Ptr + 2)) then Error_Msg -- CODEFIX - ("(style) space required", Scan_Ptr + 2); + ("(style) space required?c?", Scan_Ptr + 2); end if; end if; @@ -537,7 +537,7 @@ package body Styleg is and then not Same_Column_As_Previous_Line then Error_Msg_S -- CODEFIX - ("(style) bad column"); + ("(style) bad column?0?"); end if; return; @@ -583,7 +583,7 @@ package body Styleg is Error_Space_Required (Scan_Ptr + 2); else Error_Msg -- CODEFIX - ("(style) two spaces required", Scan_Ptr + 2); + ("(style) two spaces required?c?", Scan_Ptr + 2); end if; return; @@ -624,7 +624,7 @@ package body Styleg is | All_Upper_Case => Error_Msg_SC -- CODEFIX - ("(style) bad capitalization, mixed case required"); + ("(style) bad capitalization, mixed case required?D?"); -- The Unknown case is something like A_B_C, which is both all -- caps and mixed case. @@ -665,12 +665,12 @@ package body Styleg is if Blank_Lines = 2 then Error_Msg -- CODEFIX - ("(style) blank line not allowed at end of file", + ("(style) blank line not allowed at end of file?u?", Blank_Line_Location); elsif Blank_Lines >= 3 then Error_Msg -- CODEFIX - ("(style) blank lines not allowed at end of file", + ("(style) blank lines not allowed at end of file?u?", Blank_Line_Location); end if; end if; @@ -697,7 +697,7 @@ package body Styleg is begin if Style_Check_Horizontal_Tabs then Error_Msg_S -- CODEFIX - ("(style) horizontal tab not allowed"); + ("(style) horizontal tab not allowed?h?"); end if; end Check_HT; @@ -716,7 +716,7 @@ package body Styleg is and then Start_Column rem Style_Check_Indentation /= 0 then Error_Msg_SC -- CODEFIX - ("(style) bad indentation"); + ("(style) bad indentation?0?"); end if; end if; end Check_Indentation; @@ -755,7 +755,7 @@ package body Styleg is if Style_Check_Max_Line_Length then if Len > Style_Max_Line_Length then Error_Msg - ("(style) this line is too long", + ("(style) this line is too long?M?", Current_Line_Start + Source_Ptr (Style_Max_Line_Length)); end if; end if; @@ -792,10 +792,10 @@ package body Styleg is if Style_Check_Form_Feeds then if Source (Scan_Ptr) = ASCII.FF then Error_Msg_S -- CODEFIX - ("(style) form feed not allowed"); + ("(style) form feed not allowed?f?"); elsif Source (Scan_Ptr) = ASCII.VT then Error_Msg_S -- CODEFIX - ("(style) vertical tab not allowed"); + ("(style) vertical tab not allowed?f?"); end if; end if; @@ -813,7 +813,7 @@ package body Styleg is -- Bad terminator if we don't have an LF elsif Source (Scan_Ptr) /= LF then - Error_Msg_S ("(style) incorrect line terminator"); + Error_Msg_S ("(style) incorrect line terminator?d?"); end if; end if; @@ -829,7 +829,7 @@ package body Styleg is if Style_Check_Blanks_At_End and then L < Len then Error_Msg -- CODEFIX - ("(style) trailing spaces not permitted", S); + ("(style) trailing spaces not permitted?b?", S); end if; -- Deal with empty (blank) line @@ -851,7 +851,7 @@ package body Styleg is else if Style_Check_Blank_Lines and then Blank_Lines > 1 then Error_Msg -- CODEFIX - ("(style) multiple blank lines", Blank_Line_Location); + ("(style) multiple blank lines?u?", Blank_Line_Location); end if; -- And reset blank line count @@ -873,7 +873,8 @@ package body Styleg is or else Token_Ptr - Prev_Token_Ptr /= 4 then -- CODEFIX? Error_Msg - ("(style) single space must separate NOT and IN", Token_Ptr - 1); + ("(style) single space must separate NOT and IN?t?", + Token_Ptr - 1); end if; end if; end Check_Not_In; @@ -933,7 +934,7 @@ package body Styleg is if Style_Check_Pragma_Casing then if Determine_Token_Casing /= Mixed_Case then Error_Msg_SC -- CODEFIX - ("(style) bad capitalization, mixed case required"); + ("(style) bad capitalization, mixed case required?p?"); end if; end if; end Check_Pragma_Name; @@ -1043,10 +1044,10 @@ package body Styleg is else if Token = Tok_Then then Error_Msg -- CODEFIX - ("(style) no statements may follow THEN on same line", S); + ("(style) no statements may follow THEN on same line?S?", S); else Error_Msg - ("(style) no statements may follow ELSE on same line", S); + ("(style) no statements may follow ELSE on same line?S?", S); end if; end if; end Check_Separate_Stmt_Lines_Cont; @@ -1071,7 +1072,7 @@ package body Styleg is if If_Line = Then_Line then null; elsif Token_Ptr /= First_Non_Blank_Location then - Error_Msg_SC ("(style) misplaced THEN"); + Error_Msg_SC ("(style) misplaced THEN?i?"); end if; end; end if; @@ -1121,7 +1122,7 @@ package body Styleg is begin if Style_Check_Xtra_Parens then Error_Msg -- CODEFIX - ("(style) redundant parentheses", Loc); + ("(style) redundant parentheses?x?", Loc); end if; end Check_Xtra_Parens; @@ -1141,7 +1142,7 @@ package body Styleg is procedure Error_Space_Not_Allowed (S : Source_Ptr) is begin Error_Msg -- CODEFIX - ("(style) space not allowed", S); + ("(style) space not allowed?t?", S); end Error_Space_Not_Allowed; -------------------------- @@ -1151,7 +1152,7 @@ package body Styleg is procedure Error_Space_Required (S : Source_Ptr) is begin Error_Msg -- CODEFIX - ("(style) space required", S); + ("(style) space required?t?", S); end Error_Space_Required; -------------------- @@ -1184,7 +1185,7 @@ package body Styleg is if Style_Check_End_Labels then Error_Msg_Node_1 := Name; Error_Msg_SP -- CODEFIX - ("(style) `END &` required"); + ("(style) `END &` required?e?"); end if; end No_End_Name; @@ -1200,7 +1201,7 @@ package body Styleg is if Style_Check_End_Labels then Error_Msg_Node_1 := Name; Error_Msg_SP -- CODEFIX - ("(style) `EXIT &` required"); + ("(style) `EXIT &` required?e?"); end if; end No_Exit_Name; @@ -1216,7 +1217,7 @@ package body Styleg is begin if Style_Check_Keyword_Casing then Error_Msg_SC -- CODEFIX - ("(style) reserved words must be all lower case"); + ("(style) reserved words must be all lower case?k?"); end if; end Non_Lower_Case_Keyword; -- cgit v1.1