[flang] Semantic checks for deallocating entities with IMPURE FINAL procedures

You cannot call an IMPURE procedure in a DO CONCURRENT construct.  One
way that can happen is if an entity with an IMPURE FINAL procedure gets
deallocated.  Similar to the checks for deallocating coarrays, there are
three ways that an entity can get deallocated that are applicable to DO
CONCURRENT constructs -- an actual DEALLOCATE statement, block exit, and
assignment.

This change depends on the utility function `HasImpureFinal()` in tools.h to
determine if an entity has a derived type with an IMPURE FINAL
procedure.  In the course of testing this change, I realized that this
check is incorrect, but the code specific to DO CONCURRENT is
independent of the check, so I might as well implement it.

Original-commit: flang-compiler/f18@d2294ff511aebd64889df57d02325bd6fcdf914a
Reviewed-on: https://github.com/flang-compiler/f18/pull/954

diff --git a/flang/include/flang/semantics/tools.h b/flang/include/flang/semantics/tools.h
index 5f56325..59e4170 100644 (file)
--- a/flang/include/flang/semantics/tools.h
+++ b/flang/include/flang/semantics/tools.h
@@ -48,7 +48,7 @@ const DeclTypeSpec *FindParentTypeSpec(const DerivedTypeSpec &);
 const DeclTypeSpec *FindParentTypeSpec(const DeclTypeSpec &);
 const DeclTypeSpec *FindParentTypeSpec(const Scope &);
 const DeclTypeSpec *FindParentTypeSpec(const Symbol &);
-
+ 
 // Return the Symbol of the variable of a construct association, if it exists
 const Symbol *GetAssociationRoot(const Symbol &);
 

diff --git a/flang/lib/semantics/check-do.cpp b/flang/lib/semantics/check-do.cpp
index 96c8ba7..75acd1b 100644 (file)
--- a/flang/lib/semantics/check-do.cpp
+++ b/flang/lib/semantics/check-do.cpp
@@ -95,15 +95,33 @@ public:
     return true;
   }
 
+  template<typename T> bool Pre(const parser::UnlabeledStatement<T> &stmt) {
+    currentStatementSourcePosition_ = stmt.source;
+    return true;
+  }
+
   // C1140 -- Can't deallocate a polymorphic entity in a DO CONCURRENT.
   // 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.
+  // invocation of an IMPURE final subroutine. (C1139)
   //
 
+  // Only to be called for symbols with ObjectEntityDetails
+  static bool HasImpureFinal(const Symbol &symbol) {
+    if (const Symbol * root{GetAssociationRoot(symbol)}) {
+      CHECK(root->has<ObjectEntityDetails>());
+      if (const DeclTypeSpec * symType{root->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; }
 
@@ -143,6 +161,21 @@ public:
     return false;
   }
 
+  void SayDeallocateWithImpureFinal(const Symbol &entity, const char *reason) {
+    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);
+  }
+
+  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);
+  }
+
   // Deallocation caused by block exit
   // Allocatable entities and all of their allocatable subcomponents will be
   // deallocated.  This test is different from the other two because it does
@@ -154,16 +187,16 @@ public:
     const Scope &blockScope{context_.FindScope(endBlockStmt.source)};
     const Scope &doScope{context_.FindScope(doConcurrentSourcePosition_)};
     if (DoesScopeContain(&doScope, blockScope)) {
+      const char *reason{"block exit"};
       for (auto &pair : blockScope) {
-        Symbol &entity{*pair.second};
+        const Symbol &entity{*pair.second};
         if (IsAllocatable(entity) && !entity.attrs().test(Attr::SAVE) &&
             MightDeallocatePolymorphic(entity, DeallocateAll)) {
-          context_.SayWithDecl(entity, endBlockStmt.source,
-              "Deallocation of a polymorphic entity caused by block"
-              " exit not allowed in DO CONCURRENT"_err_en_US);
+          SayDeallocateOfPolymorph(endBlockStmt.source, entity, reason);
+        }
+        if (HasImpureFinal(entity)) {
+          SayDeallocateWithImpureFinal(entity, reason);
         }
-        // TODO: Check for deallocation of a variable with an IMPURE FINAL
-        // subroutine
       }
     }
   }
@@ -173,12 +206,12 @@ public:
   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)) {
-        context_.SayWithDecl(*entity, variable.GetSource(),
-            "Deallocation of a polymorphic entity caused by "
-            "assignment not allowed in DO CONCURRENT"_err_en_US);
-        // TODO: Check for deallocation of a variable with an IMPURE FINAL
-        // subroutine
+        SayDeallocateOfPolymorph(variable.GetSource(), *entity, reason);
+      }
+      if (HasImpureFinal(*entity)) {
+        SayDeallocateWithImpureFinal(*entity, reason);
       }
     }
   }
@@ -191,17 +224,18 @@ public:
         std::get<std::list<parser::AllocateObject>>(stmt.t)};
     for (const auto &allocateObject : allocateObjectList) {
       const parser::Name &name{GetLastName(allocateObject)};
+      const char *reason{"a DEALLOCATE statement"};
       if (name.symbol) {
         const Symbol &entity{*name.symbol};
         const DeclTypeSpec *entityType{entity.GetType()};
         if ((entityType && entityType->IsPolymorphic()) ||  // POINTER case
             MightDeallocatePolymorphic(entity, DeallocateAll)) {
-          context_.SayWithDecl(entity, currentStatementSourcePosition_,
-              "Deallocation of a polymorphic entity not allowed in DO"
-              " CONCURRENT"_err_en_US);
+          SayDeallocateOfPolymorph(
+              currentStatementSourcePosition_, entity, reason);
+        }
+        if (HasImpureFinal(entity)) {
+          SayDeallocateWithImpureFinal(entity, reason);
         }
-        // TODO: Check for deallocation of a variable with an IMPURE FINAL
-        // subroutine
       }
     }
   }

diff --git a/flang/lib/semantics/tools.cpp b/flang/lib/semantics/tools.cpp
index a39ff40..8e31a81 100644 (file)
--- a/flang/lib/semantics/tools.cpp
+++ b/flang/lib/semantics/tools.cpp
@@ -508,7 +508,7 @@ const DeclTypeSpec *FindParentTypeSpec(const Symbol &symbol) {
   return nullptr;
 }
 
-// When an construct association maps to a variable, and that variable
+// When a construct association maps to a variable, and that variable
 // is not an array with a vector-valued subscript, return the base
 // Symbol of that variable, else nullptr.  Descends into other construct
 // associations when one associations maps to another.
@@ -665,6 +665,8 @@ bool IsFinalizable(const DerivedTypeSpec &derived) {
       components.end();
 }
 
+// TODO The following function returns true for all types with FINAL procedures
+// This is because we don't yet fill in the data for FinalProcDetails
 bool HasImpureFinal(const DerivedTypeSpec &derived) {
   ScopeComponentIterator components{derived};
   return std::find_if(

diff --git a/flang/test/semantics/doconcurrent08.f90 b/flang/test/semantics/doconcurrent08.f90
index b4b5d41..b42ab61 100644 (file)
--- a/flang/test/semantics/doconcurrent08.f90
+++ b/flang/test/semantics/doconcurrent08.f90
@@ -188,18 +188,88 @@ subroutine s3()
 
   do concurrent (i = 1:10)
     ! Bad because deallocation of a polymorphic entity
-!ERROR: Deallocation of a polymorphic entity not allowed in DO CONCURRENT
+!ERROR: Deallocation of a polymorphic entity caused by a DEALLOCATE statement not allowed in DO CONCURRENT
     deallocate(polyVar)
 
     ! Bad, deallocation of an entity with a polymorphic component
-!ERROR: Deallocation of a polymorphic entity not allowed in DO CONCURRENT
+!ERROR: Deallocation of a polymorphic entity caused by a DEALLOCATE statement not allowed in DO CONCURRENT
     deallocate(polyComponentVar)
 
     ! Bad, deallocation of a pointer to an entity with a polymorphic component
-!ERROR: Deallocation of a polymorphic entity not allowed in DO CONCURRENT
+!ERROR: Deallocation of a polymorphic entity caused by a DEALLOCATE statement not allowed in DO CONCURRENT
     deallocate(pointerPolyComponentVar)
 
     ! Deallocation of a nonpolymorphic entity
     deallocate(nonPolyVar)
   end do
 end subroutine s3
+
+module m2
+  type :: impureFinal
+   contains
+    final :: impureSub
+  end type
+
+  type :: pureFinal
+   contains
+    final :: pureSub
+  end type
+
+ contains
+
+  impure subroutine impureSub(x)
+    type(impureFinal), intent(in) :: x
+  end subroutine
+
+  pure subroutine pureSub(x)
+    type(pureFinal), intent(in) :: x
+  end subroutine
+
+  subroutine s4()
+    type(impureFinal), allocatable :: ifVar, ifvar1
+    type(pureFinal), allocatable :: pfVar
+    allocate(ifVar)
+    allocate(ifVar1)
+    allocate(pfVar)
+
+    ! OK for an ordinary DO loop
+    do i = 1,10
+      if (i .eq. 1) deallocate(ifVar)
+    end do
+
+    ! OK to invoke a PURE FINAL procedure in a DO CONCURRENT
+    ! 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
+      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
+        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 
+        ! 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
+        ifvar = ifvar1
+      end if
+    end do
+  end subroutine s4
+
+end module m2