Merge branch 'topic/990' into 'master'

Fix selected components resolution for subprograms

Closes #990

See merge request eng/libadalang/libadalang!1424

ada/ast.py

@@ -7902,8 +7902,7 @@ def dottable_subps_env():
     def dottable_subps():
         """
         Return the list of all subprograms that can be called with the dot-
-        notation on values of this type. We look for them in the public part,
-        private part and body part of the package this type is declared in.
+        notation on values of this type.
 
         This property doesn't implement Ada standard but the GNAT experimental
         feature allowing dot-notation for untagged types.
@@ -7926,30 +7925,47 @@ def dottable_subps():
             # https://github.com/AdaCore/ada-spark-rfcs/blob/master/\
             #   prototyped/rfc-prefixed-untagged.rst.
 
-            pkg.is_null,
-            No(T.inner_env_assoc.array),
-
-            Array([
+            # If we are in a package, we look for subprograms that can be
+            # called with the dot-notation in the public part, private part and
+            # body part of the package this type is declared in.
+            Not(pkg.is_null),
+            Entity.dottable_subps_in_declaratives_parts(Array([
                 pkg.public_part.cast(DeclarativePart),
                 pkg.private_part.cast(DeclarativePart),
                 pkg.body_part._.decls
-            ]).mapcat(
-                lambda dp: dp._.decls.as_array
-            ).filtermap(
-                lambda decl: Let(
-                    lambda bd=decl.cast(BasicDecl): T.inner_env_assoc.new(
-                        key=bd.defining_name.name_symbol,
-                        value=bd.node,
-                        metadata=T.Metadata.new(dottable_subp=True)
-                    )
-                ),
+            ])),
 
-                lambda decl:
-                decl.cast(BasicDecl)
-                ._.subp_spec_or_null._.dottable_subp_of == Entity
+            # Else, we look for subprograms in the declarative region this
+            # type is declared in.
+            Entity.dottable_subps_in_declaratives_parts(
+                Array([scope.as_entity])
             )
         )
 
+    @langkit_property(return_type=T.inner_env_assoc.array)
+    def dottable_subps_in_declaratives_parts(
+        parts=T.DeclarativePart.entity.array
+    ):
+        """
+        Return the list of all subprograms that can be called with the
+        dot-notation on values of this type. We look for them in the
+        declarative parts array ``parts``.
+        """
+        return parts.mapcat(
+            lambda dp: dp._.decls.as_array
+        ).filtermap(
+            lambda decl: Let(
+                lambda bd=decl.cast(BasicDecl): T.inner_env_assoc.new(
+                    key=bd.defining_name.name_symbol,
+                    value=bd.node,
+                    metadata=T.Metadata.new(dottable_subp=True)
+                )
+            ),
+
+            lambda decl: decl.cast(BasicDecl)._.subp_spec_or_null
+            ._.dottable_subp_of._.base_subtype == Entity
+        )
+
     @langkit_property(return_type=T.EnvRebindings, dynamic_vars=[origin])
     def find_base_type_rebindings_among(target=T.BaseTypeDecl,
                                         base_types=T.BaseTypeDecl.entity.array,

testsuite/tests/name_resolution/dottable_subp/foo.ads

@@ -0,0 +1,8 @@
+package Foo is
+   type Container is tagged null record;
+
+   type T is new Container with null record;
+   subtype Record_T is T;
+
+   procedure Init (X : access Record_T'Class; Spacing : Integer := 0) is null;
+end Foo;

testsuite/tests/name_resolution/dottable_subp/pkg.adb

@@ -0,0 +1,22 @@
+with Foo; use Foo;
+
+package body Pkg is
+
+   type Slot_Record_T is new Foo.Record_T with record
+      Dummy : Integer;
+   end record;
+   type Slot_T is access all Slot_Record_T;
+
+   type Record_T is tagged record
+      Slot : Slot_T := null;
+   end record;
+
+   procedure P (X : access Record_T'Class; B : Boolean := False);
+
+   procedure P (X : access Record_T'Class; B : Boolean := False) is
+   begin
+     X.Slot.Init (Spacing => 5);
+     pragma Test_Statement;
+   end P;
+
+end Pkg;

testsuite/tests/name_resolution/dottable_subp/pkg.ads

@@ -0,0 +1,3 @@
+package Pkg is
+   pragma Elaborate_Body;
+end Pkg;

testsuite/tests/name_resolution/dottable_subp/region.adb

@@ -0,0 +1,30 @@
+procedure Region is
+   task T;
+
+   task body T is
+      type P is tagged null record;
+      procedure Not_Prim (Self : P) is null;
+      O : P;
+   begin
+      O.Not_Prim;
+      pragma Test_Statement;
+   end T;
+begin
+   declare
+      type P2 is tagged null record;
+      procedure Not_Prim (Self : P2) is null;
+      O : P2;
+   begin
+      O.Not_Prim;
+      pragma Test_Statement;
+   end;
+
+   declare
+      type P2 is tagged null record;
+      procedure Not_Prim (Self : P2'Class) is null;
+      O : P2;
+   begin
+      O.Not_Prim;
+      pragma Test_Statement;
+   end;
+end Region;

testsuite/tests/name_resolution/dottable_subp/test.out

@@ -18,4 +18,116 @@ Expr: <Id "F" test.adb:16:18-16:19>
   expected type: <ConcreteTypeDecl ["Integer"] __standard:4:3-4:54>
 
 
+Analyzing test_proc.adb
+#######################
+
+Resolving xrefs for node <CallStmt test_proc.adb:11:4-11:8>
+***********************************************************
+
+Expr: <DottedName test_proc.adb:11:4-11:7>
+  references:    <DefiningName "P" test_proc.adb:5:14-5:15>
+  type:          None
+  expected type: None
+Expr: <Id "X" test_proc.adb:11:4-11:5>
+  references:    <DefiningName "X" test_proc.adb:9:4-9:5>
+  type:          <ConcreteTypeDecl ["T2"] test_proc.adb:7:4-7:29>
+  expected type: <AnonymousTypeDecl ["None"] test_proc.adb:5:21-5:36>
+Expr: <Id "P" test_proc.adb:11:6-11:7>
+  references:    <DefiningName "P" test_proc.adb:5:14-5:15>
+  type:          None
+  expected type: None
+
+
+Analyzing pkg.adb
+#################
+
+Resolving xrefs for node <CallStmt pkg.adb:18:6-18:33>
+******************************************************
+
+Expr: <CallExpr pkg.adb:18:6-18:32>
+  references:    <DefiningName "Init" foo.ads:7:14-7:18>
+  type:          None
+  expected type: None
+Expr: <DottedName pkg.adb:18:6-18:17>
+  references:    <DefiningName "Init" foo.ads:7:14-7:18>
+  type:          None
+  expected type: None
+Expr: <DottedName pkg.adb:18:6-18:12>
+  references:    <DefiningName "Slot" pkg.adb:11:7-11:11>
+  type:          <ConcreteTypeDecl ["Slot_T"] pkg.adb:8:4-8:44>
+  expected type: <AnonymousTypeDecl ["None"] foo.ads:7:24-7:45>
+Expr: <Id "X" pkg.adb:18:6-18:7>
+  references:    <DefiningName "X" pkg.adb:16:17-16:18>
+  type:          <AnonymousTypeDecl ["None"] pkg.adb:16:21-16:42>
+  expected type: <ConcreteTypeDecl ["Record_T"] pkg.adb:10:4-12:15>
+Expr: <Id "Slot" pkg.adb:18:8-18:12>
+  references:    <DefiningName "Slot" pkg.adb:11:7-11:11>
+  type:          <ConcreteTypeDecl ["Slot_T"] pkg.adb:8:4-8:44>
+  expected type: <AnonymousTypeDecl ["None"] foo.ads:7:24-7:45>
+Expr: <Id "Init" pkg.adb:18:13-18:17>
+  references:    <DefiningName "Init" foo.ads:7:14-7:18>
+  type:          None
+  expected type: None
+Expr: <Id "Spacing" pkg.adb:18:19-18:26>
+  references:    <DefiningName "Spacing" foo.ads:7:47-7:54>
+  type:          None
+  expected type: None
+Expr: <Int pkg.adb:18:30-18:31>
+  references:    None
+  type:          <ConcreteTypeDecl ["Universal_Int_Type_"] __standard:116:3-116:45>
+  expected type: <ConcreteTypeDecl ["Integer"] __standard:4:3-4:54>
+
+
+Analyzing region.adb
+####################
+
+Resolving xrefs for node <CallStmt region.adb:9:7-9:18>
+*******************************************************
+
+Expr: <DottedName region.adb:9:7-9:17>
+  references:    <DefiningName "Not_Prim" region.adb:6:17-6:25>
+  type:          None
+  expected type: None
+Expr: <Id "O" region.adb:9:7-9:8>
+  references:    <DefiningName "O" region.adb:7:7-7:8>
+  type:          <ConcreteTypeDecl ["P"] region.adb:5:7-5:36>
+  expected type: <ConcreteTypeDecl ["P"] region.adb:5:7-5:36>
+Expr: <Id "Not_Prim" region.adb:9:9-9:17>
+  references:    <DefiningName "Not_Prim" region.adb:6:17-6:25>
+  type:          None
+  expected type: None
+
+Resolving xrefs for node <CallStmt region.adb:18:7-18:18>
+*********************************************************
+
+Expr: <DottedName region.adb:18:7-18:17>
+  references:    <DefiningName "Not_Prim" region.adb:15:17-15:25>
+  type:          None
+  expected type: None
+Expr: <Id "O" region.adb:18:7-18:8>
+  references:    <DefiningName "O" region.adb:16:7-16:8>
+  type:          <ConcreteTypeDecl ["P2"] region.adb:14:7-14:37>
+  expected type: <ConcreteTypeDecl ["P2"] region.adb:14:7-14:37>
+Expr: <Id "Not_Prim" region.adb:18:9-18:17>
+  references:    <DefiningName "Not_Prim" region.adb:15:17-15:25>
+  type:          None
+  expected type: None
+
+Resolving xrefs for node <CallStmt region.adb:27:7-27:18>
+*********************************************************
+
+Expr: <DottedName region.adb:27:7-27:17>
+  references:    <DefiningName "Not_Prim" region.adb:24:17-24:25>
+  type:          None
+  expected type: None
+Expr: <Id "O" region.adb:27:7-27:8>
+  references:    <DefiningName "O" region.adb:25:7-25:8>
+  type:          <ConcreteTypeDecl ["P2"] region.adb:23:7-23:37>
+  expected type: <ClasswideTypeDecl ["P2"] region.adb:23:7-23:37>
+Expr: <Id "Not_Prim" region.adb:27:9-27:17>
+  references:    <DefiningName "Not_Prim" region.adb:24:17-24:25>
+  type:          None
+  expected type: None
+
+
 Done.

testsuite/tests/name_resolution/dottable_subp/test.yaml

@@ -1,2 +1,2 @@
 driver: name-resolution
-input_sources: [test.adb]
+input_sources: [test.adb, test_proc.adb, pkg.adb, region.adb]

testsuite/tests/name_resolution/dottable_subp/test_proc.adb

@@ -0,0 +1,13 @@
+procedure Test_Proc is
+   type T12 is tagged record I : Integer; end record;
+   subtype T1 is T12;
+
+   procedure P (A : access T1'Class; B : Boolean := False) is null;
+
+   type T2 is access all T1;
+
+   X : T2 := null;
+begin
+   X.P;
+   pragma Test_Statement;
+end Test_Proc;