https://gcc.gnu.org/g:1f679fd10f93d23ad274a5c583b9cef463bf7954
commit r13-9437-g1f679fd10f93d23ad274a5c583b9cef463bf7954
Author: Eric Botcazou <ebotca...@adacore.com>
Date: Wed Mar 19 08:22:33 2025 +0100
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:
---
gcc/ada/gen_il-gen-gen_nodes.adb | 2 +-
gcc/ada/sem_ch12.adb | 31 ++++++++++++++++++----
gcc/testsuite/gnat.dg/generic_inst14.adb | 20 ++++++++++++++
gcc/testsuite/gnat.dg/generic_inst14_pkg-child.ads | 27 +++++++++++++++++++
gcc/testsuite/gnat.dg/generic_inst14_pkg.ads | 16 +++++++++++
5 files changed, 90 insertions(+), 6 deletions(-)
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index 389c9a0f005c..ecac44c798d5 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -1393,7 +1393,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
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 89581bd5bb60..9290e88d51e4 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -10546,6 +10546,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 =>
@@ -10560,9 +10561,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.
@@ -10801,6 +10799,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
@@ -10856,11 +10874,14 @@ 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);
diff --git a/gcc/testsuite/gnat.dg/generic_inst14.adb
b/gcc/testsuite/gnat.dg/generic_inst14.adb
new file mode 100644
index 000000000000..562bde604560
--- /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
index 000000000000..8ad17c4389f0
--- /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
index 000000000000..b1334f6d6351
--- /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;
