Skip to content

Commit e843d51

Browse files
klauslerklausler
authored
[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 #128608.
1 parent 523537f commit e843d51

File tree

10 files changed

+40
-21
lines changed

10 files changed

+40
-21
lines changed

‎flang/include/flang/Evaluate/tools.h‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1417,8 +1417,8 @@ inline bool IsAssumedSizeArray(const Symbol &symbol) {
14171417
// In a SELECT RANK construct, ResolveAssociations() stops at a
14181418
// RANK(n) or RANK(*) case symbol, but traverses the selector for
14191419
// RANK DEFAULT.
1420-
const Symbol &ResolveAssociations(const Symbol &);
1421-
const Symbol &GetAssociationRoot(const Symbol &);
1420+
const Symbol &ResolveAssociations(const Symbol &, bool stopAtTypeGuard = false);
1421+
const Symbol &GetAssociationRoot(const Symbol &, bool stopAtTypeGuard = false);
14221422

14231423
const Symbol *FindCommonBlockContaining(const Symbol &);
14241424
int CountLenParameters(const DerivedTypeSpec &);

‎flang/include/flang/Semantics/symbol.h‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -329,9 +329,11 @@ class AssocEntityDetails : public EntityDetails {
329329
}
330330
bool IsAssumedSize() const { return rank_.value_or(0) == isAssumedSize; }
331331
bool IsAssumedRank() const { return rank_.value_or(0) == isAssumedRank; }
332+
bool isTypeGuard() const { return isTypeGuard_; }
332333
void set_rank(int rank);
333334
void set_IsAssumedSize();
334335
void set_IsAssumedRank();
336+
void set_isTypeGuard(bool yes = true);
335337

336338
private:
337339
MaybeExpr expr_;
@@ -340,6 +342,7 @@ class AssocEntityDetails : public EntityDetails {
340342
static constexpr int isAssumedSize{-1}; // RANK(*)
341343
static constexpr int isAssumedRank{-2}; // RANK DEFAULT
342344
std::optional<int> rank_;
345+
bool isTypeGuard_{false}; // TYPE IS or CLASS IS, but not CLASS(DEFAULT)
343346
};
344347
llvm::raw_ostream &operator<<(llvm::raw_ostream &, const AssocEntityDetails &);
345348

‎flang/lib/Evaluate/tools.cpp‎

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1540,10 +1540,12 @@ bool CheckForCoindexedObject(parser::ContextualMessages &messages,
15401540

15411541
namespace Fortran::semantics {
15421542

1543-
const Symbol &ResolveAssociations(const Symbol &original) {
1543+
const Symbol &ResolveAssociations(
1544+
const Symbol &original, bool stopAtTypeGuard) {
15441545
const Symbol &symbol{original.GetUltimate()};
15451546
if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
1546-
if (!details->rank()) { // Not RANK(n) or RANK(*)
1547+
if (!details->rank() /* not RANK(n) or RANK(*) */ &&
1548+
!(stopAtTypeGuard && details->isTypeGuard())) {
15471549
if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) {
15481550
return ResolveAssociations(*nested);
15491551
}
@@ -1567,8 +1569,8 @@ static const Symbol *GetAssociatedVariable(const AssocEntityDetails &details) {
15671569
return nullptr;
15681570
}
15691571

1570-
const Symbol &GetAssociationRoot(const Symbol &original) {
1571-
const Symbol &symbol{ResolveAssociations(original)};
1572+
const Symbol &GetAssociationRoot(const Symbol &original, bool stopAtTypeGuard) {
1573+
const Symbol &symbol{ResolveAssociations(original, stopAtTypeGuard)};
15721574
if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
15731575
if (const Symbol * root{GetAssociatedVariable(*details)}) {
15741576
return *root;

‎flang/lib/Semantics/check-call.cpp‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -535,9 +535,6 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
535535
if (actualLastSymbol) {
536536
actualLastSymbol = &ResolveAssociations(*actualLastSymbol);
537537
}
538-
const ObjectEntityDetails *actualLastObject{actualLastSymbol
539-
? actualLastSymbol->detailsIf<ObjectEntityDetails>()
540-
: nullptr};
541538
int actualRank{actualType.Rank()};
542539
if (dummy.type.attrs().test(
543540
characteristics::TypeAndShape::Attr::AssumedShape)) {
@@ -689,6 +686,9 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
689686
}
690687
}
691688
}
689+
const ObjectEntityDetails *actualLastObject{actualLastSymbol
690+
? actualLastSymbol->detailsIf<ObjectEntityDetails>()
691+
: nullptr};
692692
if (actualLastObject && actualLastObject->IsCoarray() &&
693693
dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable) &&
694694
dummy.intent == common::Intent::Out &&

‎flang/lib/Semantics/check-do-forall.cpp‎

Lines changed: 7 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -154,7 +154,8 @@ class DoConcurrentBodyEnforce {
154154
// of its components?
155155
static bool MightDeallocatePolymorphic(const Symbol &original,
156156
const std::function<bool(const Symbol &)> &WillDeallocate) {
157-
const Symbol &symbol{ResolveAssociations(original)};
157+
const Symbol &symbol{
158+
ResolveAssociations(original, /*stopAtTypeGuard=*/true)};
158159
// Check the entity itself, no coarray exception here
159160
if (IsPolymorphicAllocatable(symbol)) {
160161
return true;
@@ -182,11 +183,10 @@ class DoConcurrentBodyEnforce {
182183
impure.name(), reason);
183184
}
184185

185-
void SayDeallocateOfPolymorph(
186+
void SayDeallocateOfPolymorphic(
186187
parser::CharBlock location, const Symbol &entity, const char *reason) {
187188
context_.SayWithDecl(entity, location,
188-
"Deallocation of a polymorphic entity caused by %s"
189-
" not allowed in DO CONCURRENT"_err_en_US,
189+
"Deallocation of a polymorphic entity caused by %s not allowed in DO CONCURRENT"_err_en_US,
190190
reason);
191191
}
192192

@@ -206,7 +206,7 @@ class DoConcurrentBodyEnforce {
206206
const Symbol &entity{*pair.second};
207207
if (IsAllocatable(entity) && !IsSaved(entity) &&
208208
MightDeallocatePolymorphic(entity, DeallocateAll)) {
209-
SayDeallocateOfPolymorph(endBlockStmt.source, entity, reason);
209+
SayDeallocateOfPolymorphic(endBlockStmt.source, entity, reason);
210210
}
211211
if (const Symbol * impure{HasImpureFinal(entity)}) {
212212
SayDeallocateWithImpureFinal(entity, reason, *impure);
@@ -222,7 +222,7 @@ class DoConcurrentBodyEnforce {
222222
if (const Symbol * entity{GetLastName(variable).symbol}) {
223223
const char *reason{"assignment"};
224224
if (MightDeallocatePolymorphic(*entity, DeallocateNonCoarray)) {
225-
SayDeallocateOfPolymorph(variable.GetSource(), *entity, reason);
225+
SayDeallocateOfPolymorphic(variable.GetSource(), *entity, reason);
226226
}
227227
if (const auto *assignment{GetAssignment(stmt)}) {
228228
const auto &lhs{assignment->lhs};
@@ -257,7 +257,7 @@ class DoConcurrentBodyEnforce {
257257
const DeclTypeSpec *entityType{entity.GetType()};
258258
if ((entityType && entityType->IsPolymorphic()) || // POINTER case
259259
MightDeallocatePolymorphic(entity, DeallocateAll)) {
260-
SayDeallocateOfPolymorph(
260+
SayDeallocateOfPolymorphic(
261261
currentStatementSourcePosition_, entity, reason);
262262
}
263263
if (const Symbol * impure{HasImpureFinal(entity)}) {

‎flang/lib/Semantics/expression.cpp‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3289,7 +3289,7 @@ const Assignment *ExpressionAnalyzer::Analyze(const parser::AssignmentStmt &x) {
32893289
dyType && dyType->IsPolymorphic()) { // 10.2.1.2p1(1)
32903290
const Symbol *lastWhole0{UnwrapWholeSymbolOrComponentDataRef(lhs)};
32913291
const Symbol *lastWhole{
3292-
lastWhole0 ? &lastWhole0->GetUltimate() : nullptr};
3292+
lastWhole0 ? &ResolveAssociations(*lastWhole0) : nullptr};
32933293
if (!lastWhole || !IsAllocatable(*lastWhole)) {
32943294
Say("Left-hand side of assignment may not be polymorphic unless assignment is to an entire allocatable"_err_en_US);
32953295
} else if (evaluate::IsCoarray(*lastWhole)) {

‎flang/lib/Semantics/resolve-names.cpp‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -7748,6 +7748,7 @@ void ConstructVisitor::Post(const parser::TypeGuardStmt::Guard &x) {
77487748
SetTypeFromAssociation(*symbol);
77497749
} else if (const auto *type{GetDeclTypeSpec()}) {
77507750
symbol->SetType(*type);
7751+
symbol->get<AssocEntityDetails>().set_isTypeGuard();
77517752
}
77527753
SetAttrsFromAssociation(*symbol);
77537754
}

‎flang/lib/Semantics/symbol.cpp‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -155,6 +155,7 @@ void EntityDetails::set_type(const DeclTypeSpec &type) {
155155
void AssocEntityDetails::set_rank(int rank) { rank_ = rank; }
156156
void AssocEntityDetails::set_IsAssumedSize() { rank_ = isAssumedSize; }
157157
void AssocEntityDetails::set_IsAssumedRank() { rank_ = isAssumedRank; }
158+
void AssocEntityDetails::set_isTypeGuard(bool yes) { isTypeGuard_ = yes; }
158159
void EntityDetails::ReplaceType(const DeclTypeSpec &type) { type_ = &type; }
159160

160161
ObjectEntityDetails::ObjectEntityDetails(EntityDetails &&d)

‎flang/lib/Semantics/tools.cpp‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -633,9 +633,9 @@ const EquivalenceSet *FindEquivalenceSet(const Symbol &symbol) {
633633
}
634634

635635
bool IsOrContainsEventOrLockComponent(const Symbol &original) {
636-
const Symbol &symbol{ResolveAssociations(original)};
637-
if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
638-
if (const DeclTypeSpec * type{details->type()}) {
636+
const Symbol &symbol{ResolveAssociations(original, /*stopAtTypeGuard=*/true)};
637+
if (evaluate::IsVariable(symbol)) {
638+
if (const DeclTypeSpec * type{symbol.GetType()}) {
639639
if (const DerivedTypeSpec * derived{type->AsDerived()}) {
640640
return IsEventTypeOrLockType(derived) ||
641641
FindEventOrLockPotentialComponent(*derived);
@@ -849,7 +849,7 @@ static const Symbol *HasImpureFinal(
849849
}
850850

851851
const Symbol *HasImpureFinal(const Symbol &original, std::optional<int> rank) {
852-
const Symbol &symbol{ResolveAssociations(original)};
852+
const Symbol &symbol{ResolveAssociations(original, /*stopAtTypeGuard=*/true)};
853853
if (symbol.has<ObjectEntityDetails>()) {
854854
if (const DeclTypeSpec * symType{symbol.GetType()}) {
855855
if (const DerivedTypeSpec * derived{symType->AsDerived()}) {

‎flang/test/Semantics/doconcurrent08.f90‎

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -125,6 +125,8 @@ subroutine s2()
125125
class(Base), allocatable, codimension[:] :: allocPolyComponentVar
126126
class(Base), allocatable, codimension[:] :: allocPolyComponentVar1
127127

128+
class(*), allocatable :: unlimitedPoly
129+
128130
allocate(ChildType :: localVar)
129131
allocate(ChildType :: localVar1)
130132
allocate(Base :: localVar2)
@@ -162,6 +164,16 @@ subroutine s2()
162164
!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
163165
allocPolyCoarray = allocPolyCoarray1
164166

167+
!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
168+
unlimitedPoly = 1
169+
select type (unlimitedPoly)
170+
type is (integer)
171+
unlimitedPoly = 1 ! ok
172+
class default
173+
!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
174+
unlimitedPoly = 1
175+
end select
176+
165177
end do
166178
end subroutine s2
167179

0 commit comments

Comments
 (0)