Skip to content

R
riscv-gcc-1
Commit bc202b70 by Arnaud Charlet
Options

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
parent 1d571f3b
Showing with 100 additions and 58 deletions
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 --
......
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
......
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
......
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)
......
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.
......
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;
......
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 --
----------------------------
......
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
......
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
......
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
......
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,[...])]
--
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment