This plugs another small loophole in the front-end which fails to
generate a range check for a scalar In/Out parameter when -gnatVa is
specified. This also fixes a few more leaks of the Do_Range_Check flag
on actual parameters, both in regular and -gnatVa modes, as well as a
leak specific to expression function in -gnatp mode.
Tested on x86_64-pc-linux-gnu, committed on trunk
2019-08-12 Eric Botcazou <ebotca...@adacore.com>
gcc/ada/
* checks.adb (Insert_Valid_Check): Reset the Do_Range_Check flag
on the validated object.
* exp_ch6.adb (Add_Call_By_Copy_Code): Reset the Do_Range_Check
flag on the actual here, as well as on the Expression if the
actual is a N_Type_Conversion node.
(Add_Validation_Call_By_Copy_Code): Generate the incoming range
check if needed and reset the Do_Range_Check flag on the
Expression if the actual is a N_Type_Conversion node.
(Expand_Actuals): Do not reset the Do_Range_Check flag here.
Generate the incoming range check for In parameters here instead
of...
(Expand_Call_Helper): ...here. Remove redudant condition.
* sem_res.adb (Resolve_Actuals): Use local variable A_Typ and
remove obsolete comments.
(Resolve_Type_Conversion): Do not force the Do_Range_Check flag
on the operand if range checks are suppressed.
gcc/testsuite/
* gnat.dg/range_check6.adb: New testcase.--- gcc/ada/checks.adb
+++ gcc/ada/checks.adb
@@ -7588,8 +7588,12 @@ package body Checks is
Suppress => Validity_Check);
Set_Validated_Object (Var_Id, New_Copy_Tree (Exp));
+
+ -- Reset the Do_Range_Check flag so it doesn't leak elsewhere
+
+ Set_Do_Range_Check (Validated_Object (Var_Id), False);
+
Rewrite (Exp, New_Occurrence_Of (Var_Id, Loc));
- PV := New_Occurrence_Of (Var_Id, Loc);
-- Copy the Do_Range_Check flag over to the new Exp, so it doesn't
-- get lost. Floating point types are handled elsewhere.
@@ -7598,6 +7602,8 @@ package body Checks is
Set_Do_Range_Check (Exp, Do_Range_Check (Original_Node (Exp)));
end if;
+ PV := New_Occurrence_Of (Var_Id, Loc);
+
-- Otherwise the expression does not denote a variable. Force its
-- evaluation by capturing its value in a constant. Generate:
--- gcc/ada/exp_ch6.adb
+++ gcc/ada/exp_ch6.adb
@@ -1295,7 +1295,14 @@ package body Exp_Ch6 is
Indic := New_Occurrence_Of (F_Typ, Loc);
end if;
+ -- The new code will be properly analyzed below and the setting of
+ -- the Do_Range_Check flag recomputed so remove the obsolete one.
+
+ Set_Do_Range_Check (Actual, False);
+
if Nkind (Actual) = N_Type_Conversion then
+ Set_Do_Range_Check (Expression (Actual), False);
+
V_Typ := Etype (Expression (Actual));
-- If the formal is an (in-)out parameter, capture the name
@@ -1689,6 +1696,20 @@ package body Exp_Ch6 is
Var_Id : Entity_Id;
begin
+ -- Generate range check if required
+
+ if Do_Range_Check (Actual) then
+ Generate_Range_Check (Actual, E_Formal, CE_Range_Check_Failed);
+ end if;
+
+ -- If there is a type conversion in the actual, it will be reinstated
+ -- below, the new instance will be properly analyzed and the setting
+ -- of the Do_Range_Check flag recomputed so remove the obsolete one.
+
+ if Nkind (Actual) = N_Type_Conversion then
+ Set_Do_Range_Check (Expression (Actual), False);
+ end if;
+
-- Copy the value of the validation variable back into the object
-- being validated.
@@ -2073,14 +2094,6 @@ package body Exp_Ch6 is
(Ekind (Formal) = E_In_Out_Parameter
and then not In_Subrange_Of (E_Actual, E_Formal)))
then
- -- Perhaps the setting back to False should be done within
- -- Add_Call_By_Copy_Code, since it could get set on other
- -- cases occurring above???
-
- if Do_Range_Check (Actual) then
- Set_Do_Range_Check (Actual, False);
- end if;
-
Add_Call_By_Copy_Code;
end if;
@@ -2194,6 +2207,12 @@ package body Exp_Ch6 is
-- Processing for IN parameters
else
+ -- Generate range check if required
+
+ if Do_Range_Check (Actual) then
+ Generate_Range_Check (Actual, E_Formal, CE_Range_Check_Failed);
+ end if;
+
-- For IN parameters in the bit-packed array case, we expand an
-- indexed component (the circuit in Exp_Ch4 deliberately left
-- indexed components appearing as actuals untouched, so that
@@ -3054,16 +3073,6 @@ package body Exp_Ch6 is
Actual := First_Actual (Call_Node);
Param_Count := 1;
while Present (Formal) loop
-
- -- Generate range check if required
-
- if Do_Range_Check (Actual)
- and then Ekind (Formal) = E_In_Parameter
- then
- Generate_Range_Check
- (Actual, Etype (Formal), CE_Range_Check_Failed);
- end if;
-
-- Prepare to examine current entry
Prev := Actual;
@@ -3582,9 +3591,7 @@ package body Exp_Ch6 is
-- or IN OUT parameter. We do reset the Is_Known_Valid flag
-- since the subprogram could have returned in invalid value.
- if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter)
- and then Is_Assignable (Ent)
- then
+ if Is_Assignable (Ent) then
Sav := Last_Assignment (Ent);
Kill_Current_Values (Ent);
Set_Last_Assignment (Ent, Sav);
--- gcc/ada/sem_res.adb
+++ gcc/ada/sem_res.adb
@@ -4517,7 +4517,7 @@ package body Sem_Res is
end if;
end if;
- if Etype (A) = Any_Type then
+ if A_Typ = Any_Type then
Set_Etype (N, Any_Type);
return;
end if;
@@ -4539,18 +4539,10 @@ package body Sem_Res is
-- Apply required constraint checks
- -- Gigi looks at the check flag and uses the appropriate types.
- -- For now since one flag is used there is an optimization
- -- which might not be done in the IN OUT case since Gigi does
- -- not do any analysis. More thought required about this ???
-
- -- In fact is this comment obsolete??? doesn't the expander now
- -- generate all these tests anyway???
-
- if Is_Scalar_Type (Etype (A)) then
+ if Is_Scalar_Type (A_Typ) then
Apply_Scalar_Range_Check (A, F_Typ);
- elsif Is_Array_Type (Etype (A)) then
+ elsif Is_Array_Type (A_Typ) then
Apply_Length_Check (A, F_Typ);
elsif Is_Record_Type (F_Typ)
@@ -4624,9 +4616,8 @@ package body Sem_Res is
Apply_Scalar_Range_Check
(Expression (A), Etype (Expression (A)), A_Typ);
- -- In addition, the returned value of the parameter must
- -- satisfy the bounds of the object type (see comment
- -- below).
+ -- In addition the return value must meet the constraints
+ -- of the object type (see the comment below).
Apply_Scalar_Range_Check (A, A_Typ, F_Typ);
@@ -4650,6 +4641,7 @@ package body Sem_Res is
and then Ekind (F) = E_Out_Parameter
then
Apply_Length_Check (A, F_Typ);
+
else
Apply_Range_Check (A, A_Typ, F_Typ);
end if;
@@ -11757,6 +11749,8 @@ package body Sem_Res is
and then (Is_Fixed_Point_Type (Operand_Typ)
or else (not GNATprove_Mode
and then Is_Floating_Point_Type (Operand_Typ)))
+ and then not Range_Checks_Suppressed (Target_Typ)
+ and then not Range_Checks_Suppressed (Operand_Typ)
then
Set_Do_Range_Check (Operand);
end if;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/range_check6.adb
@@ -0,0 +1,28 @@
+-- { dg-do run }
+-- { dg-options "-O0 -gnatVa" }
+
+procedure Range_Check6 is
+
+ type Byte is range -2**7 .. 2**7-1;
+ for Byte'Size use 8;
+
+ subtype Hour is Byte range 0 .. 23;
+
+ type Rec is record
+ B : Byte;
+ end record;
+
+ procedure Encode (H : in out Hour) is
+ begin
+ null;
+ end;
+
+ R : Rec;
+
+begin
+ R.B := 24;
+ Encode (R.B);
+ raise Program_Error;
+exception
+ when Constraint_Error => null;
+end;
