[flang] Check for polymorphism in DEALLOCATE statements in pure procedures

[klausler]

Summary

Semantic checking for DEALLOCATE statements omitted checks for
polymorphic objects and ultimate allocatable components in a pure
procedure, which if not caught would allow execution of an impure
FINAL subroutine defined on a type extension.

[clementval]

LGTM

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

 //===-- lib/Semantics/check-deallocate.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
 //
 //===----------------------------------------------------------------------===//
 
 #include "check-deallocate.h"
+#include "flang/Evaluate/type.h"
 #include "flang/Parser/message.h"
 #include "flang/Parser/parse-tree.h"
 #include "flang/Semantics/expression.h"
 #include "flang/Semantics/tools.h"
 
 namespace Fortran::semantics {
 
 void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
   for (const parser::AllocateObject &allocateObject :
       std::get<std::list<parser::AllocateObject>>(deallocateStmt.t)) {
     common::visit(
         common::visitors{
             [&](const parser::Name &name) {
               auto const *symbol{name.symbol};
               if (context_.HasError(symbol)) {
                 // already reported an error
               } else if (!IsVariableName(*symbol)) {
                 context_.Say(name.source,
                     "name in DEALLOCATE statement must be a variable name"_err_en_US);
               } else if (!IsAllocatableOrPointer(
                              symbol->GetUltimate())) { // C932
                 context_.Say(name.source,
                     "name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
-              } else {
+              } else if (CheckPolymorphism(name.source, *symbol)) {
                 context_.CheckIndexVarRedefine(name);
               }
             },
             [&](const parser::StructureComponent &structureComponent) {
               // Only perform structureComponent checks it was successfully
               // analyzed in expression analysis.
               if (GetExpr(context_, allocateObject)) {
-                if (!IsAllocatableOrPointer(
-                        *structureComponent.component.symbol)) { // C932
+                if (const Symbol *symbol{structureComponent.component.symbol}) {
+                  if (!IsAllocatableOrPointer(*symbol)) { // C932
                     context_.Say(structureComponent.component.source,
                         "component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
+                  } else {
+                    CheckPolymorphism(
+                        structureComponent.component.source, *symbol);
+                  }
                 }
               }
             },
         },
         allocateObject.u);
   }
   bool gotStat{false}, gotMsg{false};
   for (const parser::StatOrErrmsg &deallocOpt :
common::visit(
                     "ERRMSG may not be duplicated in a DEALLOCATE statement"_err_en_US);
               }
               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/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
+ 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
+    deallocate(pp1)
+    !ERROR: 'pc' may not be deallocated in a pure procedure because it is polymorphic
+    deallocate(pp2%pc)
+    !ERROR: 'mp2' may not be deallocated in a pure procedure because its type has a polymorphic allocatable ultimate component 'pc'
+    deallocate(mp2)
+  end subroutine
+end module