Skip to content

R
riscv-gcc-1
Commit 2ede092b by Robert Dewar Committed by Arnaud Charlet
Options

checks.adb (Check_Needed): New procedure... 

2005-09-01  Robert Dewar  <dewar@adacore.com>

	* checks.adb (Check_Needed): New procedure, deals with removing checks
	based on analysis of short-circuited forms. Also generates warnings for
	improper use of non-short-circuited forms.
	Code clean ups.

From-SVN: r103857
parent 18605ccc
Showing with 215 additions and 177 deletions
gcc/ada/checks.adb
...@@ -218,6 +218,30 @@ package body Checks is ...@@ -218,6 +218,30 @@ package body Checks is
-- routine. The Do_Static flag indicates that only a static check is -- routine. The Do_Static flag indicates that only a static check is
-- to be done. -- to be done.
type Check_Type is (Access_Check, Division_Check);
function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean;
-- This function is used to see if an access or division by zero check is
-- needed. The check is to be applied to a single variable appearing in the
-- source, and N is the node for the reference. If N is not of this form,
-- True is returned with no further processing. If N is of the right form,
-- then further processing determines if the given Check is needed.
--
-- The particular circuit is to see if we have the case of a check that is
-- not needed because it appears in the right operand of a short circuited
-- conditional where the left operand guards the check. For example:
--
-- if Var = 0 or else Q / Var > 12 then
-- ...
-- end if;
--
-- In this example, the division check is not required. At the same time
-- we can issue warnings for suspicious use of non-short-circuited forms,
-- such as:
--
-- if Var = 0 or Q / Var > 12 then
-- ...
-- end if;
procedure Find_Check procedure Find_Check
(Expr : Node_Id; (Expr : Node_Id;
Check_Type : Character; Check_Type : Character;
...@@ -254,10 +278,6 @@ package body Checks is ...@@ -254,10 +278,6 @@ package body Checks is
-- that the access value is non-null, since the checks do not -- that the access value is non-null, since the checks do not
-- not apply to null access values. -- not apply to null access values.
procedure Install_Null_Excluding_Check (N : Node_Id);
-- Determines whether an access node requires a runtime access check and
-- if so inserts the appropriate run-time check
procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr); procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr);
-- Called by Apply_{Length,Range}_Checks to rewrite the tree with the -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
-- Constraint_Error node. -- Constraint_Error node.
...@@ -387,6 +407,11 @@ package body Checks is ...@@ -387,6 +407,11 @@ package body Checks is
elsif not Expander_Active then elsif not Expander_Active then
return; return;
-- We do not need checks if not needed because of short circuiting
elsif not Check_Needed (P, Access_Check) then
return;
end if; end if;
-- Case where P is an entity name -- Case where P is an entity name
...@@ -1360,7 +1385,8 @@ package body Checks is ...@@ -1360,7 +1385,8 @@ package body Checks is
begin begin
if Expander_Active if Expander_Active
and not Backend_Divide_Checks_On_Target and then not Backend_Divide_Checks_On_Target
and then Check_Needed (Right, Division_Check)
then then
Determine_Range (Right, ROK, Rlo, Rhi); Determine_Range (Right, ROK, Rlo, Rhi);
...@@ -1382,7 +1408,6 @@ package body Checks is ...@@ -1382,7 +1408,6 @@ package body Checks is
-- Test for extremely annoying case of xxx'First divided by -1 -- Test for extremely annoying case of xxx'First divided by -1
if Do_Overflow_Check (N) then if Do_Overflow_Check (N) then
if Nkind (N) = N_Op_Divide if Nkind (N) = N_Op_Divide
and then Is_Signed_Integer_Type (Typ) and then Is_Signed_Integer_Type (Typ)
then then
...@@ -2420,6 +2445,121 @@ package body Checks is ...@@ -2420,6 +2445,121 @@ package body Checks is
return Cond; return Cond;
end Build_Discriminant_Checks; end Build_Discriminant_Checks;
------------------
-- Check_Needed --
------------------
function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean is
N : Node_Id;
P : Node_Id;
K : Node_Kind;
L : Node_Id;
R : Node_Id;
begin
-- Always check if not simple entity
if Nkind (Nod) not in N_Has_Entity
or else not Comes_From_Source (Nod)
then
return True;
end if;
-- Look up tree for short circuit
N := Nod;
loop
P := Parent (N);
K := Nkind (P);
if K not in N_Subexpr then
return True;
-- Or/Or Else case, left operand must be equality test
elsif K = N_Op_Or or else K = N_Or_Else then
exit when N = Right_Opnd (P)
and then Nkind (Left_Opnd (P)) = N_Op_Eq;
-- And/And then case, left operand must be inequality test. Note that
-- at this stage, the expander will have changed a/=b to not (a=b).
elsif K = N_Op_And or else K = N_And_Then then
exit when N = Right_Opnd (P)
and then Nkind (Left_Opnd (P)) = N_Op_Not
and then Nkind (Right_Opnd (Left_Opnd (P))) = N_Op_Eq;
end if;
N := P;
end loop;
-- If we fall through the loop, then we have a conditional with an
-- appropriate test as its left operand. So test further.
L := Left_Opnd (P);
if Nkind (L) = N_Op_Not then
L := Right_Opnd (L);
end if;
R := Right_Opnd (L);
L := Left_Opnd (L);
-- Left operand of test must match original variable
if Nkind (L) not in N_Has_Entity
or else Entity (L) /= Entity (Nod)
then
return True;
end if;
-- Right operand of test mus be key value (zero or null)
case Check is
when Access_Check =>
if Nkind (R) /= N_Null then
return True;
end if;
when Division_Check =>
if not Compile_Time_Known_Value (R)
or else Expr_Value (R) /= Uint_0
then
return True;
end if;
end case;
-- Here we have the optimizable case, warn if not short-circuited
if K = N_Op_And or else K = N_Op_Or then
case Check is
when Access_Check =>
Error_Msg_N
("Constraint_Error may be raised (access check)?",
Parent (Nod));
when Division_Check =>
Error_Msg_N
("Constraint_Error may be raised (zero divide)?",
Parent (Nod));
end case;
if K = N_Op_And then
Error_Msg_N ("use `AND THEN` instead of AND?", P);
else
Error_Msg_N ("use `OR ELSE` instead of OR?", P);
end if;
-- If not short-circuited, we need the ckeck
return True;
-- If short-circuited, we can omit the check
else
return False;
end if;
end Check_Needed;
----------------------------------- -----------------------------------
-- Check_Valid_Lvalue_Subscripts -- -- Check_Valid_Lvalue_Subscripts --
----------------------------------- -----------------------------------
...@@ -2467,222 +2607,120 @@ package body Checks is ...@@ -2467,222 +2607,120 @@ package body Checks is
Related_Nod : Node_Id; Related_Nod : Node_Id;
Has_Null_Exclusion : Boolean := False; Has_Null_Exclusion : Boolean := False;
type Msg_Kind is (Components, Formals, Objects); begin
Msg_K : Msg_Kind := Objects; pragma Assert (K = N_Parameter_Specification
-- Used by local subprograms to generate precise error messages or else K = N_Object_Declaration
or else K = N_Discriminant_Specification
procedure Check_Must_Be_Access or else K = N_Component_Declaration);
(Typ : Entity_Id;
Has_Null_Exclusion : Boolean);
-- ??? local subprograms must have comment on spec
procedure Check_Already_Null_Excluding_Type Typ := Etype (Defining_Identifier (N));
(Typ : Entity_Id;
Has_Null_Exclusion : Boolean;
Related_Nod : Node_Id);
-- ??? local subprograms must have comment on spec
procedure Check_Must_Be_Initialized pragma Assert (Is_Access_Type (Typ)
(N : Node_Id; or else (K = N_Object_Declaration and then Is_Array_Type (Typ)));
Related_Nod : Node_Id);
-- ??? local subprograms must have comment on spec
procedure Check_Null_Not_Allowed (N : Node_Id); case K is
-- ??? local subprograms must have comment on spec when N_Parameter_Specification =>
Related_Nod := Parameter_Type (N);
Has_Null_Exclusion := Null_Exclusion_Present (N);
-- ??? following bodies lack comments when N_Object_Declaration =>
Related_Nod := Object_Definition (N);
Has_Null_Exclusion := Null_Exclusion_Present (N);
-------------------------- when N_Discriminant_Specification =>
-- Check_Must_Be_Access -- Related_Nod := Discriminant_Type (N);
-------------------------- Has_Null_Exclusion := Null_Exclusion_Present (N);
procedure Check_Must_Be_Access when N_Component_Declaration =>
(Typ : Entity_Id; if Present (Access_Definition (Component_Definition (N))) then
Has_Null_Exclusion : Boolean) Related_Nod := Component_Definition (N);
is Has_Null_Exclusion :=
begin Null_Exclusion_Present
if Has_Null_Exclusion (Access_Definition (Component_Definition (N)));
and then not Is_Access_Type (Typ) else
then Related_Nod :=
Error_Msg_N ("(Ada 2005) must be an access type", Related_Nod); Subtype_Indication (Component_Definition (N));
Has_Null_Exclusion :=
Null_Exclusion_Present (Component_Definition (N));
end if; end if;
end Check_Must_Be_Access;
--------------------------------------- when others =>
-- Check_Already_Null_Excluding_Type -- raise Program_Error;
--------------------------------------- end case;
-- Enforce legality rule 3.10 (14/1): A null_exclusion is only allowed
-- of the access subtype does not exclude null.
procedure Check_Already_Null_Excluding_Type
(Typ : Entity_Id;
Has_Null_Exclusion : Boolean;
Related_Nod : Node_Id)
is
begin
if Has_Null_Exclusion if Has_Null_Exclusion
and then Can_Never_Be_Null (Typ) and then Can_Never_Be_Null (Typ)
-- No need to check itypes that have the null-excluding attribute
-- because they were checked at their point of creation
and then not Is_Itype (Typ)
then then
Error_Msg_N Error_Msg_N
("(Ada 2005) already a null-excluding type", Related_Nod); ("(Ada 2005) already a null-excluding type", Related_Nod);
end if; end if;
end Check_Already_Null_Excluding_Type;
------------------------------- -- Check that null-excluding objects are always initialized
-- Check_Must_Be_Initialized --
-------------------------------
procedure Check_Must_Be_Initialized if K = N_Object_Declaration
(N : Node_Id; and then not Present (Expression (N))
Related_Nod : Node_Id) then
is -- Add a an expression that assignates null. This node is needed
Expr : constant Node_Id := Expression (N); -- by Apply_Compile_Time_Constraint_Error, that will replace this
-- node by a Constraint_Error node.
begin
pragma Assert (Nkind (N) = N_Component_Declaration
or else Nkind (N) = N_Object_Declaration);
if not Present (Expr) then Set_Expression (N, Make_Null (Sloc (N)));
case Msg_K is Set_Etype (Expression (N), Etype (Defining_Identifier (N)));
when Components =>
Error_Msg_N
("(Ada 2005) null-excluding components must be " &
"initialized", Related_Nod);
when Formals => Apply_Compile_Time_Constraint_Error
Error_Msg_N (N => Expression (N),
("(Ada 2005) null-excluding formals must be initialized", Msg => "(Ada 2005) null-excluding objects must be initialized?",
Related_Nod); Reason => CE_Null_Not_Allowed);
when Objects =>
Error_Msg_N
("(Ada 2005) null-excluding objects must be initialized",
Related_Nod);
end case;
end if; end if;
end Check_Must_Be_Initialized;
---------------------------- -- Check that the null value is not used as a single expression to
-- Check_Null_Not_Allowed -- -- assignate a value to a null-excluding component, formal or object;
---------------------------- -- otherwise generate a warning message at the sloc of Related_Nod and
-- replace Expression (N) by an N_Contraint_Error node.
procedure Check_Null_Not_Allowed (N : Node_Id) is declare
Expr : constant Node_Id := Expression (N); Expr : constant Node_Id := Expression (N);
begin begin
if Present (Expr) if Present (Expr)
and then Nkind (Expr) = N_Null and then Nkind (Expr) = N_Null
then then
case Msg_K is case K is
when Components => when N_Discriminant_Specification |
N_Component_Declaration =>
Apply_Compile_Time_Constraint_Error Apply_Compile_Time_Constraint_Error
(N => Expr, (N => Expr,
Msg => "(Ada 2005) NULL not allowed in" Msg => "(Ada 2005) NULL not allowed in"
& " null-excluding components?", & " null-excluding components?",
Reason => CE_Null_Not_Allowed, Reason => CE_Null_Not_Allowed);
Rep => False);
when Formals => when N_Parameter_Specification =>
Apply_Compile_Time_Constraint_Error Apply_Compile_Time_Constraint_Error
(N => Expr, (N => Expr,
Msg => "(Ada 2005) NULL not allowed in" Msg => "(Ada 2005) NULL not allowed in"
& " null-excluding formals?", & " null-excluding formals?",
Reason => CE_Null_Not_Allowed, Reason => CE_Null_Not_Allowed);
Rep => False);
when Objects => when N_Object_Declaration =>
Apply_Compile_Time_Constraint_Error Apply_Compile_Time_Constraint_Error
(N => Expr, (N => Expr,
Msg => "(Ada 2005) NULL not allowed in" Msg => "(Ada 2005) NULL not allowed in"
& " null-excluding objects?", & " null-excluding objects?",
Reason => CE_Null_Not_Allowed, Reason => CE_Null_Not_Allowed);
Rep => False);
end case;
end if;
end Check_Null_Not_Allowed;
-- Start of processing for Null_Exclusion_Static_Checks
begin
pragma Assert (K = N_Component_Declaration
or else K = N_Parameter_Specification
or else K = N_Object_Declaration
or else K = N_Discriminant_Specification
or else K = N_Allocator);
case K is
when N_Component_Declaration =>
Msg_K := Components;
if not Present (Access_Definition (Component_Definition (N))) then
Has_Null_Exclusion := Null_Exclusion_Present
(Component_Definition (N));
Typ := Etype (Subtype_Indication (Component_Definition (N)));
Related_Nod := Subtype_Indication (Component_Definition (N));
Check_Must_Be_Access (Typ, Has_Null_Exclusion);
Check_Already_Null_Excluding_Type
(Typ, Has_Null_Exclusion, Related_Nod);
Check_Must_Be_Initialized (N, Related_Nod);
end if;
Check_Null_Not_Allowed (N);
when N_Parameter_Specification =>
Msg_K := Formals;
Has_Null_Exclusion := Null_Exclusion_Present (N);
Typ := Entity (Parameter_Type (N));
Related_Nod := Parameter_Type (N);
Check_Must_Be_Access (Typ, Has_Null_Exclusion);
Check_Already_Null_Excluding_Type
(Typ, Has_Null_Exclusion, Related_Nod);
Check_Null_Not_Allowed (N);
when N_Object_Declaration =>
Msg_K := Objects;
if Nkind (Object_Definition (N)) /= N_Access_Definition then
Has_Null_Exclusion := Null_Exclusion_Present (N);
Typ := Entity (Object_Definition (N));
Related_Nod := Object_Definition (N);
Check_Must_Be_Access (Typ, Has_Null_Exclusion);
Check_Already_Null_Excluding_Type
(Typ, Has_Null_Exclusion, Related_Nod);
Check_Must_Be_Initialized (N, Related_Nod);
end if;
Check_Null_Not_Allowed (N);
when N_Discriminant_Specification =>
Msg_K := Components;
if Nkind (Discriminant_Type (N)) /= N_Access_Definition then
Has_Null_Exclusion := Null_Exclusion_Present (N);
Typ := Etype (Defining_Identifier (N));
Related_Nod := Discriminant_Type (N);
Check_Must_Be_Access (Typ, Has_Null_Exclusion);
Check_Already_Null_Excluding_Type
(Typ, Has_Null_Exclusion, Related_Nod);
end if;
Check_Null_Not_Allowed (N);
when N_Allocator =>
Msg_K := Objects;
Has_Null_Exclusion := Null_Exclusion_Present (N);
Typ := Etype (Expression (N));
if Nkind (Expression (N)) = N_Qualified_Expression then
Related_Nod := Subtype_Mark (Expression (N));
else
Related_Nod := Expression (N);
end if;
Check_Must_Be_Access (Typ, Has_Null_Exclusion);
Check_Already_Null_Excluding_Type
(Typ, Has_Null_Exclusion, Related_Nod);
Check_Null_Not_Allowed (N);
when others => when others =>
raise Program_Error; null;
end case; end case;
end if;
end;
end Null_Exclusion_Static_Checks; end Null_Exclusion_Static_Checks;
---------------------------------- ----------------------------------
......
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