===================================================================
@@ -7286,11 +7286,12 @@
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 @@
-- 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 @@
-- 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 @@
-- 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:
===================================================================
@@ -15282,12 +15282,32 @@
--------------------------------------
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;
----------------------------
===================================================================
@@ -1180,6 +1180,10 @@
-- 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 @@
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 @@
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 @@
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)))
Thic patch modifies the expansion of actual parameters to account for a case where a validation variable may act as the argument of a type conversion and produce proper code to avoid a potential duplicate copy of the variable. ------------ -- Source -- ------------ -- types.ads package Types is type FD_Set (Size : Natural) is abstract tagged private; type FD_Set_Access is access all FD_Set'Class; procedure Next (Obj : FD_Set; Index : in out Positive) is abstract; type Set (Size : Natural) is new FD_Set with private; overriding procedure Next (Obj : Set; Index : in out Positive); type Socket_Set_Type is tagged private; procedure Initialize (Obj : in out Socket_Set_Type); type Socket_Count is new Natural; subtype Socket_Index is Socket_Count range 1 .. Socket_Count'Last; procedure Next (Set : Socket_Set_Type; Index : in out Socket_Index); private type FD_Set (Size : Natural) is abstract tagged null record; type Set (Size : Natural) is new FD_Set (Size) with record Comp : Integer := 1; end record; type Socket_Set_Type is tagged record Poll : FD_Set_Access; end record; end Types; -- types.adb package body Types is procedure Initialize (Obj : in out Socket_Set_Type) is begin Obj.Poll := new Set'(Size => 123, Comp => 456); end Initialize; procedure Next (Obj : Set; Index : in out Positive) is begin Index := Index + 1; end Next; procedure Next (Set : Socket_Set_Type; Index : in out Socket_Index) is begin Set.Poll.Next (Positive (Index)); end Next; end Types; -- main.adb with Ada.Text_IO; use Ada.Text_IO; with Types; use Types; procedure Main is Set : Socket_Set_Type; Val : Socket_Index; begin Set.Initialize; Val := 1; Set.Next (Val); if Val /= 2 then Put_Line ("ERROR"); end if; end Main; ----------------- -- Compilation -- ----------------- $ gnatmake -q -gnatVa main.adb $ ./main Tested on x86_64-pc-linux-gnu, committed on trunk 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.