From cdee4ce1255048e07b8733a686e3c348412d80d2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Laurent=20Th=C3=A9venoux?= Date: Thu, 7 Dec 2023 14:12:49 +0100 Subject: [PATCH] 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. --- ada/ast.py | 54 ++++++--- .../name_resolution/dottable_subp/foo.ads | 8 ++ .../name_resolution/dottable_subp/pkg.adb | 22 ++++ .../name_resolution/dottable_subp/pkg.ads | 3 + .../name_resolution/dottable_subp/region.adb | 30 +++++ .../name_resolution/dottable_subp/test.out | 112 ++++++++++++++++++ .../name_resolution/dottable_subp/test.yaml | 2 +- .../dottable_subp/test_proc.adb | 13 ++ 8 files changed, 224 insertions(+), 20 deletions(-) create mode 100644 testsuite/tests/name_resolution/dottable_subp/foo.ads create mode 100644 testsuite/tests/name_resolution/dottable_subp/pkg.adb create mode 100644 testsuite/tests/name_resolution/dottable_subp/pkg.ads create mode 100644 testsuite/tests/name_resolution/dottable_subp/region.adb create mode 100644 testsuite/tests/name_resolution/dottable_subp/test_proc.adb diff --git a/ada/ast.py b/ada/ast.py index c6870a8d2..744d5978c 100644 --- 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 new file mode 100644 index 000000000..7fafff5fd --- /dev/null +++ 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 new file mode 100644 index 000000000..011b7fbc6 --- /dev/null +++ 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 new file mode 100644 index 000000000..dc6d6ebc0 --- /dev/null +++ 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 new file mode 100644 index 000000000..59531ec5b --- /dev/null +++ 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 index 9c3196af3..6b2b4abbd 100644 --- a/testsuite/tests/name_resolution/dottable_subp/test.out +++ b/testsuite/tests/name_resolution/dottable_subp/test.out @@ -18,4 +18,116 @@ Expr: expected type: +Analyzing test_proc.adb +####################### + +Resolving xrefs for node +*********************************************************** + +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: None + expected type: None + + +Analyzing pkg.adb +################# + +Resolving xrefs for node +****************************************************** + +Expr: + references: + type: None + expected type: None +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: +Expr: + references: + type: None + expected type: None +Expr: + references: + type: None + expected type: None +Expr: + references: None + type: + expected type: + + +Analyzing region.adb +#################### + +Resolving xrefs for node +******************************************************* + +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: None + expected type: None + +Resolving xrefs for node +********************************************************* + +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: None + expected type: None + +Resolving xrefs for node +********************************************************* + +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + 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 index 173e325ff..094360a45 100644 --- 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 new file mode 100644 index 000000000..7889755c2 --- /dev/null +++ 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;