From bc202b70061a5e8765d537d4222b25284b24361a Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 19 Nov 2004 11:56:53 +0100 Subject: [PATCH] errout.ads, errout.adb: (First_Sloc): New function * errout.ads, errout.adb: (First_Sloc): New function * par-ch5.adb (P_Condition): Check for redundant parens is now a style check (-gnatyx) instead of being included as a redundant construct warning. * sem_ch6.adb: Change name Style_Check_Subprogram_Order to Style_Check_Order_Subprograms. * style.ads, styleg.ads, styleg.adb, styleg-c.adb, stylesw.ads, stylesw.adb: Add Style_Check_Xtra_Parens * usage.adb: Add line for -gnatyx (check extra parens) * vms_data.ads: Add entry for STYLE_CHECKS=XTRA_PARENS => -gnatyx From-SVN: r90905 --- gcc/ada/errout.adb | 98 ++++++++++++++++++++++++-------------------- gcc/ada/errout.ads | 6 +++ gcc/ada/par-ch5.adb | 4 +- gcc/ada/sem_ch6.adb | 2 +- gcc/ada/style.ads | 5 +++ gcc/ada/styleg-c.adb | 4 +- gcc/ada/styleg.adb | 15 ++++++- gcc/ada/styleg.ads | 6 ++- gcc/ada/stylesw.ads | 13 ++++-- gcc/ada/usage.adb | 1 + gcc/ada/vms_data.ads | 4 +- 11 files changed, 100 insertions(+), 58 deletions(-) diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index ed5ad56745e..9751d2a2ceb 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -601,52 +601,8 @@ package body Errout is ----------------- procedure Error_Msg_F (Msg : String; N : Node_Id) is - SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N)); - SF : constant Source_Ptr := Source_First (SI); - F : Node_Id; - S : Source_Ptr; - begin - F := First_Node (N); - S := Sloc (F); - - -- The following circuit is a bit subtle. When we have parenthesized - -- expressions, then the Sloc will not record the location of the - -- paren, but we would like to post the flag on the paren. So what - -- we do is to crawl up the tree from the First_Node, adjusting the - -- Sloc value for any parentheses we know are present. Yes, we know - -- this circuit is not 100% reliable (e.g. because we don't record - -- all possible paren level valoues), but this is only for an error - -- message so it is good enough. - - Node_Loop : loop - Paren_Loop : for J in 1 .. Paren_Count (F) loop - - -- We don't look more than 12 characters behind the current - -- location, and in any case not past the front of the source. - - Search_Loop : for K in 1 .. 12 loop - exit Search_Loop when S = SF; - - if Source_Text (SI) (S - 1) = '(' then - S := S - 1; - exit Search_Loop; - - elsif Source_Text (SI) (S - 1) <= ' ' then - S := S - 1; - - else - exit Search_Loop; - end if; - end loop Search_Loop; - end loop Paren_Loop; - - exit Node_Loop when F = N; - F := Parent (F); - exit Node_Loop when Nkind (F) not in N_Subexpr; - end loop Node_Loop; - - Error_Msg_NEL (Msg, N, N, S); + Error_Msg_NEL (Msg, N, N, First_Sloc (N)); end Error_Msg_F; ------------------ @@ -1390,6 +1346,58 @@ package body Errout is return Earliest; end First_Node; + ---------------- + -- First_Sloc -- + ---------------- + + function First_Sloc (N : Node_Id) return Source_Ptr is + SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N)); + SF : constant Source_Ptr := Source_First (SI); + F : Node_Id; + S : Source_Ptr; + + begin + F := First_Node (N); + S := Sloc (F); + + -- The following circuit is a bit subtle. When we have parenthesized + -- expressions, then the Sloc will not record the location of the + -- paren, but we would like to post the flag on the paren. So what + -- we do is to crawl up the tree from the First_Node, adjusting the + -- Sloc value for any parentheses we know are present. Yes, we know + -- this circuit is not 100% reliable (e.g. because we don't record + -- all possible paren level valoues), but this is only for an error + -- message so it is good enough. + + Node_Loop : loop + Paren_Loop : for J in 1 .. Paren_Count (F) loop + + -- We don't look more than 12 characters behind the current + -- location, and in any case not past the front of the source. + + Search_Loop : for K in 1 .. 12 loop + exit Search_Loop when S = SF; + + if Source_Text (SI) (S - 1) = '(' then + S := S - 1; + exit Search_Loop; + + elsif Source_Text (SI) (S - 1) <= ' ' then + S := S - 1; + + else + exit Search_Loop; + end if; + end loop Search_Loop; + end loop Paren_Loop; + + exit Node_Loop when F = N; + F := Parent (F); + exit Node_Loop when Nkind (F) not in N_Subexpr; + end loop Node_Loop; + + return S; + end First_Sloc; ---------------- -- Initialize -- diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 5bf33115cdc..ffc44bd19b1 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -584,6 +584,12 @@ package Errout is -- Given a construct C, finds the first node in the construct, i.e. the -- one with the lowest Sloc value. This is useful in placing error msgs. + function First_Sloc (N : Node_Id) return Source_Ptr; + -- Given the node for an expression, return a source pointer value that + -- points to the start of the first token in the expression. In the case + -- where the expression is parenthesized, an attempt is made to include + -- the parentheses (i.e. to return the location of the initial paren). + procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) renames Erroutc.Purge_Messages; -- All error messages whose location is in the range From .. To (not diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index 71324884f77..6293ad6ba6b 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -1268,10 +1268,10 @@ package body Ch5 is -- Otherwise check for redundant parens else - if Warn_On_Redundant_Constructs + if Style_Check and then Paren_Count (Cond) > 0 then - Error_Msg_F ("redundant parentheses?", Cond); + Style.Check_Xtra_Parens (First_Sloc (Cond)); end if; -- And return the result diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 4b5d95153b6..58d7e53cb22 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -2978,7 +2978,7 @@ package body Sem_Ch6 is -- Check body in alpha order if this is option if Style_Check - and then Style_Check_Subprogram_Order + and then Style_Check_Order_Subprograms and then Nkind (N) = N_Subprogram_Body and then Comes_From_Source (N) and then In_Extended_Main_Source_Unit (N) diff --git a/gcc/ada/style.ads b/gcc/ada/style.ads index ac2d6296938..c7a46ed3e3b 100644 --- a/gcc/ada/style.ads +++ b/gcc/ada/style.ads @@ -169,6 +169,11 @@ package Style is renames Style_Inst.Check_Vertical_Bar; -- Called after scanning a vertical bar to check spacing + procedure Check_Xtra_Parens (Loc : Source_Ptr) + renames Style_Inst.Check_Xtra_Parens; + -- Called after scanning a conditional expression that has at least one + -- level of parentheses around the entire expression. + procedure No_End_Name (Name : Node_Id) renames Style_Inst.No_End_Name; -- Called if an END is encountered where a name is allowed but not present. diff --git a/gcc/ada/styleg-c.adb b/gcc/ada/styleg-c.adb index 99e3f09c7b9..bc1a13bc447 100644 --- a/gcc/ada/styleg-c.adb +++ b/gcc/ada/styleg-c.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -217,7 +217,7 @@ package body Styleg.C is procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is begin - if Style_Check_Subprogram_Order then + if Style_Check_Order_Subprograms then Error_Msg_N ("(style) subprogram body& not in alphabetical order", Name); end if; diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb index e382daffd78..91c807b1a07 100644 --- a/gcc/ada/styleg.adb +++ b/gcc/ada/styleg.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -28,7 +28,7 @@ -- checking rules. For documentation of these rules, see comments on the -- individual procedures. -with Casing; use Casing; +with Casing; use Casing; with Csets; use Csets; with Err_Vars; use Err_Vars; with Opt; use Opt; @@ -667,6 +667,17 @@ package body Styleg is end if; end Check_Vertical_Bar; + ----------------------- + -- Check_Xtra_Parens -- + ----------------------- + + procedure Check_Xtra_Parens (Loc : Source_Ptr) is + begin + if Style_Check_Xtra_Parens then + Error_Msg ("redundant parentheses?", Loc); + end if; + end Check_Xtra_Parens; + ---------------------------- -- Determine_Token_Casing -- ---------------------------- diff --git a/gcc/ada/styleg.ads b/gcc/ada/styleg.ads index 7f4e22b8b2d..bf5b1e144cd 100644 --- a/gcc/ada/styleg.ads +++ b/gcc/ada/styleg.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -132,6 +132,10 @@ package Styleg is procedure Check_Vertical_Bar; -- Called after scanning a vertical bar to check spacing + procedure Check_Xtra_Parens (Loc : Source_Ptr); + -- Called after scanning a conditional expression that has at least one + -- level of parentheses around the entire expression. + procedure No_End_Name (Name : Node_Id); -- Called if an END is encountered where a name is allowed but not present. -- The parameter is the node whose name is the name that is permitted in diff --git a/gcc/ada/stylesw.ads b/gcc/ada/stylesw.ads index 435b31b038a..d3c46def539 100644 --- a/gcc/ada/stylesw.ads +++ b/gcc/ada/stylesw.ads @@ -145,6 +145,11 @@ package Stylesw is -- zero (a value of zero resets it to False). If True, it activates -- checking the maximum nesting level against Style_Max_Nesting_Level. + Style_Check_Order_Subprograms : Boolean := False; + -- This can be set True by using the -gnatg or -gnatyo switch. If it + -- is True, then names of subprogram bodies must be in alphabetical + -- order (not taking casing into account). + Style_Check_Pragma_Casing : Boolean := False; -- This can be set True by using the -gnatg or -gnatyp switches. If -- it is True, then pragma names must use mixed case. @@ -216,10 +221,10 @@ package Stylesw is -- where horizontal tabs are permitted, a horizontal tab is acceptable -- for meeting the requirement for a space. - Style_Check_Subprogram_Order : Boolean := False; - -- This can be set True by using the -gnatg or -gnatyo switch. If it - -- is True, then names of subprogram bodies must be in alphabetical - -- order (not taking casing into account). + Style_Check_Xtra_Parens : Boolean := False; + -- This can be set True by using the -gnatg or -gnatyx switch. If true, + -- then it is not allowed to enclose entire conditional expressions + -- in parentheses (C style). Style_Max_Line_Length : Int := 0; -- Value used to check maximum line length. Gets reset as a result of diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 3e5d0b818e9..44d8df730e7 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -445,6 +445,7 @@ begin Write_Line (" r check casing for identifier references"); Write_Line (" s check separate subprogram specs present"); Write_Line (" t check token separation rules"); + Write_Line (" x check extra parens around conditionals"); -- Lines for -gnatyN switch diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 256aadcd96b..12b6734f573 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -1815,7 +1815,9 @@ package VMS_Data is "SPECS " & "-gnatys " & "TOKEN " & - "-gnatyt "; + "-gnatyt " & + "XTRA_PARENS " & + "-gnatyx "; -- /NOSTYLE_CHECKS (D) -- /STYLE_CHECKS[=(keyword,[...])] -- -- 2.30.2