From 9a4b4c22f05b5626695f019f5a94ac4f70717e93 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Laurent=20Th=C3=A9venoux?= Date: Mon, 13 Nov 2023 12:53:55 +0100 Subject: [PATCH] Support prefixed-view notation for calls to primitive subprograms of untagged types As defined in https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-prefixed-untagged.rst. --- ada/ast.py | 32 +++++++--------- .../prefixed_untagged/test.adb | 34 +++++++++++++++++ .../prefixed_untagged/test.out | 37 +++++++++++++++++++ .../prefixed_untagged/test.yaml | 2 + 4 files changed, 87 insertions(+), 18 deletions(-) create mode 100644 testsuite/tests/name_resolution/prefixed_untagged/test.adb create mode 100644 testsuite/tests/name_resolution/prefixed_untagged/test.out create mode 100644 testsuite/tests/name_resolution/prefixed_untagged/test.yaml diff --git a/ada/ast.py b/ada/ast.py index b623dd2d5..c6870a8d2 100644 --- a/ada/ast.py +++ b/ada/ast.py @@ -7904,6 +7904,9 @@ 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. + + This property doesn't implement Ada standard but the GNAT experimental + feature allowing dot-notation for untagged types. """ scope = Var(Entity.declarative_scope) pkg = Var( @@ -7916,10 +7919,12 @@ def dottable_subps(): ) ) return Cond( - Not(Entity.is_tagged_type - # Private types can have a tagged completion - | Entity.private_completion._.is_tagged_type), - No(T.inner_env_assoc.array), + # Ada standard would requier to check that this type is tagged to + # be called with the dot-notation. We do not comply to the standard + # here in order to support a GNAT experimental feature which allows + # to use the dot-notation on untagged types too. See + # https://github.com/AdaCore/ada-spark-rfcs/blob/master/\ + # prototyped/rfc-prefixed-untagged.rst. pkg.is_null, No(T.inner_env_assoc.array), @@ -19262,23 +19267,14 @@ def dottable_subp_of(): """ Returns whether the subprogram containing this spec is a subprogram callable via the dot notation. + + This property doesn't implement Ada standard but the GNAT experimental + feature allowing dot-notation for untagged types. """ + # See also comments in BaseTypeDecl.dottable_subps return origin.bind(Self.origin_node, If( Entity.nb_max_params > 0, - Entity.potential_dottable_type.then(lambda t: Cond( - t.is_a(ClasswideTypeDecl), - t.cast(ClasswideTypeDecl).type_decl, - - # NOTE: We are not actually implementing the correct Ada - # semantics here, because you can call primitives via the dot - # notation on private types with a tagged completion. - # However, since private types don't have components, this - # should not ever be a problem with legal Ada. - t.full_view.is_tagged_type, - t, - - No(T.BaseTypeDecl.entity) - )), + Entity.potential_dottable_type._.specific_type, No(T.BaseTypeDecl.entity) )) diff --git a/testsuite/tests/name_resolution/prefixed_untagged/test.adb b/testsuite/tests/name_resolution/prefixed_untagged/test.adb new file mode 100644 index 000000000..0257213fd --- /dev/null +++ b/testsuite/tests/name_resolution/prefixed_untagged/test.adb @@ -0,0 +1,34 @@ +procedure Test is + package Pkg is + type T is null record; + procedure P (B : T); + end Pkg; + + package body Pkg is + procedure P (B : T) is null; + + procedure Q (B : T) is + begin + B.P; + pragma Test_Statement; + end Q; + end Pkg; + + package Pkg2 is + type T is null record; + subtype U is T; + procedure P (B : U); + end Pkg2; + + package body Pkg2 is + procedure P (B : U) is null; + + procedure Q (B : U) is + begin + B.P; + pragma Test_Statement; + end Q; + end Pkg2; +begin + null; +end Test; diff --git a/testsuite/tests/name_resolution/prefixed_untagged/test.out b/testsuite/tests/name_resolution/prefixed_untagged/test.out new file mode 100644 index 000000000..c45d72907 --- /dev/null +++ b/testsuite/tests/name_resolution/prefixed_untagged/test.out @@ -0,0 +1,37 @@ +Analyzing test.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 + + +Done. diff --git a/testsuite/tests/name_resolution/prefixed_untagged/test.yaml b/testsuite/tests/name_resolution/prefixed_untagged/test.yaml new file mode 100644 index 000000000..173e325ff --- /dev/null +++ b/testsuite/tests/name_resolution/prefixed_untagged/test.yaml @@ -0,0 +1,2 @@ +driver: name-resolution +input_sources: [test.adb]