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 <kirtc...@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.
Index: checks.adb
===================================================================
--- checks.adb (revision 247177)
+++ checks.adb (working copy)
@@ -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:
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 247177)
+++ sem_util.adb (working copy)
@@ -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;
----------------------------
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb (revision 247179)
+++ exp_ch6.adb (working copy)
@@ -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)))
