[flang-commits] [flang] [flang] ASSOCIATE/SELECT TYPE entities aren't pointer/allocatable (PR #99364)

[Peter Klausler via flang-commits]

https://github.com/klausler created https://github.com/llvm/llvm-project/pull/99364

Fix what seems to be a regression in semantics in definability checking: the construct entities of ASSOCIATE and SELECT TYPE constructs are never pointers or allocatables, even when their selectors are so. SELECT RANK construct entities, however, can be pointers or allocatables.

>From b43f4bef05bc331c93065ca355c8adf3251bcd46 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Wed, 17 Jul 2024 10:36:00 -0700
Subject: [PATCH] [flang] ASSOCIATE/SELECT TYPE entities aren't
 pointer/allocatable

Fix what seems to be a regression in semantics in definability checking:
the construct entities of ASSOCIATE and SELECT TYPE constructs are
never pointers or allocatables, even when their selectors are so.
SELECT RANK construct entities, however, can be pointers or
allocatables.
---
 flang/lib/Semantics/definable.cpp    |  5 +-
 flang/test/Semantics/associate03.f90 | 79 ++++++++++++++++++++++++++++
 2 files changed, 83 insertions(+), 1 deletion(-)
 create mode 100644 flang/test/Semantics/associate03.f90

diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp
index 96af46abd6180..d594b1eca567f 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -178,7 +178,10 @@ static std::optional<parser::Message> WhyNotDefinableBase(parser::CharBlock at,
 static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
     const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
   const Symbol &ultimate{original.GetUltimate()};
-  if (const auto *association{ultimate.detailsIf<AssocEntityDetails>()}) {
+  if (const auto *association{ultimate.detailsIf<AssocEntityDetails>()};
+      association &&
+      (association->rank().has_value() ||
+          !flags.test(DefinabilityFlag::PointerDefinition))) {
     if (auto dataRef{
             evaluate::ExtractDataRef(*association->expr(), true, true)}) {
       return WhyNotDefinableLast(at, scope, flags, dataRef->GetLastSymbol());
diff --git a/flang/test/Semantics/associate03.f90 b/flang/test/Semantics/associate03.f90
new file mode 100644
index 0000000000000..f57dc17839aab
--- /dev/null
+++ b/flang/test/Semantics/associate03.f90
@@ -0,0 +1,79 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+! A construct entity does not have the POINTER or ALLOCATABLE attribute,
+! except in SELECT RANK.
+
+subroutine test(up,ua,rp,ra)
+  class(*), pointer :: up
+  class(*), allocatable :: ua
+  real, pointer :: rp(..)
+  real, allocatable :: ra(..)
+  real, target :: x
+  real, pointer :: p
+  real, allocatable :: a
+  associate (s => p)
+    !ERROR: The left-hand side of a pointer assignment is not definable
+    !BECAUSE: 's' is not a pointer
+    s => x
+    !ERROR: Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+    allocate(s)
+    !ERROR: Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+    deallocate(s)
+    !ERROR: 's' may not appear in NULLIFY
+    !BECAUSE: 's' is not a pointer
+    nullify(s)
+  end associate
+  select type(s => up)
+  type is (real)
+    !ERROR: The left-hand side of a pointer assignment is not definable
+    !BECAUSE: 's' is not a pointer
+    s => x
+    !ERROR: Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+    allocate(s)
+    !ERROR: Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+    deallocate(s)
+    !ERROR: 's' may not appear in NULLIFY
+    !BECAUSE: 's' is not a pointer
+    nullify(s)
+  end select
+  select rank(s => rp)
+  rank(0)
+    s => x ! ok
+    allocate(s) ! ok
+    deallocate(s) ! ok
+    nullify(s) ! ok
+  !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE
+  rank(*)
+  rank default
+    !ERROR: The left-hand side of a pointer assignment must not be an assumed-rank dummy argument
+    !ERROR: pointer 's' associated with object 'x' with incompatible type or shape
+    s => x
+    !ERROR: An assumed-rank dummy argument may not appear in an ALLOCATE statement
+    allocate(s)
+    deallocate(s) ! ok
+    nullify(s) ! ok
+  end select
+  associate (s => a)
+    !ERROR: Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+    allocate(s)
+    !ERROR: Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+    deallocate(s)
+  end associate
+  select type(s => ua)
+  type is (real)
+    !ERROR: Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+    allocate(s)
+    !ERROR: Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+    deallocate(s)
+  end select
+  select rank(s => ra)
+  rank(0)
+    allocate(s) ! ok
+    deallocate(s) ! ok
+  !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE
+  rank(*)
+  rank default
+    !ERROR: An assumed-rank dummy argument may not appear in an ALLOCATE statement
+    allocate(s)
+    deallocate(s) ! ok
+  end select
+end