Merge branch 'topic/1030-2' into 'master'

Fix private visibility of child units.

Closes #1030

See merge request eng/libadalang/libadalang!1404

ada/ast.py

@@ -902,26 +902,6 @@ def resolve_names_from_closest_entry_point():
         result = Var(Entity.resolve_names_from_closest_entry_point_impl)
         return result != No(LexicalEnv)
 
-    @langkit_property(return_type=LexicalEnv)
-    def parent_unit_env_helper(unit=AnalysisUnit, env=LexicalEnv):
-        return env.env_parent.then(lambda parent_env: parent_env.env_node.then(
-            lambda parent_node: If(
-                parent_node.unit == unit,
-                Self.parent_unit_env_helper(unit, parent_env),
-                parent_env
-            )
-        ))
-
-    @langkit_property()
-    def parent_unit_env(env=LexicalEnv):
-        """
-        Given env's AnalysisUnit, return the first env that has a different
-        analysis unit in the env parent chain.
-        """
-        return env.then(
-            lambda env: Self.parent_unit_env_helper(env.env_node.unit, env)
-        )
-
     @langkit_property(return_type=T.AnalysisUnit, public=True,
                       external=True, uses_entity_info=False, uses_envs=False)
     def standard_unit():
@@ -1080,6 +1060,39 @@ def root_type_ops(sym=T.Symbol):
         """
     )
 
+    @langkit_property(return_type=T.Bool)
+    def parent_has_with_visibility(refd_unit=T.AnalysisUnit,
+                                   self_cu=T.CompilationUnit,
+                                   has_private_view=T.Bool):
+        """
+        Return whether the parent unit of this node has with visibility on
+        the given analysis unit. In particular, this takes into account
+        private visibility: for a given node which is inside a body or a
+        private part, it will forward to the query in the parent unit the
+        fact that the origin node has visibility on the ``private with``
+        clauses of the parent unit.
+        """
+        should_have_private_view = Var(
+            has_private_view | self_cu.has_private_view(Self)
+        )
+        return self_cu.decl.as_bare_entity.semantic_parent.then(
+            lambda parent: If(
+                # In our implementation, the semantic parent of a child package
+                # is always the private part of the parent package (see note in
+                # ``PackageDecl``'s ``env_spec``). But if we are not supposed
+                # to have view on the private part, we must perform the query
+                # outside of it, here from the parent of the private part.
+                parent.is_a(PrivatePart) & Not(should_have_private_view),
+                parent.parent.has_with_visibility(
+                    refd_unit, omit_privacy_check=False
+                ),
+
+                parent.has_with_visibility(
+                    refd_unit, omit_privacy_check=should_have_private_view
+                )
+            )
+        )
+
     @langkit_property(return_type=Bool)
     def has_private_part_parent(barrier=T.AdaNode):
         """
@@ -1091,12 +1104,12 @@ def has_private_part_parent(barrier=T.AdaNode):
         same visibility privileges of private parts (i.e. they can see "private
         with"s).
         """
-        parent = Var(Self.node_env.env_node)
         return Or(
-            parent.is_null,
-            parent.is_a(PrivatePart),
-            And(parent != barrier,
-                parent.has_private_part_parent(barrier))
+            Self.is_a(PrivatePart),
+            (Self != barrier) & Self.node_env.env_node.then(
+                lambda parent: parent.has_private_part_parent(barrier),
+                default_val=True
+            )
         )
 
     @langkit_property(return_type=Bool)
@@ -1109,22 +1122,15 @@ def has_private_with_visibility(self_cu=T.CompilationUnit,
         private part.
         """
         return Or(
+            # If the referenced unit is ourself, we don't need further checks
             Self.unit == refd_unit,
 
-            # A private package necessarily has private-with visibility
-            self_cu.body.cast(LibraryItem)._.has_private.as_bool,
-
-            Let(lambda decl=self_cu.decl: If(
-                # Private visibility only makes sense when we are in a package
-                # declaration, so check that we are in this case first.
-                decl.is_a(BasePackageDecl, GenericPackageDecl)
-                # If we are, check whether the referenced unit is only visible
-                # in private parts.
-                & self_cu.privately_imported_units.contains(refd_unit),
-                # If it's the case, check that we are in a private part
-                Self.has_private_part_parent(decl.children_env.env_node),
-                True
-            ))
+            # If we have view on "private with"s, we don't need further checks
+            self_cu.has_private_view(Self),
+
+            # But if we don't, so we must return False if the referenced unit
+            # is only visible from private parts.
+            Not(self_cu.privately_imported_units.contains(refd_unit)),
         )
 
     @langkit_property(return_type=Bool)
@@ -1138,22 +1144,16 @@ def has_with_visibility(refd_unit=AnalysisUnit,
         """
         cu = Var(Self.enclosing_compilation_unit)
         return Or(
+            # First, check whether this unit "with"s the referenced unit
             refd_unit.is_referenced_from(Self.unit)
             & (omit_privacy_check
                | Self.has_private_with_visibility(cu, refd_unit)),
 
-            Self.parent_unit_env(
-                # Here we go and explicitly grab the top level item, rather
-                # than use Self's children env, because of use clauses, that
-                # can be at the top level but semantically belong to the env of
-                # the top level item.
-                cu.decl.children_env
-            ).env_node._.has_with_visibility(
+            # If it doesn't, check whether its parent unit does
+            Self.parent_has_with_visibility(
                 refd_unit,
-
-                # A child unit necessarily has view on the private part of its
-                # parent unit, so we should not discard "private with"s.
-                omit_privacy_check=True
+                cu,
+                has_private_view=omit_privacy_check
             ),
 
             # With clauses from a library level subprogram declaration are
@@ -20806,6 +20806,27 @@ def stub_for_impl(su=T.Subunit):
         """
         pass
 
+    @langkit_property(return_type=T.Bool)
+    def has_private_view(origin=T.AdaNode):
+        """
+        Return whether the given ``origin`` node has view on "private withs" of
+        its unit or parent units.
+        """
+        decl = Var(Self.decl)
+        return Or(
+            # A private package necessarily has private-with visibility
+            Self.body.cast(LibraryItem)._.has_private.as_bool,
+
+            # If this compilation doesn't declare a package, then we
+            # necessarily have private-with visibility because it means we are
+            # inside a body.
+            Not(decl.is_a(BasePackageDecl, GenericPackageDecl)),
+
+            # Otherwise (this compilation unit declares a package), check
+            # whether `origin` lies in a private part.
+            origin.has_private_part_parent(decl.children_env.env_node),
+        )
+
 
 @abstract
 class BaseSubpBody(Body):

testsuite/tests/name_resolution/private_with_4/containers.ads

@@ -0,0 +1,3 @@
+package Containers is
+   I : Integer := 1;
+end Containers;

testsuite/tests/name_resolution/private_with_4/pkg-foo.ads

@@ -0,0 +1,4 @@
+package Pkg.Foo is
+   package Socket_Lists is new Containers.Doubly_Linked_Lists (Integer);
+   pragma Test_Statement;
+end Pkg.Foo;

testsuite/tests/name_resolution/private_with_4/pkg.ads

@@ -0,0 +1,10 @@
+with Ada; use Ada;
+with Ada.Containers.Doubly_Linked_Lists;
+
+private
+with Containers;
+
+package Pkg is
+   package Socket_Lists is new Containers.Doubly_Linked_Lists (Integer);
+   pragma Test_Statement; -- OK
+end Pkg;

testsuite/tests/name_resolution/private_with_4/pkg_2-foo.ads

@@ -0,0 +1,4 @@
+package Pkg_2.Foo is
+   package Socket_Lists is new Containers.Doubly_Linked_Lists (Integer);
+   pragma Test_Statement;
+end Pkg_2.Foo;

testsuite/tests/name_resolution/private_with_4/pkg_2.ads

@@ -0,0 +1,12 @@
+with Ada; use Ada;
+with Ada.Containers.Doubly_Linked_Lists;
+
+private
+with Containers;
+
+package Pkg_2 is
+   package Socket_Lists is new Containers.Doubly_Linked_Lists (Integer);
+   pragma Test_Statement; -- OK
+private
+   Tmp : Integer;
+end Pkg_2;

testsuite/tests/name_resolution/private_with_4/test.out

@@ -0,0 +1,49 @@
+Analyzing pkg-foo.ads
+#####################
+
+Resolving xrefs for node <GenericPackageInstantiation ["Socket_Lists"] pkg-foo.ads:2:4-2:73>
+********************************************************************************************
+
+Expr: <DottedName pkg-foo.ads:2:32-2:62>
+  references:    <DefiningName "Ada.Containers.Doubly_Linked_Lists" a-cdlili.ads:47:9-47:43>
+  type:          None
+  expected type: None
+Expr: <Id "Containers" pkg-foo.ads:2:32-2:42>
+  references:    <DefiningName "Ada.Containers" a-contai.ads:16:9-16:23>
+  type:          None
+  expected type: None
+Expr: <Id "Doubly_Linked_Lists" pkg-foo.ads:2:43-2:62>
+  references:    <DefiningName "Ada.Containers.Doubly_Linked_Lists" a-cdlili.ads:47:9-47:43>
+  type:          None
+  expected type: None
+Expr: <Id "Integer" pkg-foo.ads:2:64-2:71>
+  references:    <DefiningName "Integer" __standard:4:8-4:15>
+  type:          None
+  expected type: None
+
+
+Analyzing pkg_2-foo.ads
+#######################
+
+Resolving xrefs for node <GenericPackageInstantiation ["Socket_Lists"] pkg_2-foo.ads:2:4-2:73>
+**********************************************************************************************
+
+Expr: <DottedName pkg_2-foo.ads:2:32-2:62>
+  references:    <DefiningName "Ada.Containers.Doubly_Linked_Lists" a-cdlili.ads:47:9-47:43>
+  type:          None
+  expected type: None
+Expr: <Id "Containers" pkg_2-foo.ads:2:32-2:42>
+  references:    <DefiningName "Ada.Containers" a-contai.ads:16:9-16:23>
+  type:          None
+  expected type: None
+Expr: <Id "Doubly_Linked_Lists" pkg_2-foo.ads:2:43-2:62>
+  references:    <DefiningName "Ada.Containers.Doubly_Linked_Lists" a-cdlili.ads:47:9-47:43>
+  type:          None
+  expected type: None
+Expr: <Id "Integer" pkg_2-foo.ads:2:64-2:71>
+  references:    <DefiningName "Integer" __standard:4:8-4:15>
+  type:          None
+  expected type: None
+
+
+Done.

testsuite/tests/name_resolution/private_with_4/test.yaml

@@ -0,0 +1,2 @@
+driver: name-resolution
+input_sources: [pkg-foo.ads, pkg_2-foo.ads]

testsuite/tests/name_resolution/private_with_5/foo.ads

@@ -0,0 +1,3 @@
+package Foo is
+   X : Integer;
+end Foo;

testsuite/tests/name_resolution/private_with_5/pkg-bar.adb

@@ -0,0 +1,7 @@
+package body Pkg.Bar is
+   function Test return Integer is
+   begin
+      return Foo.X;
+      pragma Test_Statement;
+   end Test;
+end Pkg.Bar;

testsuite/tests/name_resolution/private_with_5/pkg-bar.ads

@@ -0,0 +1,6 @@
+private package Pkg.Bar is
+   function Test return Integer;
+
+   Y : Integer := Foo.X;
+   pragma Test_Statement;
+end Pkg.Bar;

testsuite/tests/name_resolution/private_with_5/pkg.ads

@@ -0,0 +1,4 @@
+private with Foo;
+
+package Pkg is
+end Pkg;

testsuite/tests/name_resolution/private_with_5/test.out

@@ -0,0 +1,45 @@
+Analyzing pkg-bar.ads
+#####################
+
+Resolving xrefs for node <ObjectDecl ["Y"] pkg-bar.ads:4:4-4:25>
+****************************************************************
+
+Expr: <Id "Integer" pkg-bar.ads:4:8-4:15>
+  references:    <DefiningName "Integer" __standard:4:8-4:15>
+  type:          None
+  expected type: None
+Expr: <DottedName pkg-bar.ads:4:19-4:24>
+  references:    <DefiningName "X" foo.ads:2:4-2:5>
+  type:          <ConcreteTypeDecl ["Integer"] __standard:4:3-4:54>
+  expected type: <ConcreteTypeDecl ["Integer"] __standard:4:3-4:54>
+Expr: <Id "Foo" pkg-bar.ads:4:19-4:22>
+  references:    <DefiningName "Foo" foo.ads:1:9-1:12>
+  type:          None
+  expected type: None
+Expr: <Id "X" pkg-bar.ads:4:23-4:24>
+  references:    <DefiningName "X" foo.ads:2:4-2:5>
+  type:          <ConcreteTypeDecl ["Integer"] __standard:4:3-4:54>
+  expected type: <ConcreteTypeDecl ["Integer"] __standard:4:3-4:54>
+
+
+Analyzing pkg-bar.adb
+#####################
+
+Resolving xrefs for node <ReturnStmt pkg-bar.adb:4:7-4:20>
+**********************************************************
+
+Expr: <DottedName pkg-bar.adb:4:14-4:19>
+  references:    <DefiningName "X" foo.ads:2:4-2:5>
+  type:          <ConcreteTypeDecl ["Integer"] __standard:4:3-4:54>
+  expected type: <ConcreteTypeDecl ["Integer"] __standard:4:3-4:54>
+Expr: <Id "Foo" pkg-bar.adb:4:14-4:17>
+  references:    <DefiningName "Foo" foo.ads:1:9-1:12>
+  type:          None
+  expected type: None
+Expr: <Id "X" pkg-bar.adb:4:18-4:19>
+  references:    <DefiningName "X" foo.ads:2:4-2:5>
+  type:          <ConcreteTypeDecl ["Integer"] __standard:4:3-4:54>
+  expected type: <ConcreteTypeDecl ["Integer"] __standard:4:3-4:54>
+
+
+Done.

testsuite/tests/name_resolution/private_with_5/test.yaml

@@ -0,0 +1,2 @@
+driver: name-resolution
+input_sources: [pkg-bar.ads, pkg-bar.adb]

user_manual/changes/1030.yaml

@@ -0,0 +1,8 @@
+type: bugfix
+title: Fix private-with visibility in child units
+description: |
+  This change fixes a bug where child units were previously assumed to always
+  have view on ``private with`` clauses of their parent unit, which is not the
+  case in their public part. This could cause name resolution to incorrectly
+  resolve names to entities that were not supposed to be visible.
+date: 2023-09-11