[flang] Use definability tests for better PURE constraint checking

[klausler]

Summary

Many semantic checks for constraints related to PURE subprograms
can be implemented in terms of Semantics' "definable.h" utilities,
slightly expanded. Replace some particular PURE constraint
checks with calls to WhyNotDefinable(), except for cases that
had better specific error messages, and start checking some
missing constraints with DEALLOCATE statements and local
variable declarations.

[jeanPerier]

LGTM

flang/include/flang/Semantics/tools.h

 // Is the symbol explicitly or implicitly initialized in any way?
 bool IsInitialized(const Symbol &, bool ignoreDATAstatements = false,
     bool ignoreAllocatable = false);
 // Is the symbol a component subject to deallocation or finalization?
 bool IsDestructible(const Symbol &, const Symbol *derivedType = nullptr);
 bool HasIntrinsicTypeName(const Symbol &);
 bool IsSeparateModuleProcedureInterface(const Symbol *);
 bool HasAlternateReturns(const Symbol &);
+bool IsAutomaticallyDestroyed(const Symbol &);
 
 // Return an ultimate component of type that matches predicate, or nullptr.
 const Symbol *FindUltimateComponent(const DerivedTypeSpec &type,
     const std::function<bool(const Symbol &)> &predicate);
 const Symbol *FindUltimateComponent(
     const Symbol &symbol, const std::function<bool(const Symbol &)> &predicate);
 
 // Returns an immediate component of type that matches predicate, or nullptr.

 }
 inline bool IsProtected(const Symbol &symbol) {
   return symbol.attrs().test(Attr::PROTECTED);
 }
 inline bool IsImpliedDoIndex(const Symbol &symbol) {
   return symbol.owner().kind() == Scope::Kind::ImpliedDos;
 }
 SymbolVector FinalsForDerivedTypeInstantiation(const DerivedTypeSpec &);
-bool IsFinalizable(
-    const Symbol &, std::set<const DerivedTypeSpec *> * = nullptr);
-bool IsFinalizable(
-    const DerivedTypeSpec &, std::set<const DerivedTypeSpec *> * = nullptr);
-bool HasImpureFinal(const DerivedTypeSpec &);
+// Returns a non-null pointer to a FINAL procedure, if any.
+const Symbol *IsFinalizable(const Symbol &,
+    std::set<const DerivedTypeSpec *> * = nullptr,
+    bool withImpureFinalizer = false);
+const Symbol *IsFinalizable(const DerivedTypeSpec &,
+    std::set<const DerivedTypeSpec *> * = nullptr,
+    bool withImpureFinalizer = false, std::optional<int> rank = std::nullopt);
+const Symbol *HasImpureFinal(const Symbol &);
 bool IsInBlankCommon(const Symbol &);
 inline bool IsAssumedSizeArray(const Symbol &symbol) {
   const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
   return details && details->IsAssumedSize();
 }
 bool IsAssumedLengthCharacter(const Symbol &);
 bool IsExternal(const Symbol &);
 bool IsModuleProcedure(const Symbol &);

 UltimateComponentIterator::const_iterator FindPointerUltimateComponent(
     const DerivedTypeSpec &);
 UltimateComponentIterator::const_iterator FindAllocatableUltimateComponent(
     const DerivedTypeSpec &);
 DirectComponentIterator::const_iterator FindAllocatableOrPointerDirectComponent(
     const DerivedTypeSpec &);
 UltimateComponentIterator::const_iterator
 FindPolymorphicAllocatableUltimateComponent(const DerivedTypeSpec &);
-UltimateComponentIterator::const_iterator
-FindPolymorphicAllocatableNonCoarrayUltimateComponent(const DerivedTypeSpec &);
 
 // The LabelEnforce class (given a set of labels) provides an error message if
 // there is a branch to a label which is not in the given set.
 class LabelEnforce {
 public:
   LabelEnforce(SemanticsContext &context, std::set<parser::Label> &&labels,
       parser::CharBlock constructSourcePosition, const char *construct)
       : context_{context}, labels_{labels},

flang/lib/Evaluate/tools.cpp

return true; // explicit SAVE attribute
       IsAutomatic(symbol) || IsNamedConstant(symbol)) {
     return false;
   } else if (scopeKind == Scope::Kind::Module ||
       (scopeKind == Scope::Kind::MainProgram &&
           (symbol.attrs().test(Attr::TARGET) || evaluate::IsCoarray(symbol)))) {
     // 8.5.16p4
     // In main programs, implied SAVE matters only for pointer
     // initialization targets and coarrays.
-    // BLOCK DATA entities must all be in COMMON,
-    // which was checked above.
     return true;
   } else if (scopeKind == Scope::Kind::MainProgram &&
       (features.IsEnabled(common::LanguageFeature::SaveMainProgram) ||
           (features.IsEnabled(
                common::LanguageFeature::SaveBigMainProgramVariables) &&
               symbol.size() > 32))) {
     // With SaveBigMainProgramVariables, keeping all unsaved main program
     // variables of 32 bytes or less on the stack allows keeping numerical and

flang/lib/Semantics/check-deallocate.h

 
 namespace Fortran::semantics {
 class DeallocateChecker : public virtual BaseChecker {
 public:
   DeallocateChecker(SemanticsContext &context) : context_{context} {}
   void Leave(const parser::DeallocateStmt &);
 
 private:
-  bool CheckPolymorphism(parser::CharBlock, const Symbol &);
   SemanticsContext &context_;
 };
 } // namespace Fortran::semantics
 #endif // FORTRAN_SEMANTICS_CHECK_DEALLOCATE_H_

flang/lib/Semantics/check-deallocate.cpp

common::visit(
                              symbol->GetUltimate())) { // C932
                 context_.Say(name.source,
                     "Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
               } else if (auto whyNot{WhyNotDefinable(name.source,
                              context_.FindScope(name.source),
                              {DefinabilityFlag::PointerDefinition,
                                  DefinabilityFlag::AcceptAllocatable},
                              *symbol)}) {
+                // Catch problems with non-definability of the
+                // pointer/allocatable
                 context_
                     .Say(name.source,
                         "Name in DEALLOCATE statement is not definable"_err_en_US)
                     .Attach(std::move(*whyNot));
-              } else if (CheckPolymorphism(name.source, *symbol)) {
+              } else if (auto whyNot{WhyNotDefinable(name.source,
+                             context_.FindScope(name.source),
+                             DefinabilityFlags{}, *symbol)}) {
+                // Catch problems with non-definability of the dynamic object
+                context_
+                    .Say(name.source,
+                        "Object in DEALLOCATE statement is not deallocatable"_err_en_US)
+                    .Attach(std::move(*whyNot));
+              } else {
                 context_.CheckIndexVarRedefine(name);
               }
             },
             [&](const parser::StructureComponent &structureComponent) {
               // Only perform structureComponent checks if it was successfully
               // analyzed by expression analysis.
               if (const auto *expr{GetExpr(context_, allocateObject)}) {
                 if (const Symbol *symbol{structureComponent.component.symbol}) {
                   auto source{structureComponent.component.source};
                   if (!IsAllocatableOrPointer(*symbol)) { // C932
                     context_.Say(source,
                         "Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
                   } else if (auto whyNot{WhyNotDefinable(source,
                                  context_.FindScope(source),
                                  {DefinabilityFlag::PointerDefinition,
                                      DefinabilityFlag::AcceptAllocatable},
                                  *expr)}) {
                     context_
                         .Say(source,
                             "Name in DEALLOCATE statement is not definable"_err_en_US)
                         .Attach(std::move(*whyNot));
-                  } else {
-                    CheckPolymorphism(source, *symbol);
+                  } else if (auto whyNot{WhyNotDefinable(source,
+                                 context_.FindScope(source),
+                                 DefinabilityFlags{}, *expr)}) {
+                    context_
+                        .Say(source,
+                            "Object in DEALLOCATE statement is not deallocatable"_err_en_US)
+                        .Attach(std::move(*whyNot));
                   }
                 }
               }
             },
         },
         allocateObject.u);
   }
   bool gotStat{false}, gotMsg{false};
common::visit(
               }
               gotMsg = true;
             },
         },
         deallocOpt.u);
   }
 }
 
-bool DeallocateChecker::CheckPolymorphism(
-    parser::CharBlock source, const Symbol &symbol) {
-  if (FindPureProcedureContaining(context_.FindScope(source))) {
-    if (auto type{evaluate::DynamicType::From(symbol)}) {
-      if (type->IsPolymorphic()) {
-        context_.Say(source,
-            "'%s' may not be deallocated in a pure procedure because it is polymorphic"_err_en_US,
-            source);
-        return false;
-      }
-      if (!type->IsUnlimitedPolymorphic() &&
-          type->category() == TypeCategory::Derived) {
-        if (auto iter{FindPolymorphicAllocatableUltimateComponent(
-                type->GetDerivedTypeSpec())}) {
-          context_.Say(source,
-              "'%s' may not be deallocated in a pure procedure because its type has a polymorphic allocatable ultimate component '%s'"_err_en_US,
-              source, iter->name());
-          return false;
-        }
-      }
-    }
-  }
-  return true;
-}
 } // namespace Fortran::semantics

flang/lib/Semantics/check-declarations.cpp

 //===-- lib/Semantics/check-declarations.cpp ------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 // Static declaration checking
 
 #include "check-declarations.h"
+#include "definable.h"
 #include "pointer-assignment.h"
 #include "flang/Evaluate/check-expression.h"
 #include "flang/Evaluate/fold.h"
 #include "flang/Evaluate/tools.h"
 #include "flang/Parser/characters.h"
 #include "flang/Semantics/scope.h"
 #include "flang/Semantics/semantics.h"
 #include "flang/Semantics/symbol.h"
if (InInterface()) {
         if (IsInitialized(symbol)) {
           messages_.Say(
               "A pure subprogram may not initialize a variable"_err_en_US);
         } else {
           messages_.Say(
               "A pure subprogram may not have a variable with the SAVE attribute"_err_en_US);
         }
       }
-      if (!IsDummy(symbol) && !IsFunctionResult(symbol)) {
-        if (IsPolymorphicAllocatable(symbol)) {
-          SayWithDeclaration(symbol,
-              "Deallocation of polymorphic object '%s' is not permitted in a pure subprogram"_err_en_US,
-              symbol.name());
-        } else if (derived) {
-          if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) {
-            SayWithDeclaration(*bad,
-                "Deallocation of polymorphic object '%s%s' is not permitted in a pure subprogram"_err_en_US,
-                symbol.name(), bad.BuildResultDesignatorName());
-          }
-        }
-      }
     }
     if (symbol.attrs().test(Attr::VOLATILE) &&
         (IsDummy(symbol) || !InInterface())) {
       messages_.Say(
           "A pure subprogram may not have a variable with the VOLATILE attribute"_err_en_US);
     }
     if (IsProcedure(symbol) && !IsPureProcedure(symbol) && IsDummy(symbol)) {
       messages_.Say(
if (!IsStmtFunctionDummy(symbol)) { // C726
       }
     }
     if (IsProcedurePointer(symbol) && symbol.HasExplicitInterface()) {
       // Don't check function result types here
     } else {
       Check(*type, canHaveAssumedParameter);
     }
     if (InPure() && InFunction() && IsFunctionResult(symbol)) {
-      if (derived && HasImpureFinal(*derived)) { // C1584
-        messages_.Say(
-            "Result of pure function may not have an impure FINAL subroutine"_err_en_US);
-      }
       if (type->IsPolymorphic() && IsAllocatable(symbol)) { // C1585
         messages_.Say(
             "Result of pure function may not be both polymorphic and ALLOCATABLE"_err_en_US);
       }
       if (derived) {
+        // These cases would be caught be the general validation of local
+        // variables in a pure context, but these messages are more specific.
+        if (HasImpureFinal(symbol)) { // C1584
+          messages_.Say(
+              "Result of pure function may not have an impure FINAL subroutine"_err_en_US);
+        }
         if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) {
           SayWithDeclaration(*bad,
               "Result of pure function may not have polymorphic ALLOCATABLE ultimate component '%s'"_err_en_US,
               bad.BuildResultDesignatorName());
         }
       }
     }
   }
if (!details.coshape().empty()) {
     if (IsBadCoarrayType(derived)) { // C747 & C824
       messages_.Say(
           "Coarray '%s' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR"_err_en_US,
           symbol.name());
     }
   }
   if (details.isDummy()) {
     if (IsIntentOut(symbol)) {
+      // Some of these errors would also be caught by the general check
+      // for definability of automatically deallocated local variables,
+      // but these messages are more specific.
       if (FindUltimateComponent(symbol, [](const Symbol &x) {
             return evaluate::IsCoarray(x) && IsAllocatable(x);
           })) { // C846
         messages_.Say(
             "An INTENT(OUT) dummy argument may not be, or contain, an ALLOCATABLE coarray"_err_en_US);
       }
       if (IsOrContainsEventOrLockComponent(symbol)) { // C847
         messages_.Say(
if (InPure() && !IsStmtFunction(DEREF(innermostSymbol_)) &&
         } else if (derived) {
           if (FindUltimateComponent(*derived, [](const Symbol &x) {
                 const DeclTypeSpec *type{x.GetType()};
                 return type && type->IsPolymorphic();
               })) { // C1588
             messages_.Say(
                 "An INTENT(OUT) dummy argument of a pure subroutine may not have a polymorphic ultimate component"_err_en_US);
           }
-          if (HasImpureFinal(*derived)) { // C1587
+          if (HasImpureFinal(symbol)) { // C1587
             messages_.Say(
                 "An INTENT(OUT) dummy argument of a pure subroutine may not have an impure FINAL subroutine"_err_en_US);
           }
         }
       } else if (!IsIntentInOut(symbol)) { // C1586
         messages_.Say(
             "non-POINTER dummy argument of pure subroutine must have INTENT() or VALUE attribute"_err_en_US);
       }
void CheckHelper::CheckObjectEntity(
   }
   if (type && type->IsPolymorphic() &&
       !(type->IsAssumedType() || IsAllocatableOrPointer(symbol) ||
           IsDummy(symbol))) { // C708
     messages_.Say("CLASS entity '%s' must be a dummy argument or have "
                   "ALLOCATABLE or POINTER attribute"_err_en_US,
         symbol.name());
   }
+  if (derived && InPure() && !InInterface() &&
+      IsAutomaticallyDestroyed(symbol) &&
+      !IsIntentOut(symbol) /*has better messages*/ &&
+      !IsFunctionResult(symbol) /*ditto*/) {
+    // Check automatically deallocated local variables for possible
+    // problems with finalization in PURE.
+    if (auto whyNot{
+            WhyNotDefinable(symbol.name(), symbol.owner(), {}, symbol)}) {
+      if (auto *msg{messages_.Say(
+              "'%s' may not be a local variable in a pure subprogram"_err_en_US,
+              symbol.name())}) {
+        msg->Attach(std::move(*whyNot));
+      }
+    }
+  }
 }
 
 void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
   if (IsPointer(symbol) && !context_.HasError(symbol) &&
       !scopeIsUninstantiatedPDT_) {
     if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
       if (object->init()) { // C764, C765; C808
         if (auto designator{evaluate::AsGenericExpr(symbol)}) {
if (symbol.attrs().test(a1) && symbol.attrs().test(a2)) {
     return true;
   } else {
     return false;
   }
 }
 
 void CheckHelper::WarnMissingFinal(const Symbol &symbol) {
   const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
-  if (!object || IsPointer(symbol)) {
+  if (!object ||
+      (!IsAutomaticallyDestroyed(symbol) &&
+          symbol.owner().kind() != Scope::Kind::DerivedType)) {
     return;
   }
   const DeclTypeSpec *type{object->type()};
   const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
   const Symbol *derivedSym{derived ? &derived->typeSymbol() : nullptr};
   int rank{object->shape().Rank()};
   const Symbol *initialDerivedSym{derivedSym};
   while (const auto *derivedDetails{

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

public:
   // Deallocation can be caused by exiting a block that declares an allocatable
   // entity, assignment to an allocatable variable, or an actual DEALLOCATE
   // statement
   //
   // Note also that the deallocation of a derived type entity might cause the
   // invocation of an IMPURE final subroutine. (C1139)
   //
 
-  // Only to be called for symbols with ObjectEntityDetails
-  static bool HasImpureFinal(const Symbol &original) {
-    const Symbol &symbol{ResolveAssociations(original)};
-    if (symbol.has<ObjectEntityDetails>()) {
-      if (const DeclTypeSpec * symType{symbol.GetType()}) {
-        if (const DerivedTypeSpec * derived{symType->AsDerived()}) {
-          return semantics::HasImpureFinal(*derived);
-        }
-      }
-    }
-    return false;
-  }
-
   // Predicate for deallocations caused by block exit and direct deallocation
   static bool DeallocateAll(const Symbol &) { return true; }
 
   // Predicate for deallocations caused by intrinsic assignment
   static bool DeallocateNonCoarray(const Symbol &component) {
     return !evaluate::IsCoarray(component);
   }
 
if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
             }
           }
         }
       }
     }
     return false;
   }
 
-  void SayDeallocateWithImpureFinal(const Symbol &entity, const char *reason) {
+  void SayDeallocateWithImpureFinal(
+      const Symbol &entity, const char *reason, const Symbol &impure) {
     context_.SayWithDecl(entity, currentStatementSourcePosition_,
-        "Deallocation of an entity with an IMPURE FINAL procedure"
-        " caused by %s not allowed in DO CONCURRENT"_err_en_US,
-        reason);
+        "Deallocation of an entity with an IMPURE FINAL procedure '%s' caused by %s not allowed in DO CONCURRENT"_err_en_US,
+        impure.name(), reason);
   }
 
   void SayDeallocateOfPolymorph(
       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,
         reason);
void Post(const parser::BlockConstruct &blockConstruct) {
     if (DoesScopeContain(&doScope, blockScope)) {
       const char *reason{"block exit"};
       for (auto &pair : blockScope) {
         const Symbol &entity{*pair.second};
         if (IsAllocatable(entity) && !IsSaved(entity) &&
             MightDeallocatePolymorphic(entity, DeallocateAll)) {
           SayDeallocateOfPolymorph(endBlockStmt.source, entity, reason);
         }
-        if (HasImpureFinal(entity)) {
-          SayDeallocateWithImpureFinal(entity, reason);
+        if (const Symbol * impure{HasImpureFinal(entity)}) {
+          SayDeallocateWithImpureFinal(entity, reason, *impure);
         }
       }
     }
   }
 
   // Deallocation caused by assignment
   // Note that this case does not cause deallocation of coarray components
   void Post(const parser::AssignmentStmt &stmt) {
     const auto &variable{std::get<parser::Variable>(stmt.t)};
     if (const Symbol * entity{GetLastName(variable).symbol}) {
       const char *reason{"assignment"};
       if (MightDeallocatePolymorphic(*entity, DeallocateNonCoarray)) {
         SayDeallocateOfPolymorph(variable.GetSource(), *entity, reason);
       }
-      if (HasImpureFinal(*entity)) {
-        SayDeallocateWithImpureFinal(*entity, reason);
+      if (const Symbol * impure{HasImpureFinal(*entity)}) {
+        SayDeallocateWithImpureFinal(*entity, reason, *impure);
       }
     }
     if (const auto *assignment{GetAssignment(stmt)}) {
       if (const auto *call{
               std::get_if<evaluate::ProcedureRef>(&assignment->u)}) {
         if (auto bad{FindImpureCall(context_.foldingContext(), *call)}) {
           context_.Say(currentStatementSourcePosition_,
               "The defined assignment subroutine '%s' is not pure"_err_en_US,
for (const auto &allocateObject : allocateObjectList) {
       if (name.symbol) {
         const Symbol &entity{*name.symbol};
         const DeclTypeSpec *entityType{entity.GetType()};
         if ((entityType && entityType->IsPolymorphic()) || // POINTER case
             MightDeallocatePolymorphic(entity, DeallocateAll)) {
           SayDeallocateOfPolymorph(
               currentStatementSourcePosition_, entity, reason);
         }
-        if (HasImpureFinal(entity)) {
-          SayDeallocateWithImpureFinal(entity, reason);
+        if (const Symbol * impure{HasImpureFinal(entity)}) {
+          SayDeallocateWithImpureFinal(entity, reason, *impure);
         }
       }
     }
   }
 
   // C1137 -- No image control statements in a DO CONCURRENT
   void Post(const parser::ExecutableConstruct &construct) {
     if (IsImageControlStmt(construct)) {

flang/lib/Semantics/definable.cpp

if (flags.test(DefinabilityFlag::PointerDefinition)) {
     }
     return std::nullopt; // pointer assignment - skip following checks
   }
   if (IsOrContainsEventOrLockComponent(ultimate)) {
     return BlameSymbol(at,
         "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US,
         original);
   }
-  if (!flags.test(DefinabilityFlag::PolymorphicOkInPure) &&
-      FindPureProcedureContaining(scope)) {
+  if (FindPureProcedureContaining(scope)) {
     if (auto dyType{evaluate::DynamicType::From(ultimate)}) {
+      if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
         if (dyType->IsPolymorphic()) { // C1596
           return BlameSymbol(at,
-            "'%s' is polymorphic in a pure subprogram"_because_en_US, original);
+              "'%s' is polymorphic in a pure subprogram"_because_en_US,
+              original);
+        }
+      }
+      if (const Symbol * impure{HasImpureFinal(ultimate)}) {
+        return BlameSymbol(at,
+            "'%s' has an impure FINAL procedure '%s'"_because_en_US, original,
+            impure->name());
       }
       if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(dyType)}) {
-        if (auto bad{FindPolymorphicAllocatableNonCoarrayUltimateComponent(
-                *derived)}) {
+        if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
+          if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) {
             return BlameSymbol(at,
-              "'%s' has polymorphic non-coarray component '%s' in a pure subprogram"_because_en_US,
+                "'%s' has polymorphic component '%s' in a pure subprogram"_because_en_US,
                 original, bad.BuildResultDesignatorName());
           }
         }
       }
     }
+  }
   return std::nullopt;
 }
 
 // Checks a data-ref
 static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
     const Scope &scope, DefinabilityFlags flags,
     const evaluate::DataRef &dataRef) {
   const Symbol &base{GetRelevantSymbol(dataRef,

flang/lib/Semantics/tools.cpp

for (const auto &pair : derived->finals()) {
           }
         }
       }
     }
   }
   return result;
 }
 
-bool IsFinalizable(
-    const Symbol &symbol, std::set<const DerivedTypeSpec *> *inProgress) {
-  if (IsPointer(symbol)) {
-    return false;
+const Symbol *IsFinalizable(const Symbol &symbol,
+    std::set<const DerivedTypeSpec *> *inProgress, bool withImpureFinalizer) {
+  if (IsPointer(symbol) || evaluate::IsAssumedRank(symbol)) {
+    return nullptr;
   }
   if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
     if (object->isDummy() && !IsIntentOut(symbol)) {
-      return false;
+      return nullptr;
     }
     const DeclTypeSpec *type{object->type()};
-    const DerivedTypeSpec *typeSpec{type ? type->AsDerived() : nullptr};
-    return typeSpec && IsFinalizable(*typeSpec, inProgress);
+    if (const DerivedTypeSpec * typeSpec{type ? type->AsDerived() : nullptr}) {
+      return IsFinalizable(
+          *typeSpec, inProgress, withImpureFinalizer, symbol.Rank());
     }
-  return false;
+  }
+  return nullptr;
 }
 
-bool IsFinalizable(const DerivedTypeSpec &derived,
-    std::set<const DerivedTypeSpec *> *inProgress) {
-  if (!FinalsForDerivedTypeInstantiation(derived).empty()) {
-    return true;
+const Symbol *IsFinalizable(const DerivedTypeSpec &derived,
+    std::set<const DerivedTypeSpec *> *inProgress, bool withImpureFinalizer,
+    std::optional<int> rank) {
+  const Symbol *elemental{nullptr};
+  for (auto ref : FinalsForDerivedTypeInstantiation(derived)) {
+    const Symbol *symbol{&ref->GetUltimate()};
+    if (const auto *binding{symbol->detailsIf<ProcBindingDetails>()}) {
+      symbol = &binding->symbol();
+    }
+    if (const auto *proc{symbol->detailsIf<ProcEntityDetails>()}) {
+      symbol = proc->procInterface();
+    }
+    if (!symbol) {
+    } else if (IsElementalProcedure(*symbol)) {
+      elemental = symbol;
+    } else {
+      if (rank) {
+        if (const SubprogramDetails *
+            subp{symbol->detailsIf<SubprogramDetails>()}) {
+          if (const auto &args{subp->dummyArgs()}; !args.empty() &&
+              args.at(0) && !evaluate::IsAssumedRank(*args.at(0)) &&
+              args.at(0)->Rank() != *rank) {
+            continue; // not a finalizer for this rank
+          }
+        }
+      }
+      if (!withImpureFinalizer || !IsPureProcedure(*symbol)) {
+        return symbol;
+      }
+      // Found non-elemental pure finalizer of matching rank, but still
+      // need to check components for an impure finalizer.
+      elemental = nullptr;
+      break;
+    }
+  }
+  if (elemental && (!withImpureFinalizer || !IsPureProcedure(*elemental))) {
+    return elemental;
   }
+  // Check components (including ancestors)
   std::set<const DerivedTypeSpec *> basis;
   if (inProgress) {
     if (inProgress->find(&derived) != inProgress->end()) {
-      return false; // don't loop on recursive type
+      return nullptr; // don't loop on recursive type
     }
   } else {
     inProgress = &basis;
   }
   auto iterator{inProgress->insert(&derived).first};
-  PotentialComponentIterator components{derived};
-  bool result{bool{std::find_if(
-      components.begin(), components.end(), [=](const Symbol &component) {
-        return IsFinalizable(component, inProgress);
-      })}};
+  const Symbol *result{nullptr};
+  for (const Symbol &component : PotentialComponentIterator{derived}) {
+    result = IsFinalizable(component, inProgress, withImpureFinalizer);
+    if (result) {
+      break;
+    }
+  }
   inProgress->erase(iterator);
   return result;
 }
 
-bool HasImpureFinal(const DerivedTypeSpec &derived) {
-  for (auto ref : FinalsForDerivedTypeInstantiation(derived)) {
-    if (!IsPureProcedure(*ref)) {
-      return true;
-    }
+static const Symbol *HasImpureFinal(
+    const DerivedTypeSpec &derived, std::optional<int> rank) {
+  return IsFinalizable(derived, nullptr, /*withImpureFinalizer=*/true, rank);
+
+const Symbol *HasImpureFinal(const Symbol &original) {
+  const Symbol &symbol{ResolveAssociations(original)};
+  if (symbol.has<ObjectEntityDetails>()) {
+    if (const DeclTypeSpec * symType{symbol.GetType()}) {
+      if (const DerivedTypeSpec * derived{symType->AsDerived()}) {
+        // finalizable assumed-rank not allowed (C839)
+        return evaluate::IsAssumedRank(symbol)
+            ? nullptr
+            : HasImpureFinal(*derived, symbol.Rank());
       }
-  return false;
+    }
+  }
+  return nullptr;
 }
 
 bool IsAssumedLengthCharacter(const Symbol &symbol) {
   if (const DeclTypeSpec * type{symbol.GetType()}) {
     return type->category() == DeclTypeSpec::Character &&
         type->characterTypeSpec().length().isAssumed();
   } else {
     return false;

 
 UltimateComponentIterator::const_iterator
 FindPolymorphicAllocatableUltimateComponent(const DerivedTypeSpec &derived) {
   UltimateComponentIterator ultimates{derived};
   return std::find_if(
       ultimates.begin(), ultimates.end(), IsPolymorphicAllocatable);
 }
 
-UltimateComponentIterator::const_iterator
-FindPolymorphicAllocatableNonCoarrayUltimateComponent(
-    const DerivedTypeSpec &derived) {
-  UltimateComponentIterator ultimates{derived};
-  return std::find_if(ultimates.begin(), ultimates.end(), [](const Symbol &x) {
-    return IsPolymorphicAllocatable(x) && !evaluate::IsCoarray(x);
-  });
-}
-
 const Symbol *FindUltimateComponent(const DerivedTypeSpec &derived,
     const std::function<bool(const Symbol &)> &predicate) {
   UltimateComponentIterator ultimates{derived};
   if (auto it{std::find_if(ultimates.begin(), ultimates.end(),
           [&predicate](const Symbol &component) -> bool {
             return predicate(component);
           })}) {
     return &*it;
bool HasAlternateReturns(const Symbol &subprogram) {
   for (const auto *dummyArg : subprogram.get<SubprogramDetails>().dummyArgs()) {
     if (!dummyArg) {
       return true;
     }
   }
   return false;
 }
 
+bool IsAutomaticallyDestroyed(const Symbol &symbol) {
+  return symbol.has<ObjectEntityDetails>() &&
+      (symbol.owner().kind() == Scope::Kind::Subprogram ||
+          symbol.owner().kind() == Scope::Kind::BlockConstruct) &&
+      (!IsDummy(symbol) || IsIntentOut(symbol)) && !IsPointer(symbol) &&
+      !IsSaved(symbol) && !FindCommonBlockContaining(symbol);
+}
+
 const std::optional<parser::Name> &MaybeGetNodeName(
     const ConstructNode &construct) {
   return common::visit(
       common::visitors{
           [&](const parser::BlockConstruct *blockConstruct)
               -> const std::optional<parser::Name> & {
             return std::get<0>(blockConstruct->t).statement.v;
           },

flang/module/__fortran_type_info.f90

type :: DerivedType
     ! Special bindings of the ancestral types are not duplicated here.
     ! Bindings are in ascending order of their "which" code values.
     type(SpecialBinding), pointer, contiguous :: special(:)
     ! A little-endian bit set of SpecialBinding::Which codes present in "special"
     integer(4) :: specialBitSet
     integer(1) :: hasParent
     integer(1) :: noInitializationNeeded ! 1 if no component w/ init
     integer(1) :: noDestructionNeeded ! 1 if no component w/ dealloc/final
-    integer(1) :: noFinalizationNeeded ! 1 if nothing finalizaable
+    integer(1) :: noFinalizationNeeded ! 1 if nothing finalizeable
     integer(1) :: __padding0(4)
   end type
 
   type :: Binding
     type(__builtin_c_funptr) :: proc
     character(len=:), pointer :: name
   end type
 

flang/test/Semantics/call10.f90

contains
   ! C1594 is tested in call12.f90.
   pure subroutine s10 ! C1595
     integer :: n
     !ERROR: Procedure 'notpure' referenced in pure subprogram 's10' must be pure too
     n = notpure(1)
   end subroutine
   pure subroutine s11(to) ! C1596
     ! Implicit deallocation at the end of the subroutine
-    !ERROR: Deallocation of polymorphic object 'auto%a' is not permitted in a pure subprogram
+    !ERROR: 'auto' may not be a local variable in a pure subprogram
+    !BECAUSE: 'auto' has polymorphic component '%a' in a pure subprogram
     type(polyAlloc) :: auto
     type(polyAlloc), intent(in out) :: to
     !ERROR: Left-hand side of assignment is not definable
-    !BECAUSE: 'to' has polymorphic non-coarray component '%a' in a pure subprogram
+    !BECAUSE: 'to' has polymorphic component '%a' in a pure subprogram
     to = auto
   end subroutine
   pure subroutine s12
     character(20) :: buff
     real :: x
     write(buff, *) 1.0 ! ok
     read(buff, *) x ! ok
     !ERROR: External I/O is not allowed in a pure subprogram

flang/test/Semantics/deallocate07.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 
 module m
   type t1
   end type
   type t2
     class(t2), allocatable :: pc
   end type
+  class(t1), pointer :: mp1
+  type(t2) :: mv1
  contains
   pure subroutine subr(pp1, pp2, mp2)
     class(t1), intent(in out), pointer :: pp1
     class(t2), intent(in out) :: pp2
     type(t2), pointer :: mp2
-    !ERROR: 'pp1' may not be deallocated in a pure procedure because it is polymorphic
+    !ERROR: Name in DEALLOCATE statement is not definable
+    !BECAUSE: 'mp1' may not be defined in pure subprogram 'subr' because it is host-associated
+    deallocate(mp1)
+    !ERROR: Name in DEALLOCATE statement is not definable
+    !BECAUSE: 'mv1' may not be defined in pure subprogram 'subr' because it is host-associated
+    deallocate(mv1%pc)
+    !ERROR: Object in DEALLOCATE statement is not deallocatable
+    !BECAUSE: 'pp1' is polymorphic in a pure subprogram
     deallocate(pp1)
-    !ERROR: 'pc' may not be deallocated in a pure procedure because it is polymorphic
+    !ERROR: Object in DEALLOCATE statement is not deallocatable
+    !BECAUSE: 'pc' is polymorphic in a pure subprogram
     deallocate(pp2%pc)
-    !ERROR: 'mp2' may not be deallocated in a pure procedure because its type has a polymorphic allocatable ultimate component 'pc'
+    !ERROR: Object in DEALLOCATE statement is not deallocatable
+    !BECAUSE: 'mp2' has polymorphic component '%pc' in a pure subprogram
     deallocate(mp2)
   end subroutine
 end module

flang/test/Semantics/declarations05.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Other checks for declarations in PURE procedures
+module m
+  type t0
+  end type
+  type t1
+   contains
+    final :: final
+  end type
+  type t2
+    type(t1), allocatable :: c
+  end type
+  type t3
+    class(t1), allocatable :: c
+  end type
+  type t4
+    class(t0), allocatable :: c
+  end type
+ contains
+  impure subroutine final(x)
+    type(t1) x
+  end
+  pure subroutine test
+    !ERROR: 'x0' may not be a local variable in a pure subprogram
+    !BECAUSE: 'x0' is polymorphic in a pure subprogram
+    class(t0), allocatable :: x0
+    !ERROR: 'x1' may not be a local variable in a pure subprogram
+    !BECAUSE: 'x1' has an impure FINAL procedure 'final'
+    type(t1) x1
+    !WARNING: 'x1a' of derived type 't1' does not have a FINAL subroutine for its rank (1)
+    type(t1), allocatable :: x1a(:)
+    !ERROR: 'x2' may not be a local variable in a pure subprogram
+    !BECAUSE: 'x2' has an impure FINAL procedure 'final'
+    type(t2) x2
+    !ERROR: 'x3' may not be a local variable in a pure subprogram
+    !BECAUSE: 'x3' has an impure FINAL procedure 'final'
+    type(t3) x3
+    !ERROR: 'x4' may not be a local variable in a pure subprogram
+    !BECAUSE: 'x4' has polymorphic component '%c' in a pure subprogram
+    type(t4) x4
+  end
+end

flang/test/Semantics/doconcurrent08.f90

subroutine s4()
     ! This case does not work currently because the compiler's test for
     ! HasImpureFinal() in .../lib/Semantics/tools.cc doesn't work correctly
 !    do concurrent (i = 1:10)
 !      if (i .eq. 1) deallocate(pfVar)
 !    end do
 
     ! Error to invoke an IMPURE FINAL procedure in a DO CONCURRENT
     do concurrent (i = 1:10)
-          !ERROR: Deallocation of an entity with an IMPURE FINAL procedure caused by a DEALLOCATE statement not allowed in DO CONCURRENT
+      !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by a DEALLOCATE statement not allowed in DO CONCURRENT
       if (i .eq. 1) deallocate(ifVar)
     end do
 
     do concurrent (i = 1:10)
       if (i .eq. 1) then
         block
           type(impureFinal), allocatable :: ifVar
           allocate(ifVar)
-          ! Error here because exiting this scope causes the finalization of 
-          !ifvar which causes the invocation of an IMPURE FINAL procedure
-          !ERROR: Deallocation of an entity with an IMPURE FINAL procedure caused by block exit not allowed in DO CONCURRENT
+          ! Error here because exiting this scope causes the finalization of
+          ! ifvar which causes the invocation of an IMPURE FINAL procedure
+          !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by block exit not allowed in DO CONCURRENT
         end block
       end if
     end do
 
     do concurrent (i = 1:10)
       if (i .eq. 1) then
-        ! Error here because the assignment statement causes the finalization 
+        ! Error here because the assignment statement causes the finalization
         ! of ifvar which causes the invocation of an IMPURE FINAL procedure
-!ERROR: Deallocation of an entity with an IMPURE FINAL procedure caused by assignment not allowed in DO CONCURRENT
+        !ERROR: Deallocation of an entity with an IMPURE FINAL procedure 'impuresub' caused by assignment not allowed in DO CONCURRENT
         ifvar = ifvar1
       end if
     end do
   end subroutine s4
 
 end module m2