From 13931a38fcab143344c90378c3688d089a4efbec Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 12 Aug 2019 08:58:52 +0000 Subject: [PATCH] [Ada] Fix missing range check for In/Out parameter with -gnatVa 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. 2019-08-12 Eric Botcazou 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. From-SVN: r274280 --- gcc/ada/ChangeLog | 19 ++++++++++ gcc/ada/checks.adb | 8 ++++- gcc/ada/exp_ch6.adb | 49 +++++++++++++++----------- gcc/ada/sem_res.adb | 22 +++++------- gcc/testsuite/ChangeLog | 4 +++ gcc/testsuite/gnat.dg/range_check6.adb | 28 +++++++++++++++ 6 files changed, 94 insertions(+), 36 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/range_check6.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 749d96a1389..7c7aa8330a0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,22 @@ +2019-08-12 Eric Botcazou + + * 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. + 2019-08-12 Eric Botcazou * checks.adb (Activate_Range_Check): Remove redundant argument. diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 813ffec3136..5d8efce9080 100644 --- a/gcc/ada/checks.adb +++ b/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: diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index f38dd671b6d..3f2d0e31783 100644 --- a/gcc/ada/exp_ch6.adb +++ b/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); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index b668a5102bb..8162b8e0520 100644 --- a/gcc/ada/sem_res.adb +++ b/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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index fdcb620c3be..90ce94df755 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-08-12 Eric Botcazou + + * gnat.dg/range_check6.adb: New testcase. + 2019-08-11 Iain Buclaw PR d/90601 diff --git a/gcc/testsuite/gnat.dg/range_check6.adb b/gcc/testsuite/gnat.dg/range_check6.adb new file mode 100644 index 00000000000..00fa705d21b --- /dev/null +++ b/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; -- 2.30.2