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
This commit is contained in:
Robert Dewar
Arnaud Charlet
parent
18605ccc2b
commit
2ede092bd7
|
|
@ -218,6 +218,30 @@ package body Checks is
|
|||
-- routine. The Do_Static flag indicates that only a static check is
|
||||
-- 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
|
||||
(Expr : Node_Id;
|
||||
Check_Type : Character;
|
||||
|
|
@ -254,10 +278,6 @@ package body Checks is
|
|||
-- that the access value is non-null, since the checks do not
|
||||
-- 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);
|
||||
-- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
|
||||
-- Constraint_Error node.
|
||||
|
|
@ -380,13 +400,18 @@ package body Checks is
|
|||
elsif Access_Checks_Suppressed (Etype (P)) then
|
||||
return;
|
||||
|
||||
-- We do not need checks if we are not generating code (i.e. the
|
||||
-- expander is not active). This is not just an optimization, there
|
||||
-- are cases (e.g. with pragma Debug) where generating the checks
|
||||
-- can cause real trouble).
|
||||
-- We do not need checks if we are not generating code (i.e. the
|
||||
-- expander is not active). This is not just an optimization, there
|
||||
-- are cases (e.g. with pragma Debug) where generating the checks
|
||||
-- can cause real trouble).
|
||||
|
||||
elsif not Expander_Active then
|
||||
return;
|
||||
|
||||
-- We do not need checks if not needed because of short circuiting
|
||||
|
||||
elsif not Check_Needed (P, Access_Check) then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Case where P is an entity name
|
||||
|
|
@ -1360,7 +1385,8 @@ package body Checks is
|
|||
|
||||
begin
|
||||
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
|
||||
Determine_Range (Right, ROK, Rlo, Rhi);
|
||||
|
||||
|
|
@ -1382,7 +1408,6 @@ package body Checks is
|
|||
-- Test for extremely annoying case of xxx'First divided by -1
|
||||
|
||||
if Do_Overflow_Check (N) then
|
||||
|
||||
if Nkind (N) = N_Op_Divide
|
||||
and then Is_Signed_Integer_Type (Typ)
|
||||
then
|
||||
|
|
@ -2420,6 +2445,121 @@ package body Checks is
|
|||
return Cond;
|
||||
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 --
|
||||
-----------------------------------
|
||||
|
|
@ -2467,222 +2607,120 @@ package body Checks is
|
|||
Related_Nod : Node_Id;
|
||||
Has_Null_Exclusion : Boolean := False;
|
||||
|
||||
type Msg_Kind is (Components, Formals, Objects);
|
||||
Msg_K : Msg_Kind := Objects;
|
||||
-- Used by local subprograms to generate precise error messages
|
||||
begin
|
||||
pragma Assert (K = N_Parameter_Specification
|
||||
or else K = N_Object_Declaration
|
||||
or else K = N_Discriminant_Specification
|
||||
or else K = N_Component_Declaration);
|
||||
|
||||
procedure Check_Must_Be_Access
|
||||
(Typ : Entity_Id;
|
||||
Has_Null_Exclusion : Boolean);
|
||||
-- ??? local subprograms must have comment on spec
|
||||
Typ := Etype (Defining_Identifier (N));
|
||||
|
||||
procedure Check_Already_Null_Excluding_Type
|
||||
(Typ : Entity_Id;
|
||||
Has_Null_Exclusion : Boolean;
|
||||
Related_Nod : Node_Id);
|
||||
-- ??? local subprograms must have comment on spec
|
||||
pragma Assert (Is_Access_Type (Typ)
|
||||
or else (K = N_Object_Declaration and then Is_Array_Type (Typ)));
|
||||
|
||||
procedure Check_Must_Be_Initialized
|
||||
(N : Node_Id;
|
||||
Related_Nod : Node_Id);
|
||||
-- ??? local subprograms must have comment on spec
|
||||
case K is
|
||||
when N_Parameter_Specification =>
|
||||
Related_Nod := Parameter_Type (N);
|
||||
Has_Null_Exclusion := Null_Exclusion_Present (N);
|
||||
|
||||
procedure Check_Null_Not_Allowed (N : Node_Id);
|
||||
-- ??? local subprograms must have comment on spec
|
||||
when N_Object_Declaration =>
|
||||
Related_Nod := Object_Definition (N);
|
||||
Has_Null_Exclusion := Null_Exclusion_Present (N);
|
||||
|
||||
-- ??? following bodies lack comments
|
||||
when N_Discriminant_Specification =>
|
||||
Related_Nod := Discriminant_Type (N);
|
||||
Has_Null_Exclusion := Null_Exclusion_Present (N);
|
||||
|
||||
--------------------------
|
||||
-- Check_Must_Be_Access --
|
||||
--------------------------
|
||||
when N_Component_Declaration =>
|
||||
if Present (Access_Definition (Component_Definition (N))) then
|
||||
Related_Nod := Component_Definition (N);
|
||||
Has_Null_Exclusion :=
|
||||
Null_Exclusion_Present
|
||||
(Access_Definition (Component_Definition (N)));
|
||||
else
|
||||
Related_Nod :=
|
||||
Subtype_Indication (Component_Definition (N));
|
||||
Has_Null_Exclusion :=
|
||||
Null_Exclusion_Present (Component_Definition (N));
|
||||
end if;
|
||||
|
||||
procedure Check_Must_Be_Access
|
||||
(Typ : Entity_Id;
|
||||
Has_Null_Exclusion : Boolean)
|
||||
is
|
||||
begin
|
||||
if Has_Null_Exclusion
|
||||
and then not Is_Access_Type (Typ)
|
||||
then
|
||||
Error_Msg_N ("(Ada 2005) must be an access type", Related_Nod);
|
||||
end if;
|
||||
end Check_Must_Be_Access;
|
||||
when others =>
|
||||
raise Program_Error;
|
||||
end case;
|
||||
|
||||
---------------------------------------
|
||||
-- Check_Already_Null_Excluding_Type --
|
||||
---------------------------------------
|
||||
-- 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
|
||||
and then Can_Never_Be_Null (Typ)
|
||||
then
|
||||
Error_Msg_N
|
||||
("(Ada 2005) already a null-excluding type", Related_Nod);
|
||||
end if;
|
||||
end Check_Already_Null_Excluding_Type;
|
||||
if Has_Null_Exclusion
|
||||
and then Can_Never_Be_Null (Typ)
|
||||
|
||||
-------------------------------
|
||||
-- Check_Must_Be_Initialized --
|
||||
-------------------------------
|
||||
-- No need to check itypes that have the null-excluding attribute
|
||||
-- because they were checked at their point of creation
|
||||
|
||||
procedure Check_Must_Be_Initialized
|
||||
(N : Node_Id;
|
||||
Related_Nod : Node_Id)
|
||||
is
|
||||
Expr : constant Node_Id := Expression (N);
|
||||
and then not Is_Itype (Typ)
|
||||
then
|
||||
Error_Msg_N
|
||||
("(Ada 2005) already a null-excluding type", Related_Nod);
|
||||
end if;
|
||||
|
||||
begin
|
||||
pragma Assert (Nkind (N) = N_Component_Declaration
|
||||
or else Nkind (N) = N_Object_Declaration);
|
||||
-- Check that null-excluding objects are always initialized
|
||||
|
||||
if not Present (Expr) then
|
||||
case Msg_K is
|
||||
when Components =>
|
||||
Error_Msg_N
|
||||
("(Ada 2005) null-excluding components must be " &
|
||||
"initialized", Related_Nod);
|
||||
if K = N_Object_Declaration
|
||||
and then not Present (Expression (N))
|
||||
then
|
||||
-- Add a an expression that assignates null. This node is needed
|
||||
-- by Apply_Compile_Time_Constraint_Error, that will replace this
|
||||
-- node by a Constraint_Error node.
|
||||
|
||||
when Formals =>
|
||||
Error_Msg_N
|
||||
("(Ada 2005) null-excluding formals must be initialized",
|
||||
Related_Nod);
|
||||
Set_Expression (N, Make_Null (Sloc (N)));
|
||||
Set_Etype (Expression (N), Etype (Defining_Identifier (N)));
|
||||
|
||||
when Objects =>
|
||||
Error_Msg_N
|
||||
("(Ada 2005) null-excluding objects must be initialized",
|
||||
Related_Nod);
|
||||
end case;
|
||||
end if;
|
||||
end Check_Must_Be_Initialized;
|
||||
Apply_Compile_Time_Constraint_Error
|
||||
(N => Expression (N),
|
||||
Msg => "(Ada 2005) null-excluding objects must be initialized?",
|
||||
Reason => CE_Null_Not_Allowed);
|
||||
end if;
|
||||
|
||||
----------------------------
|
||||
-- Check_Null_Not_Allowed --
|
||||
----------------------------
|
||||
-- Check that the null value is not used as a single expression to
|
||||
-- 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);
|
||||
|
||||
begin
|
||||
if Present (Expr)
|
||||
and then Nkind (Expr) = N_Null
|
||||
then
|
||||
case Msg_K is
|
||||
when Components =>
|
||||
case K is
|
||||
when N_Discriminant_Specification |
|
||||
N_Component_Declaration =>
|
||||
Apply_Compile_Time_Constraint_Error
|
||||
(N => Expr,
|
||||
Msg => "(Ada 2005) NULL not allowed in"
|
||||
& " null-excluding components?",
|
||||
Reason => CE_Null_Not_Allowed,
|
||||
Rep => False);
|
||||
Reason => CE_Null_Not_Allowed);
|
||||
|
||||
when Formals =>
|
||||
when N_Parameter_Specification =>
|
||||
Apply_Compile_Time_Constraint_Error
|
||||
(N => Expr,
|
||||
Msg => "(Ada 2005) NULL not allowed in"
|
||||
& " null-excluding formals?",
|
||||
Reason => CE_Null_Not_Allowed,
|
||||
Rep => False);
|
||||
Reason => CE_Null_Not_Allowed);
|
||||
|
||||
when Objects =>
|
||||
when N_Object_Declaration =>
|
||||
Apply_Compile_Time_Constraint_Error
|
||||
(N => Expr,
|
||||
Msg => "(Ada 2005) NULL not allowed in"
|
||||
& " null-excluding objects?",
|
||||
Reason => CE_Null_Not_Allowed,
|
||||
Rep => False);
|
||||
Reason => CE_Null_Not_Allowed);
|
||||
|
||||
when others =>
|
||||
null;
|
||||
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 =>
|
||||
raise Program_Error;
|
||||
end case;
|
||||
end;
|
||||
end Null_Exclusion_Static_Checks;
|
||||
|
||||
----------------------------------
|
||||
|
|
|
|||
Loading…
Reference in New Issue