[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

@@ -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 &);

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<int> rank_;
+  bool isTypeGuard_{false}; // TYPE IS or CLASS IS, but not CLASS(DEFAULT)
 };
 llvm::raw_ostream &operator<<(llvm::raw_ostream &, const AssocEntityDetails &);
 

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;

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 &&

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

@@ -154,7 +154,8 @@ public:
   // 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 @@ 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)}) {

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)) {

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);
   }

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)

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()}) {

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