From e843d514b12fd07e8bf49898cf66716e4b2833ce Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Thu, 27 Feb 2025 14:32:12 -0800 Subject: [PATCH] [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. --- 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 352f6b36458c..f94981011b6e 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 4ae2775c0f84..715811885c21 100644 --- a/flang/include/flang/Semantics/symbol.h +++ b/flang/include/flang/Semantics/symbol.h @@ -329,9 +329,11 @@ public: } 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 @@ private: static constexpr int isAssumedSize{-1}; // RANK(*) static constexpr int isAssumedRank{-2}; // RANK DEFAULT std::optional 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 7181265b862f..36b7d0a69d2b 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()}) { - 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()}) { 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 8485a7a1f5bc..4042d7504396 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() - : 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() + : 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 84e6b6455cc6..cc1d4bf58745 100644 --- a/flang/lib/Semantics/check-do-forall.cpp +++ b/flang/lib/Semantics/check-do-forall.cpp @@ -154,7 +154,8 @@ public: // of its components? static bool MightDeallocatePolymorphic(const Symbol &original, const std::function &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 @@ public: 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 @@ public: 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 @@ public: 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 @@ public: 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 6949e5693d08..82e346bb4b6d 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 514c0b88d350..1514c01a4952 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().set_isTypeGuard(); } SetAttrsFromAssociation(*symbol); } diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp index 61982295f323..32eb6c2c5a18 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 5bb8bae83a78..5e58a0c75c77 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()}) { - 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 rank) { - const Symbol &symbol{ResolveAssociations(original)}; + const Symbol &symbol{ResolveAssociations(original, /*stopAtTypeGuard=*/true)}; if (symbol.has()) { 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 e09d1ab32acb..48d653fc6589 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