[flang-commits] [flang] 24db885 - [flang] Check for polymorphism in DEALLOCATE statements in pure procedures

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2022-12-15T16:39:48-08:00
New Revision: 24db8859497f9a5be35e92050ce9b08730dc04ff

URL: https://github.com/llvm/llvm-project/commit/24db8859497f9a5be35e92050ce9b08730dc04ff
DIFF: https://github.com/llvm/llvm-project/commit/24db8859497f9a5be35e92050ce9b08730dc04ff.diff

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

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.

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

Added: 
    flang/test/Semantics/deallocate07.f90

Modified: 
    flang/lib/Semantics/check-deallocate.cpp
    flang/lib/Semantics/check-deallocate.h

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-deallocate.cpp b/flang/lib/Semantics/check-deallocate.cpp
index 0b21244b22cb1..5e46960e3350b 100644
--- a/flang/lib/Semantics/check-deallocate.cpp
+++ b/flang/lib/Semantics/check-deallocate.cpp
@@ -7,6 +7,7 @@
 //===----------------------------------------------------------------------===//
 
 #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"
@@ -30,7 +31,7 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
                              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);
               }
             },
@@ -38,10 +39,14 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
               // Only perform structureComponent checks it was successfully
               // analyzed in expression analysis.
               if (GetExpr(context_, allocateObject)) {
-                if (!IsAllocatableOrPointer(
-                        *structureComponent.component.symbol)) { // C932
-                  context_.Say(structureComponent.component.source,
-                      "component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
+                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);
+                  }
                 }
               }
             },
@@ -71,4 +76,29 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
         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

diff  --git a/flang/lib/Semantics/check-deallocate.h b/flang/lib/Semantics/check-deallocate.h
index 6aafb87a74793..cff75f7d5d8d3 100644
--- a/flang/lib/Semantics/check-deallocate.h
+++ b/flang/lib/Semantics/check-deallocate.h
@@ -22,6 +22,7 @@ class DeallocateChecker : public virtual BaseChecker {
   void Leave(const parser::DeallocateStmt &);
 
 private:
+  bool CheckPolymorphism(parser::CharBlock, const Symbol &);
   SemanticsContext &context_;
 };
 } // namespace Fortran::semantics

diff  --git a/flang/test/Semantics/deallocate07.f90 b/flang/test/Semantics/deallocate07.f90
new file mode 100644
index 0000000000000..2a3d036ec0b66
--- /dev/null
+++ b/flang/test/Semantics/deallocate07.f90
@@ -0,0 +1,21 @@
+! 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