[flang-commits] [flang] e843d51 - [flang] Refine handling of SELECT TYPE associations in analyses (#128935)
via flang-commits
flang-commits at lists.llvm.org
Thu Feb 27 14:32:15 PST 2025
Author: Peter Klausler
Date: 2025-02-27T14:32:12-08:00
New Revision: e843d514b12fd07e8bf49898cf66716e4b2833ce
URL: https://github.com/llvm/llvm-project/commit/e843d514b12fd07e8bf49898cf66716e4b2833ce
DIFF: https://github.com/llvm/llvm-project/commit/e843d514b12fd07e8bf49898cf66716e4b2833ce.diff
LOG: [flang] Refine handling of SELECT TYPE associations in analyses (#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.
Added:
Modified:
flang/include/flang/Evaluate/tools.h
flang/include/flang/Semantics/symbol.h
flang/lib/Evaluate/tools.cpp
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/check-do-forall.cpp
flang/lib/Semantics/expression.cpp
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/symbol.cpp
flang/lib/Semantics/tools.cpp
flang/test/Semantics/doconcurrent08.f90
Removed:
################################################################################
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 7181265b862fb..36b7d0a69d2ba 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 8485a7a1f5bc8..4042d7504396c 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 514c0b88d350a..1514c01a49528 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -7748,6 +7748,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 5bb8bae83a787..5e58a0c75c77b 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 e09d1ab32acb2..48d653fc65896 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