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