Commit 10475800 by Eric Botcazou Committed by Arnaud Charlet

checks.adb (Selected_Range_Checks): Do not consider that a non-static integer…

checks.adb (Selected_Range_Checks): Do not consider that a non-static integer bound forces the check if...

2009-07-13  Eric Botcazou  <ebotcazou@adacore.com>

	* checks.adb (Selected_Range_Checks): Do not consider that a non-static
	integer bound forces the check if it is compared to its subtype range.

From-SVN: r149577
parent 2f3e235b
2009-07-13 Eric Botcazou <ebotcazou@adacore.com>
* checks.adb (Selected_Range_Checks): Do not consider that a non-static
integer bound forces the check if it is compared to its subtype range.
2009-07-13 Robert Dewar <dewar@adacore.com> 2009-07-13 Robert Dewar <dewar@adacore.com>
* prj.ads, prj-dect.adb, prj-err.ads, prj-err.adb, prj-nmsc.adb, * prj.ads, prj-dect.adb, prj-err.ads, prj-err.adb, prj-nmsc.adb,
......
...@@ -6644,27 +6644,65 @@ package body Checks is ...@@ -6644,27 +6644,65 @@ package body Checks is
declare declare
T_LB : constant Node_Id := Type_Low_Bound (T_Typ); T_LB : constant Node_Id := Type_Low_Bound (T_Typ);
T_HB : constant Node_Id := Type_High_Bound (T_Typ); T_HB : constant Node_Id := Type_High_Bound (T_Typ);
LB : constant Node_Id := Low_Bound (Ck_Node); Known_T_LB : constant Boolean := Compile_Time_Known_Value (T_LB);
HB : constant Node_Id := High_Bound (Ck_Node); Known_T_HB : constant Boolean := Compile_Time_Known_Value (T_HB);
Null_Range : Boolean;
LB : Node_Id := Low_Bound (Ck_Node);
HB : Node_Id := High_Bound (Ck_Node);
Known_LB : Boolean;
Known_HB : Boolean;
Null_Range : Boolean;
Out_Of_Range_L : Boolean; Out_Of_Range_L : Boolean;
Out_Of_Range_H : Boolean; Out_Of_Range_H : Boolean;
begin begin
-- Check for case where everything is static and we can -- Compute what is known at compile time
-- do the check at compile time. This is skipped if we
-- have an access type, since the access value may be null. if Known_T_LB and Known_T_HB then
if Compile_Time_Known_Value (LB) then
-- ??? This code can be improved since you only need to know Known_LB := True;
-- that the two respective bounds (LB & T_LB or HB & T_HB)
-- are known at compile time to emit pertinent messages. -- There's no point in checking that a bound is within its
-- own range so pretend that it is known in this case. First
if Compile_Time_Known_Value (LB) -- deal with low bound.
and then Compile_Time_Known_Value (HB)
and then Compile_Time_Known_Value (T_LB) elsif Ekind (Etype (LB)) = E_Signed_Integer_Subtype
and then Compile_Time_Known_Value (T_HB) and then Scalar_Range (Etype (LB)) = Scalar_Range (T_Typ)
and then not Do_Access then
LB := T_LB;
Known_LB := True;
else
Known_LB := False;
end if;
-- Likewise for the high bound
if Compile_Time_Known_Value (HB) then
Known_HB := True;
elsif Ekind (Etype (HB)) = E_Signed_Integer_Subtype
and then Scalar_Range (Etype (HB)) = Scalar_Range (T_Typ)
then
HB := T_HB;
Known_HB := True;
else
Known_HB := False;
end if;
end if;
-- Check for case where everything is static and we can do the
-- check at compile time. This is skipped if we have an access
-- type, since the access value may be null.
-- ??? This code can be improved since you only need to know that
-- the two respective bounds (LB & T_LB or HB & T_HB) are known at
-- compile time to emit pertinent messages.
if Known_T_LB and Known_T_HB and Known_LB and Known_HB
and not Do_Access
then then
-- Floating-point case -- Floating-point case
...@@ -6672,12 +6710,12 @@ package body Checks is ...@@ -6672,12 +6710,12 @@ package body Checks is
Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB); Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB);
Out_Of_Range_L := Out_Of_Range_L :=
(Expr_Value_R (LB) < Expr_Value_R (T_LB)) (Expr_Value_R (LB) < Expr_Value_R (T_LB))
or else or else
(Expr_Value_R (LB) > Expr_Value_R (T_HB)); (Expr_Value_R (LB) > Expr_Value_R (T_HB));
Out_Of_Range_H := Out_Of_Range_H :=
(Expr_Value_R (HB) > Expr_Value_R (T_HB)) (Expr_Value_R (HB) > Expr_Value_R (T_HB))
or else or else
(Expr_Value_R (HB) < Expr_Value_R (T_LB)); (Expr_Value_R (HB) < Expr_Value_R (T_LB));
-- Fixed or discrete type case -- Fixed or discrete type case
...@@ -6686,12 +6724,12 @@ package body Checks is ...@@ -6686,12 +6724,12 @@ package body Checks is
Null_Range := Expr_Value (HB) < Expr_Value (LB); Null_Range := Expr_Value (HB) < Expr_Value (LB);
Out_Of_Range_L := Out_Of_Range_L :=
(Expr_Value (LB) < Expr_Value (T_LB)) (Expr_Value (LB) < Expr_Value (T_LB))
or else or else
(Expr_Value (LB) > Expr_Value (T_HB)); (Expr_Value (LB) > Expr_Value (T_HB));
Out_Of_Range_H := Out_Of_Range_H :=
(Expr_Value (HB) > Expr_Value (T_HB)) (Expr_Value (HB) > Expr_Value (T_HB))
or else or else
(Expr_Value (HB) < Expr_Value (T_LB)); (Expr_Value (HB) < Expr_Value (T_LB));
end if; end if;
...@@ -6725,7 +6763,6 @@ package body Checks is ...@@ -6725,7 +6763,6 @@ package body Checks is
"static range out of bounds of}?", T_Typ)); "static range out of bounds of}?", T_Typ));
end if; end if;
end if; end if;
end if; end if;
else else
...@@ -6827,15 +6864,17 @@ package body Checks is ...@@ -6827,15 +6864,17 @@ package body Checks is
or else or else
(Expr_Value_R (Ck_Node) > Expr_Value_R (UB)); (Expr_Value_R (Ck_Node) > Expr_Value_R (UB));
else -- fixed or discrete type -- Fixed or discrete type
else
Out_Of_Range := Out_Of_Range :=
Expr_Value (Ck_Node) < Expr_Value (LB) Expr_Value (Ck_Node) < Expr_Value (LB)
or else or else
Expr_Value (Ck_Node) > Expr_Value (UB); Expr_Value (Ck_Node) > Expr_Value (UB);
end if; end if;
-- Bounds of the type are static and the literal is -- Bounds of the type are static and the literal is out of
-- out of range so make a warning message. -- range so output a warning message.
if Out_Of_Range then if Out_Of_Range then
if No (Warn_Node) then if No (Warn_Node) then
...@@ -6936,7 +6975,6 @@ package body Checks is ...@@ -6936,7 +6975,6 @@ package body Checks is
Next (L_Index); Next (L_Index);
Next (R_Index); Next (R_Index);
end if; end if;
end loop; end loop;
end; end;
...@@ -6963,7 +7001,6 @@ package body Checks is ...@@ -6963,7 +7001,6 @@ package body Checks is
(Cond, Range_N_Cond (Ck_Node, T_Typ, Indx)); (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx));
end loop; end loop;
end; end;
end if; end if;
else else
...@@ -7059,8 +7096,8 @@ package body Checks is ...@@ -7059,8 +7096,8 @@ package body Checks is
Add_Check Add_Check
(Make_Raise_Constraint_Error (Loc, (Make_Raise_Constraint_Error (Loc,
Condition => Cond, Condition => Cond,
Reason => CE_Range_Check_Failed)); Reason => CE_Range_Check_Failed));
end if; end if;
return Ret_Result; return Ret_Result;
......
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