[flang] Use definability tests for better PURE constraint checking

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.

Differential Revision: https://reviews.llvm.org/D147389

flang/include/flang/Semantics/tools.h

@@ -123,6 +123,7 @@ 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,
@@ -167,11 +168,14 @@ 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>()};
@@ -565,8 +569,6 @@ 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.

flang/lib/Evaluate/tools.cpp

@@ -1454,8 +1454,6 @@ bool IsSaved(const Symbol &original) {
     // 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) ||

flang/lib/Semantics/check-deallocate.cpp

@@ -37,11 +37,21 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
                              {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);
               }
             },
@@ -63,8 +73,13 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
                         .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));
                   }
                 }
               }
@@ -96,28 +111,4 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
   }
 }
 
-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-deallocate.h

@@ -22,7 +22,6 @@ class DeallocateChecker : public virtual BaseChecker {
   void Leave(const parser::DeallocateStmt &);
 
 private:
-  bool CheckPolymorphism(parser::CharBlock, const Symbol &);
   SemanticsContext &context_;
 };
 } // namespace Fortran::semantics

flang/lib/Semantics/check-declarations.cpp

@@ -9,6 +9,7 @@
 // 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"
@@ -312,19 +313,6 @@ void CheckHelper::Check(const Symbol &symbol) {
               "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())) {
@@ -359,15 +347,17 @@ void CheckHelper::Check(const Symbol &symbol) {
       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,
@@ -656,6 +646,9 @@ void CheckHelper::CheckObjectEntity(
   }
   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
@@ -701,7 +694,7 @@ void CheckHelper::CheckObjectEntity(
             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);
           }
@@ -789,6 +782,21 @@ void CheckHelper::CheckObjectEntity(
                   "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) {
@@ -1735,7 +1743,9 @@ bool CheckHelper::CheckConflicting(const Symbol &symbol, Attr a1, Attr a2) {
 
 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()};

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

@@ -115,19 +115,6 @@ class DoConcurrentBodyEnforce {
   // 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; }
 
@@ -166,11 +153,11 @@ class DoConcurrentBodyEnforce {
     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(
@@ -199,8 +186,8 @@ class DoConcurrentBodyEnforce {
             MightDeallocatePolymorphic(entity, DeallocateAll)) {
           SayDeallocateOfPolymorph(endBlockStmt.source, entity, reason);
         }
-        if (HasImpureFinal(entity)) {
-          SayDeallocateWithImpureFinal(entity, reason);
+        if (const Symbol * impure{HasImpureFinal(entity)}) {
+          SayDeallocateWithImpureFinal(entity, reason, *impure);
         }
       }
     }
@@ -215,8 +202,8 @@ class DoConcurrentBodyEnforce {
       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)}) {
@@ -248,8 +235,8 @@ class DoConcurrentBodyEnforce {
           SayDeallocateOfPolymorph(
               currentStatementSourcePosition_, entity, reason);
         }
-        if (HasImpureFinal(entity)) {
-          SayDeallocateWithImpureFinal(entity, reason);
+        if (const Symbol * impure{HasImpureFinal(entity)}) {
+          SayDeallocateWithImpureFinal(entity, reason, *impure);
         }
       }
     }

flang/lib/Semantics/definable.cpp

@@ -156,19 +156,27 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock 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 (dyType->IsPolymorphic()) { // C1596
+      if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
+        if (dyType->IsPolymorphic()) { // C1596
+          return BlameSymbol(at,
+              "'%s' is polymorphic in a pure subprogram"_because_en_US,
+              original);
+        }
+      }
+      if (const Symbol * impure{HasImpureFinal(ultimate)}) {
         return BlameSymbol(at,
-            "'%s' is polymorphic in a pure subprogram"_because_en_US, original);
+            "'%s' has an impure FINAL procedure '%s'"_because_en_US, original,
+            impure->name());
       }
       if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(dyType)}) {
-        if (auto bad{FindPolymorphicAllocatableNonCoarrayUltimateComponent(
-                *derived)}) {
-          return BlameSymbol(at,
-              "'%s' has polymorphic non-coarray component '%s' in a pure subprogram"_because_en_US,
-              original, bad.BuildResultDesignatorName());
+        if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
+          if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) {
+            return BlameSymbol(at,
+                "'%s' has polymorphic component '%s' in a pure subprogram"_because_en_US,
+                original, bad.BuildResultDesignatorName());
+          }
         }
       }
     }