From: Hristian Kirtchev Date: Tue, 25 Apr 2017 10:43:14 +0000 (+0000) Subject: checks.adb (Insert_Valid_Check): Code cleanup. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=62e45e3e7035eb7c668be8ec9988c57e2d4337f9;p=gcc.git checks.adb (Insert_Valid_Check): Code cleanup. 2017-04-25 Hristian Kirtchev * checks.adb (Insert_Valid_Check): Code cleanup. * exp_ch6.adb (Add_Validation_Call_By_Copy_Code): New routine. (Expand_Actuals): Generate proper copy-back for a validation variable when it acts as the argument of a type conversion. * sem_util.adb (Is_Validation_Variable_Reference): Augment the predicate to operate on type qualifications. From-SVN: r247180 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 634629536f3..55a1526b072 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2017-04-25 Hristian Kirtchev + + * checks.adb (Insert_Valid_Check): Code cleanup. + * exp_ch6.adb (Add_Validation_Call_By_Copy_Code): New routine. + (Expand_Actuals): Generate proper copy-back for a validation + variable when it acts as the argument of a type conversion. + * sem_util.adb (Is_Validation_Variable_Reference): Augment the + predicate to operate on type qualifications. + 2017-04-25 Hristian Kirtchev * sem_prag.adb, exp_ch6.adb, binde.adb, sem_disp.adb, s-fileio.adb: diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index b839863e5c2..2bcd059219d 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -7286,10 +7286,11 @@ package body Checks is declare DRC : constant Boolean := Do_Range_Check (Exp); - CE : Node_Id; - Obj : Node_Id; - PV : Node_Id; - Var : Entity_Id; + + CE : Node_Id; + Obj : Node_Id; + PV : Node_Id; + Var_Id : Entity_Id; begin Set_Do_Range_Check (Exp, False); @@ -7301,14 +7302,14 @@ package body Checks is -- 1) The evaluation of the object results in only one read in the -- case where the object is atomic or volatile. - -- Temp ... := Object; -- read + -- Var ... := Object; -- read -- 2) The captured value is the one verified by attribute 'Valid. -- As a result the object is not evaluated again, which would -- result in an unwanted read in the case where the object is -- atomic or volatile. - -- if not Temp'Valid then -- OK, no read of Object + -- if not Var'Valid then -- OK, no read of Object -- if not Object'Valid then -- Wrong, extra read of Object @@ -7316,7 +7317,7 @@ package body Checks is -- As a result the object is not evaluated again, in the same -- vein as 2). - -- ... Temp ... -- OK, no read of Object + -- ... Var ... -- OK, no read of Object -- ... Object ... -- Wrong, extra read of Object @@ -7326,24 +7327,24 @@ package body Checks is -- procedure Call (Val : in out ...); - -- Temp : ... := Object; -- read Object - -- if not Temp'Valid then -- validity check - -- Call (Temp); -- modify Temp - -- Object := Temp; -- update Object + -- Var : ... := Object; -- read Object + -- if not Var'Valid then -- validity check + -- Call (Var); -- modify Var + -- Object := Var; -- update Object if Is_Variable (Exp) then - Obj := New_Copy_Tree (Exp); - Var := Make_Temporary (Loc, 'T', Exp); + Obj := New_Copy_Tree (Exp); + Var_Id := Make_Temporary (Loc, 'T', Exp); Insert_Action (Exp, Make_Object_Declaration (Loc, - Defining_Identifier => Var, + Defining_Identifier => Var_Id, Object_Definition => New_Occurrence_Of (Typ, Loc), Expression => Relocate_Node (Exp))); - Set_Validated_Object (Var, Obj); + Set_Validated_Object (Var_Id, Obj); - Rewrite (Exp, New_Occurrence_Of (Var, Loc)); - PV := New_Occurrence_Of (Var, Loc); + Rewrite (Exp, New_Occurrence_Of (Var_Id, Loc)); + 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 e0499ec9f9f..2a425285d75 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1180,6 +1180,10 @@ package body Exp_Ch6 is -- that all that is needed is to simply create a temporary and copy -- the value in and out of the temporary. + procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id); + -- Perform copy-back for actual parameter Act which denotes a validation + -- variable. + procedure Check_Fortran_Logical; -- A value of type Logical that is passed through a formal parameter -- must be normalized because .TRUE. usually does not have the same @@ -1618,6 +1622,85 @@ package body Exp_Ch6 is end if; end Add_Simple_Call_By_Copy_Code; + -------------------------------------- + -- Add_Validation_Call_By_Copy_Code -- + -------------------------------------- + + procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id) is + Expr : Node_Id; + Obj : Node_Id; + Obj_Typ : Entity_Id; + Var : Node_Id; + Var_Id : Entity_Id; + + begin + Var := Act; + + -- Use the expression when the context qualifies a reference in some + -- fashion. + + while Nkind_In (Var, N_Qualified_Expression, + N_Type_Conversion, + N_Unchecked_Type_Conversion) + loop + Var := Expression (Var); + end loop; + + -- Copy the value of the validation variable back into the object + -- being validated. + + if Is_Entity_Name (Var) then + Var_Id := Entity (Var); + Obj := Validated_Object (Var_Id); + Obj_Typ := Etype (Obj); + + Expr := New_Occurrence_Of (Var_Id, Loc); + + -- A type conversion is needed when the validation variable and + -- the validated object carry different types. This case occurs + -- when the actual is qualified in some fashion. + + -- Common: + -- subtype Int is Integer range ...; + -- procedure Call (Val : in out Integer); + + -- Original: + -- Object : Int; + -- Call (Integer (Object)); + + -- Expanded: + -- Object : Int; + -- Var : Integer := Object; -- conversion to base type + -- if not Var'Valid then -- validity check + -- Call (Var); -- modify Var + -- Object := Int (Var); -- conversion to subtype + + if Etype (Var_Id) /= Obj_Typ then + Expr := + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Obj_Typ, Loc), + Expression => Expr); + end if; + + -- Generate: + -- Object := Var; + -- + -- Object := Object_Type (Var); + + Append_To (Post_Call, + Make_Assignment_Statement (Loc, + Name => Obj, + Expression => Expr)); + + -- If the flow reaches this point, then this routine was invoked with + -- an actual which does not denote a validation variable. + + else + pragma Assert (False); + null; + end if; + end Add_Validation_Call_By_Copy_Code; + --------------------------- -- Check_Fortran_Logical -- --------------------------- @@ -1831,10 +1914,26 @@ package body Exp_Ch6 is end if; end if; - -- If argument is a type conversion for a type that is passed - -- by copy, then we must pass the parameter by copy. + -- The actual denotes a variable which captures the value of an + -- object for validation purposes. Add a copy-back to reflect any + -- potential changes in value back into the original object. + + -- Var : ... := Object; + -- if not Var'Valid then -- validity check + -- Call (Var); -- modify var + -- Object := Var; -- update Object + + -- This case is given higher priority because the subsequent check + -- for type conversion may add an extra copy of the variable and + -- prevent proper value propagation back in the original object. + + if Is_Validation_Variable_Reference (Actual) then + Add_Validation_Call_By_Copy_Code (Actual); - if Nkind (Actual) = N_Type_Conversion + -- If argument is a type conversion for a type that is passed by + -- copy, then we must pass the parameter by copy. + + elsif Nkind (Actual) = N_Type_Conversion and then (Is_Numeric_Type (E_Formal) or else Is_Access_Type (E_Formal) @@ -1913,21 +2012,6 @@ package body Exp_Ch6 is then Add_Call_By_Copy_Code; - -- The actual denotes a variable which captures the value of an - -- object for validation purposes. Add a copy-back to reflect any - -- potential changes in value back into the original object. - - -- Temp : ... := Object; - -- if not Temp'Valid then ... - -- Call (Temp); - -- Object := Temp; - - elsif Is_Validation_Variable_Reference (Actual) then - Append_To (Post_Call, - Make_Assignment_Statement (Loc, - Name => Validated_Object (Entity (Actual)), - Expression => New_Occurrence_Of (Entity (Actual), Loc))); - elsif Nkind (Actual) = N_Indexed_Component and then Is_Entity_Name (Prefix (Actual)) and then Has_Volatile_Components (Entity (Prefix (Actual))) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 4bbaf1bda66..a1187824bfa 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -15282,12 +15282,32 @@ package body Sem_Util is -------------------------------------- function Is_Validation_Variable_Reference (N : Node_Id) return Boolean is + Var : Node_Id; + Var_Id : Entity_Id; + begin + Var := N; + + -- Use the expression when the context qualifies a reference in some + -- fashion. + + while Nkind_In (Var, N_Qualified_Expression, + N_Type_Conversion, + N_Unchecked_Type_Conversion) + loop + Var := Expression (Var); + end loop; + + Var_Id := Empty; + + if Is_Entity_Name (Var) then + Var_Id := Entity (Var); + end if; + return - Is_Entity_Name (N) - and then Present (Entity (N)) - and then Ekind (Entity (N)) = E_Variable - and then Present (Validated_Object (Entity (N))); + Present (Var_Id) + and then Ekind (Var_Id) = E_Variable + and then Present (Validated_Object (Var_Id)); end Is_Validation_Variable_Reference; ----------------------------