Ada: Fix bogus error on limited with clause and private parent package

The implementation of the 10.1.2(8/2-11/2) subclauses that establish rules
for the legality of "with" clauses of private child units is done separately
for regular "with" clauses (in Check_Private_Child_Unit) and for limited
"with" clauses (in Check_Private_Limited_Withed_Unit).  The testcase, which
contains the regular and the "limited" version of the same pattern, exhibits
a disagreement between them; the former implementation is correct and the
latter is wrong in this case.

The patch fixes the problem and also cleans up the latter implementation by
aligning it with the former as much as possible.

gcc/ada/
	PR ada/34374
	* sem_ch10.adb (Check_Private_Limited_Withed_Unit): Use a separate
	variable for the private child unit, streamline the loop locating
	the nearest private ancestor, fix a too early termination of the
	loop traversing the ancestor of the current unit, and use the same
	privacy test as Check_Private_Child_Unit.

gcc/testsuite/
	* gnat.dg/specs/limited_with4.ads: Rename to...
	* gnat.dg/specs/limited_with1.ads: ...this.
	* gnat.dg/specs/limited_with4_pkg.ads: Rename to...
	* gnat.dg/specs/limited_with1_pkg.ads: ...this.
	* gnat.dg/specs/limited_with2-child1.ads: New test.
	* gnat.dg/specs/limited_with2-child2.ads: Likewise.
	* gnat.dg/specs/limited_with2.ads: New helper.

diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index cff0d71c17ceeb7f1417c94ba4328f43633d3b30..9cd86d6bc1d29b502b5fd0ccb4b0d450d60107f1 100644 (file)
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -4337,43 +4337,38 @@ package body Sem_Ch10 is
       ---------------------------------------
 
       procedure Check_Private_Limited_Withed_Unit (Item : Node_Id) is
-         Curr_Parent  : Node_Id;
          Child_Parent : Node_Id;
+         Curr_Parent  : Node_Id;
          Curr_Private : Boolean;
+         Priv_Child   : Node_Id;
 
       begin
-         --  Compilation unit of the parent of the withed library unit
+         --  Start with the compilation unit of the withed library unit
 
-         Child_Parent := Withed_Lib_Unit (Item);
+         Priv_Child := Withed_Lib_Unit (Item);
 
          --  If the child unit is a public child, then locate its nearest
-         --  private ancestor, if any, then Child_Parent will then be set to
+         --  private ancestor, if any. Child_Parent will then be set to
          --  the parent of that ancestor.
 
-         if not Private_Present (Withed_Lib_Unit (Item)) then
-            while Present (Child_Parent)
-              and then not Private_Present (Child_Parent)
-            loop
-               Child_Parent := Parent_Spec (Unit (Child_Parent));
-            end loop;
-
-            if No (Child_Parent) then
+         while not Private_Present (Priv_Child) loop
+            Priv_Child := Parent_Spec (Unit (Priv_Child));
+            if No (Priv_Child) then
                return;
             end if;
-         end if;
+         end loop;
 
-         Child_Parent := Parent_Spec (Unit (Child_Parent));
+         Child_Parent := Parent_Spec (Unit (Priv_Child));
 
          --  Traverse all the ancestors of the current compilation unit to
-         --  check if it is a descendant of named library unit.
+         --  check if it is a descendant of Child_Parent.
 
-         Curr_Parent := Parent (Item);
+         Curr_Parent := N;
          Curr_Private := Private_Present (Curr_Parent);
 
-         while Present (Parent_Spec (Unit (Curr_Parent)))
-           and then Curr_Parent /= Child_Parent
-         loop
+         while Curr_Parent /= Child_Parent loop
             Curr_Parent := Parent_Spec (Unit (Curr_Parent));
+            exit when No (Curr_Parent);
             Curr_Private := Curr_Private or else Private_Present (Curr_Parent);
          end loop;
 
@@ -4384,11 +4379,11 @@ package body Sem_Ch10 is
               ("\current unit must also have parent&!",
                Item, Defining_Unit_Name (Specification (Unit (Child_Parent))));
 
-         elsif Private_Present (Parent (Item))
-            or else Curr_Private
+         elsif Curr_Private
             or else Private_Present (Item)
-            or else Nkind (Unit (Parent (Item))) in
-                      N_Package_Body | N_Subprogram_Body | N_Subunit
+            or else Nkind (Unit (N)) in N_Package_Body | N_Subunit
+            or else (Nkind (Unit (N)) = N_Subprogram_Body
+                      and then not Acts_As_Spec (Parent (Unit (N))))
          then
             --  Current unit is private, of descendant of a private unit
 

diff --git a/gcc/testsuite/gnat.dg/specs/limited_with4.ads b/gcc/testsuite/gnat.dg/specs/limited_with1.ads
similarity index 73%
rename from gcc/testsuite/gnat.dg/specs/limited_with4.ads
rename to gcc/testsuite/gnat.dg/specs/limited_with1.ads
index 53fb676470ac2b227d0e9033feb35f52d63782a5..f8fc01bdb78e724de64081136e8bfb9c3bab426c 100644 (file)
--- a/gcc/testsuite/gnat.dg/specs/limited_with4.ads
+++ b/gcc/testsuite/gnat.dg/specs/limited_with1.ads
@@ -2,16 +2,16 @@
 -- { dg-options "-gnatc" }
 
 with Ada.Containers.Vectors;
-with Limited_With4_Pkg;
+with Limited_With1_Pkg;
 
-package Limited_With4 is
+package Limited_With1 is
 
    type Object is tagged private;
    type Object_Ref is access all Object;
    type Class_Ref is access all Object'Class;
 
    package Vec is new Ada.Containers.Vectors
-     (Positive, Limited_With4_Pkg.Object_Ref,Limited_With4_Pkg ."=");
+     (Positive, Limited_With1_Pkg.Object_Ref,Limited_With1_Pkg ."=");
    subtype Vector is Vec.Vector;
 
 private
@@ -20,4 +20,4 @@ private
       V : Vector;
    end record;
 
-end Limited_With4;
+end Limited_With1;

diff --git a/gcc/testsuite/gnat.dg/specs/limited_with1_pkg.ads b/gcc/testsuite/gnat.dg/specs/limited_with1_pkg.ads
new file mode 100644 (file)
index 0000000..b1d09e4
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/specs/limited_with1_pkg.ads
@@ -0,0 +1,15 @@
+-- { dg-do compile }
+-- { dg-options "-gnatc" }
+
+limited with Limited_With1;
+
+package Limited_With1_Pkg is
+
+   type Object is tagged null record;
+   type Object_Ref is access all Object;
+   type Class_Ref is access all Object'Class;
+
+   function Func return Limited_With1.Class_Ref;
+   procedure Proc (Arg : Limited_With1.Class_Ref);
+
+end Limited_With1_Pkg;

diff --git a/gcc/testsuite/gnat.dg/specs/limited_with2-child1.ads b/gcc/testsuite/gnat.dg/specs/limited_with2-child1.ads
new file mode 100644 (file)
index 0000000..aae2f74
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/specs/limited_with2-child1.ads
@@ -0,0 +1,6 @@
+-- { dg-do compile }
+
+with Limited_With2.Child2;
+
+package Limited_With2.Child1 is
+end Limited_With2.Child1;

diff --git a/gcc/testsuite/gnat.dg/specs/limited_with2-child2.ads b/gcc/testsuite/gnat.dg/specs/limited_with2-child2.ads
new file mode 100644 (file)
index 0000000..10c77fa
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/specs/limited_with2-child2.ads
@@ -0,0 +1,6 @@
+-- { dg-do compile }
+
+limited with Limited_With2.Child1;
+
+package Limited_With2.Child2 is
+end Limited_With2.Child2;

diff --git a/gcc/testsuite/gnat.dg/specs/limited_with2.ads b/gcc/testsuite/gnat.dg/specs/limited_with2.ads
new file mode 100644 (file)
index 0000000..7a8cbf7
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/specs/limited_with2.ads
@@ -0,0 +1,2 @@
+private package Limited_With2 is
+end Limited_With2;

diff --git a/gcc/testsuite/gnat.dg/specs/limited_with4_pkg.ads b/gcc/testsuite/gnat.dg/specs/limited_with4_pkg.ads
deleted file mode 100644 (file)
index 3d690bd..0000000
--- a/gcc/testsuite/gnat.dg/specs/limited_with4_pkg.ads
+++ /dev/null
@@ -1,15 +0,0 @@
--- { dg-do compile }
--- { dg-options "-gnatc" }
-
-limited with Limited_With4;
-
-package Limited_With4_Pkg is
-
-   type Object is tagged null record;
-   type Object_Ref is access all Object;
-   type Class_Ref is access all Object'Class;
-
-   function Func return Limited_With4.Class_Ref;
-   procedure Proc (Arg : Limited_With4.Class_Ref);
-
-end Limited_With4_Pkg;