OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

checks.adb (Insert_Valid_Check): Code cleanup.

Browse Source 
2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* 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
This commit is contained in:
Hristian Kirtchev 2017-04-25 10:43:14 +00:00 committed by Arnaud Charlet
parent ec40b86c77
commit 62e45e3e70
4 changed files with 153 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
gcc/ada/ChangeLog
View File

@ -1,3 +1,12 @@
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* 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 <kirtchev@adacore.com>
* sem_prag.adb, exp_ch6.adb, binde.adb, sem_disp.adb, s-fileio.adb:

35
gcc/ada/checks.adb
View File

@ -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:

120
gcc/ada/exp_ch6.adb
View File

@ -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;
-- <or>
-- 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.
if Nkind (Actual) = N_Type_Conversion
-- 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 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)))

28
gcc/ada/sem_util.adb
View File

@ -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;
----------------------------