Ada: Fix generic formal subprogram with implicit default wrongly rejected

It's another issue with a formal subprogram parameter of a generic unit,
whose default is specified by a box and the actual is omitted, so an
implicit actual with the name of the formal is used instead and resolved
in the context of the instance.

The problem is that, for a child generic unit, the parent unit needs to be
loaded during the instantiation, but it cannot be used to resolve implicit
actuals, which must be resolved in the context of the instance.  So an
ad-hoc mechanism is implemented to prune references to the parent unit(s)
for this resolution, but that's wrong if the parent unit was loaded at an
earlier point in the context of the instance.

The fix disables this ad-hoc mechanism in the case where the parent unit
has not been loaded during the instantiation by propagating the boolean
Parent_Installed flag through the call chain.

gcc/ada/
	PR ada/34511
	* sem_ch12.adb (Analyze_Associations): Add Parent_Installed formal
	parameter and pass it in call to Analyze_One_Association.
	(Analyze_One_Association): Add Parent_Installed formal parameter
	and pass it in call to Instantiate_Formal_Subprogram.
	(Analyze_Formal_Package_Declaration): Pass Parent_Installed in call
	to Analyze_Associations.
	(Analyze_Package_Instantiation): Likewise.
	(Analyze_Subprogram_Instantiation): Likewise.
	(Instantiate_Formal_Subprogram): Add Parent_Installed formal
	parameter and prune references to the parent unit(s) only if
	it is true.

gcc/testsuite/
	* gnat.dg/specs/generic_inst4-child2.ads: New test.
	* gnat.dg/specs/generic_inst4.ads: New helper.
	* gnat.dg/specs/generic_inst4-child1.ads: Likewise.

diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 24d276ba48ae7e6df92cc51de6aac662ba108d56..9a155b9b48109e5d5dc3b099a1cbf0e14fd55211 100644 (file)
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -480,14 +480,16 @@ package body Sem_Ch12 is
    --  Create a new access type with the given designated type
 
    function Analyze_Associations
-     (N       : Node_Id;
-      Formals : List_Id;
-      F_Copy  : List_Id) return List_Id;
+     (N                : Node_Id;
+      Formals          : List_Id;
+      F_Copy           : List_Id;
+      Parent_Installed : Boolean) return List_Id;
    --  At instantiation time, build the list of associations between formals
    --  and actuals. Each association becomes a renaming declaration for the
    --  formal entity. N is the instantiation node. Formals is the list of
-   --  unanalyzed formals. F_Copy is the analyzed list of formals in the
-   --  generic copy.
+   --  unanalyzed formals. F_Copy is the list of analyzed formals in the
+   --  generic copy. Parent_Installed is True if the parent has been installed
+   --  during the instantiation.
 
    procedure Analyze_Subprogram_Instantiation
      (N : Node_Id;
@@ -838,9 +840,12 @@ package body Sem_Ch12 is
    --  the same list it is passing to Actual_Decls.
 
    function Instantiate_Formal_Subprogram
-     (Formal          : Node_Id;
-      Actual          : Node_Id;
-      Analyzed_Formal : Node_Id) return Node_Id;
+     (Formal           : Node_Id;
+      Actual           : Node_Id;
+      Analyzed_Formal  : Node_Id;
+      Parent_Installed : Boolean) return Node_Id;
+   --  Parent_Installed is True if the parent has been installed during the
+   --  instantiation.
 
    function Instantiate_Formal_Package
      (Formal          : Node_Id;
@@ -1283,12 +1288,14 @@ package body Sem_Ch12 is
    procedure Analyze_One_Association
      (N                 : Node_Id;
       Assoc             : Associations.Assoc_Rec;
+      Parent_Installed  : Boolean;
       Result_Renamings  : List_Id;
       Default_Actuals   : List_Id;
       Actuals_To_Freeze : Elist_Id);
-   --  Called by Analyze_Associations for each association. The renamings
-   --  are appended onto Result_Renamings. Defaulted actuals are appended
-   --  onto Default_Actuals, and actuals that require freezing are
+   --  Called by Analyze_Associations for each association. Parent_Installed
+   --  is True if the parent has been installed during the instantiation. The
+   --  renamings are appended onto Result_Renamings. The defaulted actuals are
+   --  appended onto Default_Actuals, and actuals that require freezing are
    --  appended onto Actuals_To_Freeze.
 
    procedure Analyze_Structural_Associations
@@ -2362,9 +2369,10 @@ package body Sem_Ch12 is
    --------------------------
 
    function Analyze_Associations
-     (N       : Node_Id;
-      Formals : List_Id;
-      F_Copy  : List_Id) return List_Id
+     (N                : Node_Id;
+      Formals          : List_Id;
+      F_Copy           : List_Id;
+      Parent_Installed : Boolean) return List_Id
    is
       use Associations;
 
@@ -2412,6 +2420,7 @@ package body Sem_Ch12 is
                Analyze_One_Association
                  (N,
                   Assoc,
+                  Parent_Installed,
                   Result_Renamings,
                   Default_Actuals,
                   Actuals_To_Freeze);
@@ -2470,6 +2479,7 @@ package body Sem_Ch12 is
    procedure Analyze_One_Association
      (N                 : Node_Id;
       Assoc             : Associations.Assoc_Rec;
+      Parent_Installed  : Boolean;
       Result_Renamings  : List_Id;
       Default_Actuals   : List_Id;
       Actuals_To_Freeze : Elist_Id)
@@ -2736,7 +2746,10 @@ package body Sem_Ch12 is
             else
                Append_To (Result_Renamings,
                  Instantiate_Formal_Subprogram
-                   (Assoc.Un_Formal, Match, Assoc.An_Formal));
+                   (Assoc.Un_Formal,
+                    Match,
+                    Assoc.An_Formal,
+                    Parent_Installed));
 
                --  If formal subprogram has contracts, create wrappers
                --  for it. This is an expansion activity that cannot
@@ -3557,7 +3570,7 @@ package body Sem_Ch12 is
       --  List of primitives made temporarily visible in the instantiation
       --  to match the visibility of the formal type.
 
-      function Build_Local_Package return Node_Id;
+      function Build_Local_Package (Parent_Installed : Boolean) return Node_Id;
       --  The formal package is rewritten so that its parameters are replaced
       --  with corresponding declarations. For parameters with bona fide
       --  associations these declarations are created by Analyze_Associations
@@ -3569,7 +3582,8 @@ package body Sem_Ch12 is
       -- Build_Local_Package --
       -------------------------
 
-      function Build_Local_Package return Node_Id is
+      function Build_Local_Package (Parent_Installed : Boolean) return Node_Id
+      is
          Decls     : List_Id;
          Pack_Decl : Node_Id;
 
@@ -3645,9 +3659,10 @@ package body Sem_Ch12 is
 
                Decls :=
                  Analyze_Associations
-                   (N       => Original_Node (N),
-                    Formals => Generic_Formal_Declarations (Act_Tree),
-                    F_Copy  => Generic_Formal_Declarations (Gen_Decl));
+                   (N                => Original_Node (N),
+                    Formals          => Generic_Formal_Declarations (Act_Tree),
+                    F_Copy           => Generic_Formal_Declarations (Gen_Decl),
+                    Parent_Installed => Parent_Installed);
 
                Vis_Prims_List := Check_Hidden_Primitives (Decls);
             end;
@@ -3782,7 +3797,7 @@ package body Sem_Ch12 is
       --  internal declarations.
 
       begin
-         New_N := Build_Local_Package;
+         New_N := Build_Local_Package (Parent_Installed);
 
       --  If there are errors in the parameter list, Analyze_Associations
       --  raises Instantiation_Error. Patch the declaration to prevent further
@@ -5159,9 +5174,10 @@ package body Sem_Ch12 is
 
          Renamings :=
            Analyze_Associations
-             (N       => N,
-              Formals => Generic_Formal_Declarations (Act_Tree),
-              F_Copy  => Generic_Formal_Declarations (Gen_Decl));
+             (N                => N,
+              Formals          => Generic_Formal_Declarations (Act_Tree),
+              F_Copy           => Generic_Formal_Declarations (Gen_Decl),
+              Parent_Installed => Parent_Installed);
 
          --  Bail out if the instantiation has been turned into something else
 
@@ -6981,9 +6997,10 @@ package body Sem_Ch12 is
 
          Renamings :=
            Analyze_Associations
-             (N       => N,
-              Formals => Generic_Formal_Declarations (Act_Tree),
-              F_Copy  => Generic_Formal_Declarations (Gen_Decl));
+             (N                => N,
+              Formals          => Generic_Formal_Declarations (Act_Tree),
+              F_Copy           => Generic_Formal_Declarations (Gen_Decl),
+              Parent_Installed => Parent_Installed);
 
          --  Bail out if the instantiation has been turned into something else
 
@@ -12538,9 +12555,10 @@ package body Sem_Ch12 is
    -----------------------------------
 
    function Instantiate_Formal_Subprogram
-     (Formal          : Node_Id;
-      Actual          : Node_Id;
-      Analyzed_Formal : Node_Id) return Node_Id
+     (Formal           : Node_Id;
+      Actual           : Node_Id;
+      Analyzed_Formal  : Node_Id;
+      Parent_Installed : Boolean) return Node_Id
    is
       Analyzed_S : constant Entity_Id :=
                      Defining_Unit_Name (Specification (Analyzed_Formal));
@@ -12548,13 +12566,7 @@ package body Sem_Ch12 is
                      Defining_Unit_Name (Specification (Formal));
 
       function From_Parent_Scope (Subp : Entity_Id) return Boolean;
-      --  If the generic is a child unit, the parent has been installed on the
-      --  scope stack, but a default subprogram cannot resolve to something
-      --  on the parent because that parent is not really part of the visible
-      --  context (it is there to resolve explicit local entities). If the
-      --  default has resolved in this way, we remove the entity from immediate
-      --  visibility and analyze the node again to emit an error message or
-      --  find another visible candidate.
+      --  Return true if Subp is declared in a parent scope of Analyzed_S
 
       procedure Valid_Actual_Subprogram (Act : Node_Id);
       --  Perform legality check and raise exception on failure
@@ -12812,21 +12824,31 @@ package body Sem_Ch12 is
       end if;
 
       --  Gather possible interpretations for the actual before analyzing the
-      --  instance. If overloaded, it will be resolved when analyzing the
-      --  renaming declaration.
+      --  instance. If the actual is overloaded, then it will be resolved when
+      --  the renaming declaration is analyzed.
 
       if Box_Present (Formal) and then No (Actual) then
          Analyze (Nam);
 
-         if Is_Child_Unit (Scope (Analyzed_S))
-           and then Present (Entity (Nam))
+         --  If the generic is a child unit and the parent has been installed
+         --  during this instantiation (as opposed to having been installed in
+         --  the context of the instantiation at some earlier point), a default
+         --  subprogram cannot resolve to something in the parent because the
+         --  parent is not really part of the visible context (it is there to
+         --  resolve explicit local entities). If the default subprogram has
+         --  been resolved in this way, we remove the entity from immediate
+         --  visibility and analyze the node again to emit an error message
+         --  or find another visible candidate.
+
+         if Present (Entity (Nam))
+           and then Is_Child_Unit (Scope (Analyzed_S))
+           and then Parent_Installed
          then
             if not Is_Overloaded (Nam) then
                if From_Parent_Scope (Entity (Nam)) then
                   Set_Is_Immediately_Visible (Entity (Nam), False);
                   Set_Entity (Nam, Empty);
                   Set_Etype (Nam, Empty);
-
                   Analyze (Nam);
                   Set_Is_Immediately_Visible (Entity (Nam));
                end if;

diff --git a/gcc/testsuite/gnat.dg/specs/generic_inst4-child1.ads b/gcc/testsuite/gnat.dg/specs/generic_inst4-child1.ads
new file mode 100644 (file)
index 0000000..2e5d7ef
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/specs/generic_inst4-child1.ads
@@ -0,0 +1,6 @@
+generic
+
+  with procedure Proc is <>;
+
+package Generic_Inst4.Child1 is
+end Generic_Inst4.Child1;

diff --git a/gcc/testsuite/gnat.dg/specs/generic_inst4-child2.ads b/gcc/testsuite/gnat.dg/specs/generic_inst4-child2.ads
new file mode 100644 (file)
index 0000000..c84709e
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/specs/generic_inst4-child2.ads
@@ -0,0 +1,5 @@
+-- { dg-do compile }
+
+with Generic_Inst4.Child1;
+
+package Generic_Inst4.Child2 is new Generic_Inst4.Child1;

diff --git a/gcc/testsuite/gnat.dg/specs/generic_inst4.ads b/gcc/testsuite/gnat.dg/specs/generic_inst4.ads
new file mode 100644 (file)
index 0000000..01e4ad4
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/specs/generic_inst4.ads
@@ -0,0 +1,5 @@
+package Generic_Inst4 is
+
+  procedure Proc is null;
+
+end Generic_Inst4;