[Ada] Spurious warnings and errors on calls on synchronized interfaces

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;