Skip to content

[flang] Refine handling of SELECT TYPE associations in analyses #128935

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 1 commit into from
Feb 27, 2025

Conversation

klausler
Copy link
Contributor

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.

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 llvm#128608.
@llvmbot llvmbot added flang Flang issues not falling into any other category flang:semantics labels Feb 26, 2025
@llvmbot
Copy link
Member

llvmbot commented Feb 26, 2025

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

Changes

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.


Full diff: https://github.com/llvm/llvm-project/pull/128935.diff

10 Files Affected:

  • (modified) flang/include/flang/Evaluate/tools.h (+2-2)
  • (modified) flang/include/flang/Semantics/symbol.h (+3)
  • (modified) flang/lib/Evaluate/tools.cpp (+6-4)
  • (modified) flang/lib/Semantics/check-call.cpp (+3-3)
  • (modified) flang/lib/Semantics/check-do-forall.cpp (+7-7)
  • (modified) flang/lib/Semantics/expression.cpp (+1-1)
  • (modified) flang/lib/Semantics/resolve-names.cpp (+1)
  • (modified) flang/lib/Semantics/symbol.cpp (+1)
  • (modified) flang/lib/Semantics/tools.cpp (+4-4)
  • (modified) flang/test/Semantics/doconcurrent08.f90 (+12)
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 16b0260719097..da119ec5dad7d 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 e396ece303103..2e49e8175b51c 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 17a6665dfb6a5..a0fea0772aac2 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -7771,6 +7771,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 7544731a682ec..5cbd0389891da 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 52b382741d073..c4547004bf2d3 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
 

@klausler klausler merged commit e843d51 into llvm:main Feb 27, 2025
14 checks passed
@klausler klausler deleted the bug128608 branch February 27, 2025 22:32
cheezeburglar pushed a commit to cheezeburglar/llvm-project that referenced this pull request Feb 28, 2025
…#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 llvm#128608.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Labels
flang:semantics flang Flang issues not falling into any other category
Projects
None yet
Development

Successfully merging this pull request may close these issues.

[Flang] Compilation error when using the type is statement in select type construct
3 participants