https://gcc.gnu.org/g:eebee8f21d727231cf3db837684cb6cafb066fb0
commit r16-5100-geebee8f21d727231cf3db837684cb6cafb066fb0 Author: Eric Botcazou <[email protected]> Date: Sat Nov 8 19:15:46 2025 +0100 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: --- gcc/ada/sem_ch10.adb | 41 ++++++++++------------ .../specs/{limited_with4.ads => limited_with1.ads} | 8 ++--- gcc/testsuite/gnat.dg/specs/limited_with1_pkg.ads | 15 ++++++++ .../gnat.dg/specs/limited_with2-child1.ads | 6 ++++ .../gnat.dg/specs/limited_with2-child2.ads | 6 ++++ gcc/testsuite/gnat.dg/specs/limited_with2.ads | 2 ++ gcc/testsuite/gnat.dg/specs/limited_with4_pkg.ads | 15 -------- 7 files changed, 51 insertions(+), 42 deletions(-) diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index cff0d71c17ce..9cd86d6bc1d2 100644 --- 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 53fb676470ac..f8fc01bdb78e 100644 --- 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 index 000000000000..b1d09e431fe5 --- /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 index 000000000000..aae2f74971b0 --- /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 index 000000000000..10c77fa701d8 --- /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 index 000000000000..7a8cbf786868 --- /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 index 3d690bde079c..000000000000 --- 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;
