Fix spurious visibility error with partially parameterized formal package

This is not a regression but the issue is quite annoying and the fix is
trivial.  The problem is that a formal parameter covered by a box in the
formal package is not visible in the instance when it comes after another
formal parameter that is also a formal package.

It comes from a discrepancy internal to Instantiate_Formal_Package, where
a specific construct (the abbreviated instance) built for the nested formal
package discombobulates the processing done for the outer formal package.

gcc/ada/
	* gen_il-gen-gen_nodes.adb (N_Formal_Package_Declaration): Use
	N_Declaration instead of Node_Kind as ancestor.
	* sem_ch12.adb (Get_Formal_Entity): Remove obsolete alternative.
	(Instantiate_Formal_Package): Take into account the abbreviated
	instances in the main loop running over the actuals of the local
	package created for the formal package.

gcc/testsuite/
	* gnat.dg/generic_inst14.adb: New test.
	* gnat.dg/generic_inst14_pkg.ads: New helper.
	* gnat.dg/generic_inst14_pkg-child.ads: Likewise.

diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index 1f5dc6d3803e0090127bb0dcb483b0ba80034e8f..eb035361b570f9f5f19fc9ed50daa0075e128872 100644 (file)
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -1309,7 +1309,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
    Cc (N_Formal_Modular_Type_Definition, Node_Kind);
    Cc (N_Formal_Ordinary_Fixed_Point_Definition, Node_Kind);
 
-   Cc (N_Formal_Package_Declaration, Node_Kind,
+   Cc (N_Formal_Package_Declaration, N_Declaration,
        (Sy (Defining_Identifier, Node_Id),
         Sy (Name, Node_Id, Default_Empty),
         Sy (Generic_Associations, List_Id, Default_No_List),

diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index dad8c73729e90f4b989b20644acc4b9b49be76d1..5768e28e90fcecaf2e9ec5cac66ca69807742c0a 100644 (file)
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -11551,6 +11551,7 @@ package body Sem_Ch12 is
 
       function Get_Formal_Entity (N : Node_Id) return Entity_Id is
          Kind : constant Node_Kind := Nkind (Original_Node (N));
+
       begin
          case Kind is
             when N_Formal_Object_Declaration =>
@@ -11565,9 +11566,6 @@ package body Sem_Ch12 is
             when N_Formal_Package_Declaration =>
                return Defining_Identifier (Original_Node (N));
 
-            when N_Generic_Package_Declaration =>
-               return Defining_Identifier (Original_Node (N));
-
             --  All other declarations are introduced by semantic analysis and
             --  have no match in the actual.
 
@@ -11806,6 +11804,26 @@ package body Sem_Ch12 is
                   end if;
 
                   Next_Non_Pragma (Formal_Node);
+
+                  --  If the actual of the local package created for the formal
+                  --  is itself an instantiated formal package, then it could
+                  --  have given rise to additional declarations, see the code
+                  --  dealing with conformance checking below.
+
+                  if Nkind (Actual_Of_Formal) = N_Package_Renaming_Declaration
+                    and then Requires_Conformance_Checking
+                               (Declaration_Node
+                                 (Associated_Formal_Package
+                                   (Defining_Entity (Actual_Of_Formal))))
+                  then
+                     Next (Actual_Of_Formal);
+                     pragma Assert
+                       (Nkind (Actual_Of_Formal) = N_Package_Declaration);
+                     Next (Actual_Of_Formal);
+                     pragma Assert
+                       (Nkind (Actual_Of_Formal) = N_Package_Instantiation);
+                  end if;
+
                   Next (Actual_Of_Formal);
 
                   --  A formal subprogram may be overloaded, so advance in
@@ -11861,10 +11879,15 @@ package body Sem_Ch12 is
          --  checking, because it contains formal declarations for those
          --  defaulted parameters, and those should not reach the back-end.
 
+         --  This processing needs to be synchronized with the pattern matching
+         --  done in the main loop of the above block that starts with the test
+         --  on Requires_Conformance_Checking.
+
          if Requires_Conformance_Checking (Formal) then
             declare
                I_Pack : constant Entity_Id := Make_Temporary (Loc, 'P');
-               I_Nam : Node_Id;
+               I_Nam  : Node_Id;
+
             begin
                Set_Is_Internal (I_Pack);
                Mutate_Ekind (I_Pack, E_Package);

diff --git a/gcc/testsuite/gnat.dg/generic_inst14.adb b/gcc/testsuite/gnat.dg/generic_inst14.adb
new file mode 100644 (file)
index 0000000..562bde6
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/generic_inst14.adb
@@ -0,0 +1,20 @@
+--  { dg-do compile }
+
+with Generic_Inst14_Pkg;
+with Generic_Inst14_Pkg.Child;
+
+procedure Generic_Inst14 is
+
+   type T is null record;
+
+   package Tree is new Generic_Inst14_Pkg.Definite_Value_Tree (T);
+
+   package Base is new Generic_Inst14_Pkg.Child.Simple (T, Tree);
+
+   package OK is new Generic_Inst14_Pkg.Child.OK (T, Base.Strat);
+
+   package Not_OK is new Generic_Inst14_Pkg.Child.Not_OK (T, Tree, Base.Strat);
+
+begin
+   null;
+end;

diff --git a/gcc/testsuite/gnat.dg/generic_inst14_pkg-child.ads b/gcc/testsuite/gnat.dg/generic_inst14_pkg-child.ads
new file mode 100644 (file)
index 0000000..8ad17c4
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/generic_inst14_pkg-child.ads
@@ -0,0 +1,27 @@
+package Generic_Inst14_Pkg.Child is
+
+   generic
+      type Value is private;
+      with package Value_Tree is new Definite_Value_Tree (Value => Value);
+   package Simple is
+      type Node is new Value_Tree.Value_Node with null record;
+      package Strat is new Def_Strat (Value, Value_Tree, Node);
+   end Simple;
+
+   generic
+      type Value is private;
+      with package A_Strat is new Def_Strat (Value => Value, others => <>);
+   package OK is
+      procedure Plop (N : A_Strat.Node) is null;
+   end OK;
+
+   generic
+      type Value is private;
+      with package Value_Tree is new Definite_Value_Tree (Value => Value);
+      with package A_Strat is
+         new Def_Strat (Value => Value, Value_Tree => Value_Tree, others => <>);
+   package Not_OK is
+      procedure Plop (N : A_Strat.Node) is null;
+   end Not_OK;
+   
+end Generic_Inst14_Pkg.Child;

diff --git a/gcc/testsuite/gnat.dg/generic_inst14_pkg.ads b/gcc/testsuite/gnat.dg/generic_inst14_pkg.ads
new file mode 100644 (file)
index 0000000..b1334f6
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/generic_inst14_pkg.ads
@@ -0,0 +1,16 @@
+package Generic_Inst14_Pkg is
+
+   generic
+      type Value is limited private;
+   package Definite_Value_Tree is
+      type Value_Node is abstract tagged null record; 
+   end Definite_Value_Tree;
+   
+   generic
+      type Value is limited private;
+      with package Value_Tree is new Definite_Value_Tree (Value);
+      type Node (<>) is new Value_Tree.Value_Node with private;
+   package Def_Strat is
+   end Def_Strat;
+
+end Generic_Inst14_Pkg;