This patch fixes some spurious warnings and errors on dispatching calls to
synchronized operations when the controlling formal of the operation is an
access to interface type.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
2017-10-20 Ed Schonberg <schonb...@adacore.com>
* sem_util.adb (Is_Controlling_Limited_Procedure): Handle properly the
case where the controlling formal is an anonymous access to interface
type.
* exp_ch9.adb (Extract_Dispatching_Call): If controlling actual is an
access type, handle properly the the constructed dereference that
designates the object used in the rewritten synchronized call.
(Parameter_Block_Pack): If the type of the actual is by-copy, its
generated declaration in the parameter block does not need an
initialization even if the type is a null-excluding access type,
because it will be initialized with the value of the actual later on.
(Parameter_Block_Pack): Do not add controlling actual to parameter
block when its type is by-copy.
gcc/testsuite/
2017-10-20 Ed Schonberg <schonb...@adacore.com>
* gnat.dg/sync_iface_call.adb, gnat.dg/sync_iface_call_pkg.ads,
gnat.dg/sync_iface_call_pkg2.adb, gnat.dg/sync_iface_call_pkg2.ads:
New testcase.
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 253947)
+++ sem_util.adb (working copy)
@@ -13186,18 +13186,30 @@
function Is_Controlling_Limited_Procedure
(Proc_Nam : Entity_Id) return Boolean
is
+ Param : Node_Id;
Param_Typ : Entity_Id := Empty;
begin
if Ekind (Proc_Nam) = E_Procedure
and then Present (Parameter_Specifications (Parent (Proc_Nam)))
then
- Param_Typ := Etype (Parameter_Type (First (
- Parameter_Specifications (Parent (Proc_Nam)))));
+ Param := Parameter_Type (First (
+ Parameter_Specifications (Parent (Proc_Nam))));
- -- In this case where an Itype was created, the procedure call has been
- -- rewritten.
+ -- The formal may be an anonymous access type.
+ if Nkind (Param) = N_Access_Definition then
+ Param_Typ := Entity (Subtype_Mark (Param));
+
+ else
+ Param_Typ := Etype (Param);
+ end if;
+
+ -- In the case where an Itype was created for a dispatchin call, the
+ -- procedure call has been rewritten. The actual may be an access to
+ -- interface type in which case it is the designated type that is the
+ -- controlling type.
+
elsif Present (Associated_Node_For_Itype (Proc_Nam))
and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
and then
@@ -13207,6 +13219,10 @@
Param_Typ :=
Etype (First (Parameter_Associations
(Associated_Node_For_Itype (Proc_Nam))));
+
+ if Ekind (Param_Typ) = E_Anonymous_Access_Type then
+ Param_Typ := Directly_Designated_Type (Param_Typ);
+ end if;
end if;
if Present (Param_Typ) then
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb (revision 253941)
+++ exp_ch9.adb (working copy)
@@ -12909,11 +12909,14 @@
end if;
-- If the type of the dispatching object is an access type then return
- -- an explicit dereference.
+ -- an explicit dereference of a copy of the object, and note that
+ -- this is the controlling actual of the call.
if Is_Access_Type (Etype (Object)) then
- Object := Make_Explicit_Dereference (Sloc (N), Object);
+ Object :=
+ Make_Explicit_Dereference (Sloc (N), New_Copy_Tree (Object));
Analyze (Object);
+ Set_Is_Controlling_Actual (Object);
end if;
end Extract_Dispatching_Call;
@@ -14561,6 +14564,12 @@
Object_Definition =>
New_Occurrence_Of (Etype (Formal), Loc)));
+ -- The object is initialized with an explicit assignment
+ -- later. Indicate that it does not need an initialization
+ -- to prevent spurious warnings if the type excludes null.
+
+ Set_No_Initialization (Last (Decls));
+
if Ekind (Formal) /= E_Out_Parameter then
-- Generate:
@@ -14577,16 +14586,23 @@
Expression => New_Copy_Tree (Actual)));
end if;
- -- Generate:
+ -- If the actual is not controlling, generate:
+
-- Jnn'unchecked_access
- Append_To (Params,
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Unchecked_Access,
- Prefix => New_Occurrence_Of (Temp_Nam, Loc)));
+ -- and add it to aggegate for access to formals. Note that
+ -- the actual may be by-copy but still be a controlling actual
+ -- if it is an access to class-wide interface.
- Has_Param := True;
+ if not Is_Controlling_Actual (Actual) then
+ Append_To (Params,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Unchecked_Access,
+ Prefix => New_Occurrence_Of (Temp_Nam, Loc)));
+ Has_Param := True;
+ end if;
+
-- The controlling parameter is omitted
else
Index: ../testsuite/gnat.dg/sync_iface_call.adb
===================================================================
--- ../testsuite/gnat.dg/sync_iface_call.adb (revision 0)
+++ ../testsuite/gnat.dg/sync_iface_call.adb (revision 0)
@@ -0,0 +1,34 @@
+-- { dg-do compile }
+
+with Sync_Iface_Call_Pkg;
+with Sync_Iface_Call_Pkg2;
+
+procedure Sync_Iface_Call is
+
+ Impl : access Sync_Iface_Call_Pkg.IFace'Class :=
+ new Sync_Iface_Call_Pkg2.Impl;
+ Val : aliased Integer := 10;
+begin
+ select
+ Impl.Do_Stuff (Val);
+ or
+ delay 10.0;
+ end select;
+ select
+ Impl.Do_Stuff_Access (Val'Access);
+ or
+ delay 10.0;
+ end select;
+
+ select
+ Impl.Do_Stuff_2 (Val);
+ or
+ delay 10.0;
+ end select;
+
+ select
+ Impl.Do_Stuff_2_Access (Val'Access);
+ or
+ delay 10.0;
+ end select;
+end Sync_Iface_Call;
Index: ../testsuite/gnat.dg/sync_iface_call_pkg.ads
===================================================================
--- ../testsuite/gnat.dg/sync_iface_call_pkg.ads (revision 0)
+++ ../testsuite/gnat.dg/sync_iface_call_pkg.ads (revision 0)
@@ -0,0 +1,21 @@
+package Sync_Iface_Call_Pkg is
+
+ type IFace is synchronized interface;
+
+ procedure Do_Stuff
+ (This : in out IFace;
+ Value : in Integer) is null;
+
+ procedure Do_Stuff_Access
+ (This : in out IFace;
+ Value : not null access Integer) is null;
+
+ procedure Do_Stuff_2
+ (This : not null access IFace;
+ Value : in Integer) is null;
+
+ procedure Do_Stuff_2_Access
+ (This : not null access IFace;
+ Value : not null access Integer) is null;
+
+end Sync_Iface_Call_Pkg;
Index: ../testsuite/gnat.dg/sync_iface_call_pkg2.adb
===================================================================
--- ../testsuite/gnat.dg/sync_iface_call_pkg2.adb (revision 0)
+++ ../testsuite/gnat.dg/sync_iface_call_pkg2.adb (revision 0)
@@ -0,0 +1,8 @@
+package body Sync_Iface_Call_Pkg2 is
+
+ task body Impl is
+ begin
+ null;
+ end Impl;
+
+end Sync_Iface_Call_Pkg2;
Index: ../testsuite/gnat.dg/sync_iface_call_pkg2.ads
===================================================================
--- ../testsuite/gnat.dg/sync_iface_call_pkg2.ads (revision 0)
+++ ../testsuite/gnat.dg/sync_iface_call_pkg2.ads (revision 0)
@@ -0,0 +1,7 @@
+with Sync_Iface_Call_Pkg;
+
+package Sync_Iface_Call_Pkg2 is
+
+ task type Impl is new Sync_Iface_Call_Pkg.IFace with end;
+
+end Sync_Iface_Call_Pkg2;
