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;