Merge branch 'topic/1447' into 'master'

Shed rebindings after collapsing entries

Closes #1447

See merge request eng/libadalang/libadalang!1775

ada/nodes.lkt

@@ -272,18 +272,41 @@ class AdaNode implements Node[AdaNode] {
     |" ``[My_Pkg, I]``. However, ``add_rebinding`` sees that ``I`` is
     |" rebound by the instantiation of ``My_Pkg`` and therefore collapses
     |" the two rebindings from ``[My_Pkg, I]`` to ``[My_Interface]``.
-    fun add_rebinding(base: EnvRebindings, old_env: LexicalEnv, new_env: LexicalEnv): EnvRebindings = {
+    fun add_rebinding(base: EnvRebindings,
+                      old_env: LexicalEnv,
+                      new_env: LexicalEnv): EnvRebindings = {
         val parent_env = new_env.env_node.node_env();
 
-        if base.is_null or not parent_env.env_node is GenericDecl or not node.is_rebound(base, parent_env) then base.append_rebinding(old_env, new_env)
-        elif base.old_env == parent_env then base.new_env.get_first(
-            new_env.env_node.as[GenericPackageInstantiation].name.name_symbol(), lookup=LookupKind.minimal
-        ).as[GenericPackageInstantiation].do(
-            (gpi) => node.add_rebinding(
-                base.get_parent, gpi.nonbound_generic_decl_from_self().node.children_env(), gpi.instantiation_env
-            ), default_val=base.append_rebinding(old_env, new_env)
-        )
-        else node.add_rebinding(base.get_parent, old_env, new_env)
+        if (
+            base.is_null
+            or not parent_env.env_node is GenericDecl
+            or not node.is_rebound(base, parent_env)
+        ) then
+            base.append_rebinding(old_env, new_env)
+        elif base.old_env == parent_env then
+            base.new_env.get_first(
+                new_env.env_node.as[GenericPackageInstantiation].name.name_symbol(),
+                lookup=LookupKind.minimal
+            ).as[GenericPackageInstantiation].do(
+                (gpi) => {
+                    val gen_env = gpi.nonbound_generic_decl_from_self().node.children_env();
+                    val info = EntityInfo(
+                        md=null[Metadata],
+                        rebindings=node.add_rebinding(
+                            base.get_parent,
+                            gen_env,
+                            gpi.instantiation_env
+                        ),
+                        from_rebound=false
+                    );
+                    # Collapsing may make some entries irrelevant, so shed
+                    # rebindings at this point to remove those.
+                    gen_env.shed_rebindings(info).rebindings
+                },
+                default_val=base.append_rebinding(old_env, new_env)
+            )
+        else
+            node.add_rebinding(base.get_parent, old_env, new_env)
     }
 
     |" Return whether ``old_env`` is rebound somewhere inside the given
@@ -4331,15 +4354,16 @@ class BasicDecl: AdaNode {
         ).as[BaseTypeDecl].classwide_type().as[BaseTypeDecl];
         val params = self.subp_spec_or_null()?.unpacked_formal_params();
 
-        {
-            bind origin = node.origin_node();
+        bind origin = node.origin_node();
 
-            (
-                node.is_subprogram() and params?[0].formal_decl().formal_type().is_access_to(root_stream_type)
-            ) and (
-                if return_obj then self.subp_spec_or_null().return_type().matching_formal_type(typ) else params?[1].formal_decl().formal_type().matching_formal_type(typ)
-            )
-        }
+        node.is_subprogram()
+        and params?[0].formal_decl().formal_type().is_access_to(root_stream_type)
+        and (
+            if return_obj then
+                self.subp_spec_or_null().return_type().matching_formal_type(typ)
+            else
+                params?[1].formal_decl().formal_type().matching_formal_type(typ)
+        )
     }
 
     |" Return whether this subprogram has the correct profile to be given
@@ -5805,7 +5829,7 @@ class BaseTypeDecl: BasicDecl {
 
     @with_dynvars(origin)
     fun is_access_to(typ: Entity[BaseTypeDecl]): Bool =
-        self?.accessed_type().matching_formal_type(typ)
+        self?.accessed_type()?.matching_formal_type(typ)
 
     |" Returns whether self is an access type whose accessed type matches
     |" other.

testsuite/tests/name_resolution/collapse_rebindings_2/test.adb

@@ -0,0 +1,33 @@
+procedure Test is
+   generic
+   package Vectors is
+      type U is null record;
+      type U_Acc is access U;
+
+      N : constant U_Acc := new U;
+   end Vectors;
+
+   generic
+      with package Vec is new Vectors (<>);
+   package Interface_G is
+   end Interface_G;
+
+   generic
+   package Base_G is
+      package Vec is new Vectors;
+
+      generic
+      package Inner_G is
+         package Itf is new Interface_G (Vec);
+      end Inner_G;
+   end Base_G;
+
+   generic
+      with package Base is new Base_G (<>);
+   package Pkg_G is
+      package Inner is new Base.Inner_G;
+      pragma Test_Statement;
+   end Pkg_G;
+begin
+   null;
+end Test;

testsuite/tests/name_resolution/collapse_rebindings_2/test.out

@@ -0,0 +1,116 @@
+Analyzing test.adb
+##################
+
+Resolving xrefs for node <GenericPackageInstantiation ["Inner"] test.adb:28:7-28:41>
+************************************************************************************
+
+Expr: <DottedName test.adb:28:28-28:40>
+  references:    <| DefiningName "Inner_G" test.adb:20:15-20:22 [test.adb:26:12] |>
+  type:          None
+  expected type: None
+Expr: <Id "Base" test.adb:28:28-28:32>
+  references:    <DefiningName "Base" test.adb:26:20-26:24>
+  type:          None
+  expected type: None
+Expr: <Id "Inner_G" test.adb:28:33-28:40>
+  references:    <| DefiningName "Inner_G" test.adb:20:15-20:22 [test.adb:26:12] |>
+  type:          None
+  expected type: None
+Traversing generic node <| GenericPackageDecl ["Inner_G"] test.adb:19:7-22:19 [test.adb:26:12, test.adb:28:7] |>
+****************************************************************************************************************
+
+Resolving xrefs for node <| GenericPackageInstantiation ["Itf"] test.adb:21:10-21:47 [test.adb:26:12, test.adb:28:7] |>
+***********************************************************************************************************************
+
+Expr: <| Id "Interface_G" test.adb:21:29-21:40 [test.adb:26:12, test.adb:28:7] |>
+  references:    <DefiningName "Interface_G" test.adb:12:12-12:23>
+  type:          None
+  expected type: None
+Expr: <| Id "Vec" test.adb:21:42-21:45 [test.adb:26:12, test.adb:28:7] |>
+  references:    <| DefiningName "Vec" test.adb:17:15-17:18 [test.adb:26:12] |>
+  type:          None
+  expected type: None
+Traversing generic node <| GenericPackageDecl ["Interface_G"] test.adb:10:4-13:20 [test.adb:26:12, test.adb:28:7, test.adb:21:10] |>
+************************************************************************************************************************************
+
+Resolving xrefs for node <| GenericPackageInstantiation ["Vec"] test.adb:11:12-11:44 [test.adb:26:12, test.adb:28:7, test.adb:21:10] |>
+***************************************************************************************************************************************
+
+Expr: <| Id "Vectors" test.adb:11:31-11:38 [test.adb:26:12, test.adb:28:7, test.adb:21:10] |>
+  references:    <DefiningName "Vectors" test.adb:3:12-3:19>
+  type:          None
+  expected type: None
+Expr: <| BoxExpr test.adb:11:40-11:42 [test.adb:26:12, test.adb:28:7, test.adb:21:10] |>
+  type:          None
+  expected type: None
+Traversing generic node <| GenericPackageDecl ["Vectors"] test.adb:2:4-8:16 [test.adb:26:12, test.adb:17:7] |>
+**************************************************************************************************************
+
+Resolving xrefs for node <| ConcreteTypeDecl ["U"] test.adb:4:7-4:29 [test.adb:26:12, test.adb:17:7] |>
+*******************************************************************************************************
+
+
+Resolving xrefs for node <| ConcreteTypeDecl ["U_Acc"] test.adb:5:7-5:30 [test.adb:26:12, test.adb:17:7] |>
+***********************************************************************************************************
+
+Expr: <| Id "U" test.adb:5:28-5:29 [test.adb:26:12, test.adb:17:7] |>
+  references:    <| DefiningName "U" test.adb:4:12-4:13 [test.adb:26:12, test.adb:17:7] |>
+  type:          None
+  expected type: None
+
+Resolving xrefs for node <| ObjectDecl ["N"] test.adb:7:7-7:35 [test.adb:26:12, test.adb:17:7] |>
+*************************************************************************************************
+
+Expr: <| Id "U_Acc" test.adb:7:20-7:25 [test.adb:26:12, test.adb:17:7] |>
+  references:    <| DefiningName "U_Acc" test.adb:5:12-5:17 [test.adb:26:12, test.adb:17:7] |>
+  type:          None
+  expected type: None
+Expr: <| Allocator test.adb:7:29-7:34 [test.adb:26:12, test.adb:17:7] |>
+  type:          <| ConcreteTypeDecl ["U_Acc"] test.adb:5:7-5:30 [test.adb:26:12, test.adb:17:7] |>
+  expected type: <| ConcreteTypeDecl ["U_Acc"] test.adb:5:7-5:30 [test.adb:26:12, test.adb:17:7] |>
+Expr: <| Id "U" test.adb:7:33-7:34 [test.adb:26:12, test.adb:17:7] |>
+  references:    <| DefiningName "U" test.adb:4:12-4:13 [test.adb:26:12, test.adb:17:7] |>
+  type:          None
+  expected type: None
+
+Resolving xrefs for node <| EndName test.adb:8:8-8:15 [test.adb:26:12, test.adb:17:7] |>
+****************************************************************************************
+
+Expr: <| EndName test.adb:8:8-8:15 [test.adb:26:12, test.adb:17:7] |>
+  references:    <| DefiningName "Vec" test.adb:17:15-17:18 [test.adb:26:12] |>
+  type:          None
+  expected type: None
+Expr: <| Id "Vectors" test.adb:8:8-8:15 [test.adb:26:12, test.adb:17:7] |>
+  references:    <| DefiningName "Vec" test.adb:17:15-17:18 [test.adb:26:12] |>
+  type:          None
+  expected type: None
+
+
+Resolving xrefs for node <| EndName test.adb:13:8-13:19 [test.adb:26:12, test.adb:28:7, test.adb:21:10] |>
+**********************************************************************************************************
+
+Expr: <| EndName test.adb:13:8-13:19 [test.adb:26:12, test.adb:28:7, test.adb:21:10] |>
+  references:    <| DefiningName "Itf" test.adb:21:18-21:21 [test.adb:26:12, test.adb:28:7] |>
+  type:          None
+  expected type: None
+Expr: <| Id "Interface_G" test.adb:13:8-13:19 [test.adb:26:12, test.adb:28:7, test.adb:21:10] |>
+  references:    <| DefiningName "Itf" test.adb:21:18-21:21 [test.adb:26:12, test.adb:28:7] |>
+  type:          None
+  expected type: None
+
+
+Resolving xrefs for node <| EndName test.adb:22:11-22:18 [test.adb:26:12, test.adb:28:7] |>
+*******************************************************************************************
+
+Expr: <| EndName test.adb:22:11-22:18 [test.adb:26:12, test.adb:28:7] |>
+  references:    <DefiningName "Inner" test.adb:28:15-28:20>
+  type:          None
+  expected type: None
+Expr: <| Id "Inner_G" test.adb:22:11-22:18 [test.adb:26:12, test.adb:28:7] |>
+  references:    <DefiningName "Inner" test.adb:28:15-28:20>
+  type:          None
+  expected type: None
+
+
+
+Done.

testsuite/tests/name_resolution/collapse_rebindings_2/test.yaml

@@ -0,0 +1,3 @@
+driver: name-resolution
+traverse_generics: true
+input_sources: [test.adb]

testsuite/tests/name_resolution/generic_formal_package_dot_access/test.out

@@ -41,38 +41,38 @@ Expr: <| Id "Trait" trait.ads:6:43-6:48 [pkg.ads:5:9, pkg.ads:12:7] |>
 Expr: <| BoxExpr trait.ads:6:50-6:52 [pkg.ads:5:9, pkg.ads:12:7] |>
   type:          None
   expected type: None
-Traversing generic node <| GenericPackageDecl ["Trait"] trait_impl.ads:2:4-6:14 [pkg.ads:5:9, pkg.ads:11:7] |>
-**************************************************************************************************************
+Traversing generic node <| GenericPackageDecl ["Trait"] trait_impl.ads:2:4-6:14 [pkg.ads:11:7] |>
+*************************************************************************************************
 
-Resolving xrefs for node <| FormalTypeDecl ["T"] trait_impl.ads:3:7-3:25 [pkg.ads:5:9, pkg.ads:11:7] |>
-*******************************************************************************************************
+Resolving xrefs for node <| FormalTypeDecl ["T"] trait_impl.ads:3:7-3:25 [pkg.ads:11:7] |>
+******************************************************************************************
 
 
-Resolving xrefs for node <| ConcreteFormalSubpDecl ["Foo"] trait_impl.ads:4:12-4:34 [pkg.ads:5:9, pkg.ads:11:7] |>
-******************************************************************************************************************
+Resolving xrefs for node <| ConcreteFormalSubpDecl ["Foo"] trait_impl.ads:4:12-4:34 [pkg.ads:11:7] |>
+*****************************************************************************************************
 
 
-Resolving xrefs for node <| SubpSpec trait_impl.ads:4:12-4:33 [pkg.ads:5:9, pkg.ads:11:7] |>
-********************************************************************************************
+Resolving xrefs for node <| SubpSpec trait_impl.ads:4:12-4:33 [pkg.ads:11:7] |>
+*******************************************************************************
 
 
-Resolving xrefs for node <| ParamSpec ["X"] trait_impl.ads:4:27-4:32 [pkg.ads:5:9, pkg.ads:11:7] |>
-***************************************************************************************************
+Resolving xrefs for node <| ParamSpec ["X"] trait_impl.ads:4:27-4:32 [pkg.ads:11:7] |>
+**************************************************************************************
 
-Expr: <| Id "T" trait_impl.ads:4:31-4:32 [pkg.ads:5:9, pkg.ads:11:7] |>
+Expr: <| Id "T" trait_impl.ads:4:31-4:32 [pkg.ads:11:7] |>
   references:    <DefiningName "T" pkg.ads:8:12-8:13>
   type:          None
   expected type: None
 
-Resolving xrefs for node <| EndName trait_impl.ads:6:8-6:13 [pkg.ads:5:9, pkg.ads:11:7] |>
-******************************************************************************************
+Resolving xrefs for node <| EndName trait_impl.ads:6:8-6:13 [pkg.ads:11:7] |>
+*****************************************************************************
 
-Expr: <| EndName trait_impl.ads:6:8-6:13 [pkg.ads:5:9, pkg.ads:11:7] |>
-  references:    <| DefiningName "My_Trait_Impl" pkg.ads:11:15-11:28 [pkg.ads:5:9] |>
+Expr: <| EndName trait_impl.ads:6:8-6:13 [pkg.ads:11:7] |>
+  references:    <DefiningName "My_Trait_Impl" pkg.ads:11:15-11:28>
   type:          None
   expected type: None
-Expr: <| Id "Trait" trait_impl.ads:6:8-6:13 [pkg.ads:5:9, pkg.ads:11:7] |>
-  references:    <| DefiningName "My_Trait_Impl" pkg.ads:11:15-11:28 [pkg.ads:5:9] |>
+Expr: <| Id "Trait" trait_impl.ads:6:8-6:13 [pkg.ads:11:7] |>
+  references:    <DefiningName "My_Trait_Impl" pkg.ads:11:15-11:28>
   type:          None
   expected type: None
 

testsuite/tests/name_resolution/write_attr/test.adb

@@ -11,6 +11,8 @@ procedure Test is
    procedure Write (Stream : access Root_Stream_Type'Class; Item : D2) is null;
    procedure Write
      (Stream : access Root_Stream_Type'Class; Item : Float) is null;
+   procedure Write
+     (S : Integer; Item : Float);  -- independent overload
 
    for D1'Write use Write;
    pragma Test_Statement;

testsuite/tests/name_resolution/write_attr/test.out

@@ -1,42 +1,42 @@
 Analyzing test.adb
 ##################
 
-Resolving xrefs for node <AttributeDefClause test.adb:15:4-15:27>
+Resolving xrefs for node <AttributeDefClause test.adb:17:4-17:27>
 *****************************************************************
 
-Expr: <AttributeRef test.adb:15:8-15:16>
+Expr: <AttributeRef test.adb:17:8-17:16>
   references:    None
   type:          None
   expected type: None
-Expr: <Id "D1" test.adb:15:8-15:10>
+Expr: <Id "D1" test.adb:17:8-17:10>
   references:    <DefiningName "D1" test.adb:6:9-6:11>
   type:          <ConcreteTypeDecl ["D1"] test.adb:6:4-6:21>
   expected type: None
-Expr: <Id "Write" test.adb:15:11-15:16>
+Expr: <Id "Write" test.adb:17:11-17:16>
   references:    None
   type:          None
   expected type: None
-Expr: <Id "Write" test.adb:15:21-15:26>
+Expr: <Id "Write" test.adb:17:21-17:26>
   references:    <DefiningName "Write" test.adb:9:14-9:19>
   type:          None
   expected type: None
 
-Resolving xrefs for node <AttributeDefClause test.adb:17:4-17:27>
+Resolving xrefs for node <AttributeDefClause test.adb:19:4-19:27>
 *****************************************************************
 
-Expr: <AttributeRef test.adb:17:8-17:16>
+Expr: <AttributeRef test.adb:19:8-19:16>
   references:    None
   type:          None
   expected type: None
-Expr: <Id "D2" test.adb:17:8-17:10>
+Expr: <Id "D2" test.adb:19:8-19:10>
   references:    <DefiningName "D2" test.adb:7:9-7:11>
   type:          <ConcreteTypeDecl ["D2"] test.adb:7:4-7:22>
   expected type: None
-Expr: <Id "Write" test.adb:17:11-17:16>
+Expr: <Id "Write" test.adb:19:11-19:16>
   references:    None
   type:          None
   expected type: None
-Expr: <Id "Write" test.adb:17:21-17:26>
+Expr: <Id "Write" test.adb:19:21-19:26>
   references:    <DefiningName "Write" test.adb:11:14-11:19>
   type:          None
   expected type: None