Ada: Fix bogus error on aggregate in call with qualified type in instance

This happens with a container aggregate in the testcase, although this can
very likely happen with a record aggregate as well.  The trick used in the
Save_Global_References procedure for aggregates loses the qualification of
the type of the formal for which the aggregate is the actual.

gcc/ada/
	PR ada/123302
	* sem_ch12.adb (Save_Global_Reference.Save_References_In_Aggregate):
	Recurse on the scope of the type to find one that is visible, in the
	case of an actual in a subprogram call with a local type.

gcc/testsuite/
	* gnat.dg/aggr34.adb: New test.
	* gnat.dg/aggr34_pkg1.ads, gnat.dg/aggr34_pkg1.adb: New helper.
	* gnat.dg/aggr34_pkg2.ads, gnat.dg/aggr34_pkg2.adb: Likewise.
	* gnat.dg/aggr34_pkg3.ads: Likewise.

diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 3bff9394c835ca5e141f3a817f93399aed6dacaa..d2478d24ec85f5b99e5f14238b0e9499ddc65598 100644 (file)
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -18064,7 +18064,6 @@ package body Sem_Ch12 is
          ----------------------------------
 
          procedure Save_References_In_Aggregate (N : Node_Id) is
-            Nam   : Node_Id;
             Qual  : Node_Id   := Empty;
             Typ   : Entity_Id := Empty;
 
@@ -18120,16 +18119,16 @@ package body Sem_Ch12 is
                   end;
                end if;
 
-               --  If the aggregate is an actual in a call, it has been
-               --  resolved in the current context, to some local type. The
+               --  If the aggregate is an actual in a subprogram call, it has
+               --  been resolved in the current context to some local type. The
                --  enclosing call may have been disambiguated by the aggregate,
                --  and this disambiguation might fail at instantiation time
                --  because the type to which the aggregate did resolve is not
                --  preserved. In order to preserve some of this information,
                --  wrap the aggregate in a qualified expression, using the id
                --  of its type. For further disambiguation we qualify the type
-               --  name with its scope (if visible and not hidden by a local
-               --  homograph) because both id's will have corresponding
+               --  name with its scope recursively (if visible and not hidden
+               --  by a local homograph) because both will have corresponding
                --  entities in an instance. This resolves most of the problems
                --  with missing type information on aggregates in instances.
 
@@ -18139,24 +18138,40 @@ package body Sem_Ch12 is
                  and then Present (Typ)
                  and then Comes_From_Source (Typ)
                then
-                  Nam := Make_Identifier (Loc, Chars (Typ));
+                  declare
+                     function Qualify_Name (S, E : Entity_Id) return Node_Id is
+                       (if E = S
+                        then Make_Identifier (Loc, Chars (E))
+                        else Make_Selected_Component (Loc,
+                               Prefix        => Qualify_Name (S, Scope (E)),
+                               Selector_Name =>
+                                 Make_Identifier (Loc, Chars (E))));
+                     --  Return the qualified name of E up to scope S
+
+                     Nam : Node_Id;
+                     S   : Entity_Id;
 
-                  if Is_Immediately_Visible (Scope (Typ))
-                    and then
-                      (not In_Open_Scopes (Scope (Typ))
-                         or else Current_Entity (Scope (Typ)) = Scope (Typ))
-                  then
-                     Nam :=
-                       Make_Selected_Component (Loc,
-                         Prefix        =>
-                           Make_Identifier (Loc, Chars (Scope (Typ))),
-                         Selector_Name => Nam);
-                  end if;
+                  begin
+                     S := Scope (Typ);
+                     while not Is_Immediately_Visible (S) loop
+                        S := Scope (S);
+                        exit when Is_Generic_Unit (S);
+                     end loop;
 
-                  Qual :=
-                    Make_Qualified_Expression (Loc,
-                      Subtype_Mark => Nam,
-                      Expression   => Relocate_Node (N));
+                     if not Is_Generic_Unit (S)
+                       and then (not In_Open_Scopes (S)
+                                  or else Current_Entity (S) = S)
+                     then
+                        Nam := Qualify_Name (S, Typ);
+                     else
+                        Nam := Make_Identifier (Loc, Chars (Typ));
+                     end if;
+
+                     Qual :=
+                       Make_Qualified_Expression (Loc,
+                         Subtype_Mark => Nam,
+                         Expression   => Relocate_Node (N));
+                  end;
                end if;
 
             --  For a full aggregate, if the type is global and a derived

diff --git a/gcc/testsuite/gnat.dg/aggr34.adb b/gcc/testsuite/gnat.dg/aggr34.adb
new file mode 100644 (file)
index 0000000..41c324e
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/aggr34.adb
@@ -0,0 +1,15 @@
+-- PR ada/123302
+-- { dg-do link }
+-- { dg-options "-gnat2022" }
+
+with Aggr34_Pkg3;
+with Aggr34_Pkg1;
+
+procedure Aggr34 is
+
+  package My_Pkg3 is new Aggr34_Pkg3;
+  package My_Pkg1 is new Aggr34_Pkg1 (My_Pkg3);
+
+begin
+  My_Pkg1.Proc;
+end;

diff --git a/gcc/testsuite/gnat.dg/aggr34_pkg1.adb b/gcc/testsuite/gnat.dg/aggr34_pkg1.adb
new file mode 100644 (file)
index 0000000..e930de0
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/aggr34_pkg1.adb
@@ -0,0 +1,6 @@
+-- { dg-do compile }
+-- { dg-options "-gnat2022" }
+
+package body Aggr34_Pkg1 is
+   procedure Proc is null;
+end Aggr34_Pkg1;

diff --git a/gcc/testsuite/gnat.dg/aggr34_pkg1.ads b/gcc/testsuite/gnat.dg/aggr34_pkg1.ads
new file mode 100644 (file)
index 0000000..6febc51
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/aggr34_pkg1.ads
@@ -0,0 +1,9 @@
+with Aggr34_Pkg3;
+with Aggr34_Pkg2;
+
+generic
+   with package My_Config is new Aggr34_Pkg3;
+package Aggr34_Pkg1 is
+   package My_Module_Basic_Config is new Aggr34_Pkg2 (My_Config);
+   procedure Proc;
+end Aggr34_Pkg1;

diff --git a/gcc/testsuite/gnat.dg/aggr34_pkg2.adb b/gcc/testsuite/gnat.dg/aggr34_pkg2.adb
new file mode 100644 (file)
index 0000000..6775627
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/aggr34_pkg2.adb
@@ -0,0 +1,9 @@
+-- { dg-do compile }
+-- { dg-options "-gnat2022" }
+
+package body Aggr34_Pkg2 is
+   procedure Disable_Prunt is
+   begin
+      My_Config.Set (["a", "b"]);
+   end Disable_Prunt;
+end Aggr34_Pkg2;

diff --git a/gcc/testsuite/gnat.dg/aggr34_pkg2.ads b/gcc/testsuite/gnat.dg/aggr34_pkg2.ads
new file mode 100644 (file)
index 0000000..176a7a6
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/aggr34_pkg2.ads
@@ -0,0 +1,7 @@
+with Aggr34_Pkg3;
+
+generic
+   with package My_Config is new Aggr34_Pkg3;
+package Aggr34_Pkg2 is
+   procedure Disable_Prunt;
+end Aggr34_Pkg2;

diff --git a/gcc/testsuite/gnat.dg/aggr34_pkg3.ads b/gcc/testsuite/gnat.dg/aggr34_pkg3.ads
new file mode 100644 (file)
index 0000000..5f7960f
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/aggr34_pkg3.ads
@@ -0,0 +1,8 @@
+with Ada.Containers.Indefinite_Vectors;
+
+generic
+package Aggr34_Pkg3 is
+   package Config_Data_Paths is new
+     Ada.Containers.Indefinite_Vectors (Positive, String);
+   procedure Set (Path : Config_Data_Paths.Vector) is null;
+end Aggr34_Pkg3;