Fix selected components resolution for subprograms

As defined by the ARM in 4.1.3-9.2/3: The prefix (after any implicit dereference) shall resolve to denote an object or value of a specific tagged type T or class-wide type T'Class. The selector_name shall resolve to denote a view of a subprogram declared immediately within the declarative region in which an ancestor of the type T is declared. That means that subprograms can be called with dot notation as long as the first parameter is of the type of the object referenced by the prefix, weither the given subprogram is a primitive or not.
AdaCore · Dec 14, 2023 · cdee4ce · cdee4ce
1 parent dd6c19b
commit cdee4ce
Show file tree

Hide file tree

Showing 8 changed files with 224 additions and 20 deletions.
diff --git a/ada/ast.py b/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,

diff --git a/testsuite/tests/name_resolution/dottable_subp/foo.ads b/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;
diff --git a/testsuite/tests/name_resolution/dottable_subp/pkg.adb b/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;
diff --git a/testsuite/tests/name_resolution/dottable_subp/pkg.ads b/testsuite/tests/name_resolution/dottable_subp/pkg.ads
@@ -0,0 +1,3 @@
+package Pkg is
+   pragma Elaborate_Body;
+end Pkg;
diff --git a/testsuite/tests/name_resolution/dottable_subp/region.adb b/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;
diff --git a/testsuite/tests/name_resolution/dottable_subp/test.out b/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.
diff --git a/testsuite/tests/name_resolution/dottable_subp/test.yaml b/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]
diff --git a/testsuite/tests/name_resolution/dottable_subp/test_proc.adb b/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;