[flang-commits] [flang] [flang] Refine handling of SELECT TYPE associations in analyses (PR #128935)
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Wed Feb 26 11:20:41 PST 2025
https://github.com/klausler created https://github.com/llvm/llvm-project/pull/128935
A few bits of semantic checking need a variant of the ResolveAssociations utility function that stops when hitting a construct entity for a type or class guard. This is necessary for cases like the bug below where the analysis is concerned with the type of the name in context, rather than its shape or storage or whatever. So add a flag to ResolveAssociations and GetAssociationRoot to make this happen, and use it at the appropriate call sites.
Fixes https://github.com/llvm/llvm-project/issues/128608.
>From a48714002c1d843cc22beac18ed3d36895c72dc3 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Wed, 26 Feb 2025 11:12:57 -0800
Subject: [PATCH] [flang] Refine handling of SELECT TYPE associations in
analyses
A few bits of semantic checking need a variant of the ResolveAssociations
utility function that stops when hitting a construct entity for a
type or class guard. This is necessary for cases like the bug below
where the analysis is concerned with the type of the name in context,
rather than its shape or storage or whatever. So add a flag to
ResolveAssociations and GetAssociationRoot to make this happen, and
use it at the appropriate call sites.
Fixes https://github.com/llvm/llvm-project/issues/128608.
---
flang/include/flang/Evaluate/tools.h | 4 ++--
flang/include/flang/Semantics/symbol.h | 3 +++
flang/lib/Evaluate/tools.cpp | 10 ++++++----
flang/lib/Semantics/check-call.cpp | 6 +++---
flang/lib/Semantics/check-do-forall.cpp | 14 +++++++-------
flang/lib/Semantics/expression.cpp | 2 +-
flang/lib/Semantics/resolve-names.cpp | 1 +
flang/lib/Semantics/symbol.cpp | 1 +
flang/lib/Semantics/tools.cpp | 8 ++++----
flang/test/Semantics/doconcurrent08.f90 | 12 ++++++++++++
10 files changed, 40 insertions(+), 21 deletions(-)
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index 352f6b36458ce..f94981011b6e5 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -1417,8 +1417,8 @@ inline bool IsAssumedSizeArray(const Symbol &symbol) {
// In a SELECT RANK construct, ResolveAssociations() stops at a
// RANK(n) or RANK(*) case symbol, but traverses the selector for
// RANK DEFAULT.
-const Symbol &ResolveAssociations(const Symbol &);
-const Symbol &GetAssociationRoot(const Symbol &);
+const Symbol &ResolveAssociations(const Symbol &, bool stopAtTypeGuard = false);
+const Symbol &GetAssociationRoot(const Symbol &, bool stopAtTypeGuard = false);
const Symbol *FindCommonBlockContaining(const Symbol &);
int CountLenParameters(const DerivedTypeSpec &);
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index 4ae2775c0f849..715811885c219 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -329,9 +329,11 @@ class AssocEntityDetails : public EntityDetails {
}
bool IsAssumedSize() const { return rank_.value_or(0) == isAssumedSize; }
bool IsAssumedRank() const { return rank_.value_or(0) == isAssumedRank; }
+ bool isTypeGuard() const { return isTypeGuard_; }
void set_rank(int rank);
void set_IsAssumedSize();
void set_IsAssumedRank();
+ void set_isTypeGuard(bool yes = true);
private:
MaybeExpr expr_;
@@ -340,6 +342,7 @@ class AssocEntityDetails : public EntityDetails {
static constexpr int isAssumedSize{-1}; // RANK(*)
static constexpr int isAssumedRank{-2}; // RANK DEFAULT
std::optional<int> rank_;
+ bool isTypeGuard_{false}; // TYPE IS or CLASS IS, but not CLASS(DEFAULT)
};
llvm::raw_ostream &operator<<(llvm::raw_ostream &, const AssocEntityDetails &);
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 16b0260719097..da119ec5dad7d 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -1540,10 +1540,12 @@ bool CheckForCoindexedObject(parser::ContextualMessages &messages,
namespace Fortran::semantics {
-const Symbol &ResolveAssociations(const Symbol &original) {
+const Symbol &ResolveAssociations(
+ const Symbol &original, bool stopAtTypeGuard) {
const Symbol &symbol{original.GetUltimate()};
if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
- if (!details->rank()) { // Not RANK(n) or RANK(*)
+ if (!details->rank() /* not RANK(n) or RANK(*) */ &&
+ !(stopAtTypeGuard && details->isTypeGuard())) {
if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) {
return ResolveAssociations(*nested);
}
@@ -1567,8 +1569,8 @@ static const Symbol *GetAssociatedVariable(const AssocEntityDetails &details) {
return nullptr;
}
-const Symbol &GetAssociationRoot(const Symbol &original) {
- const Symbol &symbol{ResolveAssociations(original)};
+const Symbol &GetAssociationRoot(const Symbol &original, bool stopAtTypeGuard) {
+ const Symbol &symbol{ResolveAssociations(original, stopAtTypeGuard)};
if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
if (const Symbol * root{GetAssociatedVariable(*details)}) {
return *root;
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index e396ece303103..2e49e8175b51c 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -535,9 +535,6 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
if (actualLastSymbol) {
actualLastSymbol = &ResolveAssociations(*actualLastSymbol);
}
- const ObjectEntityDetails *actualLastObject{actualLastSymbol
- ? actualLastSymbol->detailsIf<ObjectEntityDetails>()
- : nullptr};
int actualRank{actualType.Rank()};
if (dummy.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedShape)) {
@@ -689,6 +686,9 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
}
}
}
+ const ObjectEntityDetails *actualLastObject{actualLastSymbol
+ ? actualLastSymbol->detailsIf<ObjectEntityDetails>()
+ : nullptr};
if (actualLastObject && actualLastObject->IsCoarray() &&
dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable) &&
dummy.intent == common::Intent::Out &&
diff --git a/flang/lib/Semantics/check-do-forall.cpp b/flang/lib/Semantics/check-do-forall.cpp
index 84e6b6455cc61..cc1d4bf58745a 100644
--- a/flang/lib/Semantics/check-do-forall.cpp
+++ b/flang/lib/Semantics/check-do-forall.cpp
@@ -154,7 +154,8 @@ class DoConcurrentBodyEnforce {
// of its components?
static bool MightDeallocatePolymorphic(const Symbol &original,
const std::function<bool(const Symbol &)> &WillDeallocate) {
- const Symbol &symbol{ResolveAssociations(original)};
+ const Symbol &symbol{
+ ResolveAssociations(original, /*stopAtTypeGuard=*/true)};
// Check the entity itself, no coarray exception here
if (IsPolymorphicAllocatable(symbol)) {
return true;
@@ -182,11 +183,10 @@ class DoConcurrentBodyEnforce {
impure.name(), reason);
}
- void SayDeallocateOfPolymorph(
+ void SayDeallocateOfPolymorphic(
parser::CharBlock location, const Symbol &entity, const char *reason) {
context_.SayWithDecl(entity, location,
- "Deallocation of a polymorphic entity caused by %s"
- " not allowed in DO CONCURRENT"_err_en_US,
+ "Deallocation of a polymorphic entity caused by %s not allowed in DO CONCURRENT"_err_en_US,
reason);
}
@@ -206,7 +206,7 @@ class DoConcurrentBodyEnforce {
const Symbol &entity{*pair.second};
if (IsAllocatable(entity) && !IsSaved(entity) &&
MightDeallocatePolymorphic(entity, DeallocateAll)) {
- SayDeallocateOfPolymorph(endBlockStmt.source, entity, reason);
+ SayDeallocateOfPolymorphic(endBlockStmt.source, entity, reason);
}
if (const Symbol * impure{HasImpureFinal(entity)}) {
SayDeallocateWithImpureFinal(entity, reason, *impure);
@@ -222,7 +222,7 @@ class DoConcurrentBodyEnforce {
if (const Symbol * entity{GetLastName(variable).symbol}) {
const char *reason{"assignment"};
if (MightDeallocatePolymorphic(*entity, DeallocateNonCoarray)) {
- SayDeallocateOfPolymorph(variable.GetSource(), *entity, reason);
+ SayDeallocateOfPolymorphic(variable.GetSource(), *entity, reason);
}
if (const auto *assignment{GetAssignment(stmt)}) {
const auto &lhs{assignment->lhs};
@@ -257,7 +257,7 @@ class DoConcurrentBodyEnforce {
const DeclTypeSpec *entityType{entity.GetType()};
if ((entityType && entityType->IsPolymorphic()) || // POINTER case
MightDeallocatePolymorphic(entity, DeallocateAll)) {
- SayDeallocateOfPolymorph(
+ SayDeallocateOfPolymorphic(
currentStatementSourcePosition_, entity, reason);
}
if (const Symbol * impure{HasImpureFinal(entity)}) {
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 6949e5693d08f..82e346bb4b6d6 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -3289,7 +3289,7 @@ const Assignment *ExpressionAnalyzer::Analyze(const parser::AssignmentStmt &x) {
dyType && dyType->IsPolymorphic()) { // 10.2.1.2p1(1)
const Symbol *lastWhole0{UnwrapWholeSymbolOrComponentDataRef(lhs)};
const Symbol *lastWhole{
- lastWhole0 ? &lastWhole0->GetUltimate() : nullptr};
+ lastWhole0 ? &ResolveAssociations(*lastWhole0) : nullptr};
if (!lastWhole || !IsAllocatable(*lastWhole)) {
Say("Left-hand side of assignment may not be polymorphic unless assignment is to an entire allocatable"_err_en_US);
} else if (evaluate::IsCoarray(*lastWhole)) {
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 17a6665dfb6a5..a0fea0772aac2 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -7771,6 +7771,7 @@ void ConstructVisitor::Post(const parser::TypeGuardStmt::Guard &x) {
SetTypeFromAssociation(*symbol);
} else if (const auto *type{GetDeclTypeSpec()}) {
symbol->SetType(*type);
+ symbol->get<AssocEntityDetails>().set_isTypeGuard();
}
SetAttrsFromAssociation(*symbol);
}
diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp
index 61982295f323a..32eb6c2c5a188 100644
--- a/flang/lib/Semantics/symbol.cpp
+++ b/flang/lib/Semantics/symbol.cpp
@@ -155,6 +155,7 @@ void EntityDetails::set_type(const DeclTypeSpec &type) {
void AssocEntityDetails::set_rank(int rank) { rank_ = rank; }
void AssocEntityDetails::set_IsAssumedSize() { rank_ = isAssumedSize; }
void AssocEntityDetails::set_IsAssumedRank() { rank_ = isAssumedRank; }
+void AssocEntityDetails::set_isTypeGuard(bool yes) { isTypeGuard_ = yes; }
void EntityDetails::ReplaceType(const DeclTypeSpec &type) { type_ = &type; }
ObjectEntityDetails::ObjectEntityDetails(EntityDetails &&d)
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 7544731a682ec..5cbd0389891da 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -633,9 +633,9 @@ const EquivalenceSet *FindEquivalenceSet(const Symbol &symbol) {
}
bool IsOrContainsEventOrLockComponent(const Symbol &original) {
- const Symbol &symbol{ResolveAssociations(original)};
- if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
- if (const DeclTypeSpec * type{details->type()}) {
+ const Symbol &symbol{ResolveAssociations(original, /*stopAtTypeGuard=*/true)};
+ if (evaluate::IsVariable(symbol)) {
+ if (const DeclTypeSpec * type{symbol.GetType()}) {
if (const DerivedTypeSpec * derived{type->AsDerived()}) {
return IsEventTypeOrLockType(derived) ||
FindEventOrLockPotentialComponent(*derived);
@@ -849,7 +849,7 @@ static const Symbol *HasImpureFinal(
}
const Symbol *HasImpureFinal(const Symbol &original, std::optional<int> rank) {
- const Symbol &symbol{ResolveAssociations(original)};
+ const Symbol &symbol{ResolveAssociations(original, /*stopAtTypeGuard=*/true)};
if (symbol.has<ObjectEntityDetails>()) {
if (const DeclTypeSpec * symType{symbol.GetType()}) {
if (const DerivedTypeSpec * derived{symType->AsDerived()}) {
diff --git a/flang/test/Semantics/doconcurrent08.f90 b/flang/test/Semantics/doconcurrent08.f90
index 52b382741d073..c4547004bf2d3 100644
--- a/flang/test/Semantics/doconcurrent08.f90
+++ b/flang/test/Semantics/doconcurrent08.f90
@@ -125,6 +125,8 @@ subroutine s2()
class(Base), allocatable, codimension[:] :: allocPolyComponentVar
class(Base), allocatable, codimension[:] :: allocPolyComponentVar1
+ class(*), allocatable :: unlimitedPoly
+
allocate(ChildType :: localVar)
allocate(ChildType :: localVar1)
allocate(Base :: localVar2)
@@ -162,6 +164,16 @@ subroutine s2()
!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
allocPolyCoarray = allocPolyCoarray1
+!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
+ unlimitedPoly = 1
+ select type (unlimitedPoly)
+ type is (integer)
+ unlimitedPoly = 1 ! ok
+ class default
+!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
+ unlimitedPoly = 1
+ end select
+
end do
end subroutine s2
More information about the flang-commits
mailing list