Ada: Fix overriding indicator wrongly rejected on protected procedure

The case itself is fairly pathological (and very likely not human made), but
it's a clear incentive to get rid of an old kludge in generic instantiation,
whereby the full view of a type is forced on nodes in the generic unit even
though only the partial declaration is visible to them.

gcc/ada/
	PR ada/124596
	* sem_ch12.ads (Check_Private_View): Move around.
	* sem_ch12.adb (Check_Private_View): Retrieve the partial view
	by means of a call to Incomplete_Or_Partial_View.
	(Save_Global_References.Set_Global_Type): Do not force the full
	view of a type when only the partial declaration is visible.
	* sem_res.adb (Resolve_Actuals.Insert_Default): Remove obsolete
	code coping with the above kludge.

gcc/testsuite/
	* gnat.dg/generic_inst21.adb: New test.

diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index c2697c74f969646754d08585cba4c1d583e4bc50..2710d0545f454e7e3fd8f1ff7d626c294a1c440b 100644 (file)
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -9235,15 +9235,19 @@ package body Sem_Ch12 is
            and then (not In_Open_Scopes (Scope (Typ))
                       or else Nkind (Parent (N)) = N_Subtype_Declaration)
          then
+            --  In the generic unit, only the private declaration was visible,
+            --  so restore the partial view of Typ when there was an explicit
+            --  declaration of its full view.
+
             declare
-               Assoc : constant Node_Id := Get_Associated_Node (N);
+               Priv_Typ : constant Entity_Id :=
+                 Incomplete_Or_Partial_View (Typ, Partial_Only => True);
 
             begin
-               --  In the generic, only the private declaration was visible
-
-               Prepend_Elmt (Typ, Exchanged_Views);
-               Exchange_Declarations
-                 (if Comparison then Compare_Type (Assoc) else Etype (Assoc));
+               if Present (Priv_Typ) then
+                  Prepend_Elmt (Typ, Exchanged_Views);
+                  Exchange_Declarations (Priv_Typ);
+               end if;
             end;
 
          --  Check that the available views of Typ match their respective flag.
@@ -18607,22 +18611,10 @@ package body Sem_Ch12 is
          elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then
             null;
 
-         --  Otherwise mark the type for flipping and set the full view on N2
-         --  when available, which is necessary for Check_Private_View to swap
-         --  back the views in case the full declaration of Typ is visible in
-         --  the instantiation context. Note that this will be problematic if
-         --  N2 is re-analyzed later, e.g. if it's a default value in a call.
+         --  Otherwise mark the node as seeing the private view
 
          else
             Set_Has_Private_View (N);
-
-            if Present (Full_View (Typ)) then
-               if Comparison then
-                  Set_Compare_Type (N2, Full_View (Typ));
-               else
-                  Set_Etype (N2, Full_View (Typ));
-               end if;
-            end if;
          end if;
 
          if Is_Floating_Point_Type (Typ)

diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads
index 478d968ce9522c678a7f6fde3a58beeea786e8d7..94f6f9829b1f833ea87d45229b64a0e79380475d 100644 (file)
--- a/gcc/ada/sem_ch12.ads
+++ b/gcc/ada/sem_ch12.ads
@@ -64,6 +64,22 @@ package Sem_Ch12 is
    --  this call, then Parent_Installed is set True, otherwise Parent_Installed
    --  is unchanged by the call.
 
+   procedure Check_Private_View (N : Node_Id);
+   --  Check whether the type of a generic entity has a different view between
+   --  the point of generic analysis and the point of instantiation. If the
+   --  view has changed, then at the point of instantiation we restore the
+   --  correct view to perform semantic analysis of the instance, and reset
+   --  the current view after instantiation. The processing is driven by the
+   --  current private status of the type of the node, and Has_Private_View,
+   --  a flag that is set at the point of generic compilation. If view and
+   --  flag are inconsistent then the type is updated appropriately. A second
+   --  flag Has_Secondary_Private_View is used to update a second type related
+   --  to this type if need be.
+   --
+   --  This subprogram is used in Check_Generic_Actuals and Copy_Generic_Node,
+   --  and is exported here for the purpose of front-end inlining (see Exp_Ch6.
+   --  Expand_Inlined_Call.Process_Formals).
+
    function Copy_Generic_Node
      (N             : Node_Id;
       Parent_Id     : Node_Id;
@@ -228,20 +244,4 @@ package Sem_Ch12 is
    procedure Initialize;
    --  Initializes internal data structures
 
-   procedure Check_Private_View (N : Node_Id);
-   --  Check whether the type of a generic entity has a different view between
-   --  the point of generic analysis and the point of instantiation. If the
-   --  view has changed, then at the point of instantiation we restore the
-   --  correct view to perform semantic analysis of the instance, and reset
-   --  the current view after instantiation. The processing is driven by the
-   --  current private status of the type of the node, and Has_Private_View,
-   --  a flag that is set at the point of generic compilation. If view and
-   --  flag are inconsistent then the type is updated appropriately. A second
-   --  flag Has_Secondary_Private_View is used to update a second type related
-   --  to this type if need be.
-   --
-   --  This subprogram is used in Check_Generic_Actuals and Copy_Generic_Node,
-   --  and is exported here for the purpose of front-end inlining (see Exp_Ch6.
-   --  Expand_Inlined_Call.Process_Formals).
-
 end Sem_Ch12;

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 7f168499426fb3a8f4b791e49e9bf2b1afa8d395..53cef024b3260c2875c8bbdb8fc85db76b807c85 100644 (file)
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -4038,23 +4038,6 @@ package body Sem_Res is
                  and then Has_Discriminants (Etype (Actval))
                then
                   Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
-
-               --  Resolve entities with their own type, which may differ from
-               --  the type of a reference in a generic context because of the
-               --  trick used in Save_Global_References.Set_Global_Type to set
-               --  full views forcefully, which did not anticipate the need to
-               --  re-analyze default values in calls.
-
-               elsif Is_Entity_Name (Actval) then
-                  Analyze_And_Resolve (Actval, Etype (Entity (Actval)));
-
-               --  Ditto for calls whose name is an entity, for the same reason
-
-               elsif Nkind (Actval) = N_Function_Call
-                 and then Is_Entity_Name (Name (Actval))
-               then
-                  Analyze_And_Resolve (Actval, Etype (Entity (Name (Actval))));
-
                else
                   Analyze_And_Resolve (Actval, Etype (Actval));
                end if;

diff --git a/gcc/testsuite/gnat.dg/generic_inst21.adb b/gcc/testsuite/gnat.dg/generic_inst21.adb
new file mode 100644 (file)
index 0000000..78ca5f0
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/generic_inst21.adb
@@ -0,0 +1,50 @@
+-- { dg-do compile }
+
+procedure Generic_Inst21 is
+
+   package Config is
+      type Config_Data is private;
+   private
+      type Config_Data is null record;
+   end Config;
+
+   generic
+   package Config_Saving is
+
+      type Config_Saver is synchronized interface;
+
+      procedure Register_For_Saving
+        (This : in out Config_Saver; Config_Data : Config.Config_Data)
+      is abstract;
+
+      type Instance is synchronized new Config_Saver with private;
+
+   private
+
+      protected type Instance is new Config_Saver with
+         overriding
+         procedure Register_For_Saving (Config_Data : Config.Config_Data);
+      end Instance;
+
+   end Config_Saving;
+
+   package body Config_Saving is
+
+      protected body Instance is
+         procedure Register_For_Saving (Config_Data : Config.Config_Data) is
+         begin
+            null;
+         end Register_For_Saving;
+      end Instance;
+
+   end Config_Saving;
+
+   package My_Config_Saving is new Config_Saving;
+
+   X : aliased My_Config_Saving.Instance;
+   Y : access My_Config_Saving.Config_Saver'Class := X'Access;
+   Z : Config.Config_Data;
+
+begin
+   Y.Register_For_Saving (Z);
+end;