[flang] Catch attempts to copy pointers in allocatables in PURE

In a pure context, a pointer acquired from an INTENT(IN) dummy argument
may not be copied.  Catch the case in which the pointer is a component
of an allocatable component at some depth of nesting.

(This patch adds a new component iterator kind that is a variant of
a potential subobject component iterator; it visits all potential
subobject components, plus pointers, into which it does not descend.)

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

Author: klausler

flang/include/flang/Semantics/tools.h

@@ -383,6 +383,10 @@ std::list<std::list<SymbolRef>> GetStorageAssociations(const Scope &);
 //     its non-POINTER components and the potential subobject components of
 //     its non-POINTER derived type components.  (The lifetime of each
 //     potential subobject component is that of the entire instance.)
+//   - PotentialAndPointer subobject components of a derived type are the
+//   closure of
+//     its components (including POINTERs) and the PotentialAndPointer subobject
+//     components of its non-POINTER derived type components.
 // Parent and procedure components are considered against these definitions.
 // For this kind of iterator, the component tree is recursively visited in the
 // following order:
@@ -413,7 +417,8 @@ std::list<std::list<SymbolRef>> GetStorageAssociations(const Scope &);
 //       ....
 //    }
 
-ENUM_CLASS(ComponentKind, Ordered, Direct, Ultimate, Potential, Scope)
+ENUM_CLASS(ComponentKind, Ordered, Direct, Ultimate, Potential, Scope,
+    PotentialAndPointer)
 
 template <ComponentKind componentKind> class ComponentIterator {
 public:
@@ -535,11 +540,14 @@ extern template class ComponentIterator<ComponentKind::Direct>;
 extern template class ComponentIterator<ComponentKind::Ultimate>;
 extern template class ComponentIterator<ComponentKind::Potential>;
 extern template class ComponentIterator<ComponentKind::Scope>;
+extern template class ComponentIterator<ComponentKind::PotentialAndPointer>;
 using OrderedComponentIterator = ComponentIterator<ComponentKind::Ordered>;
 using DirectComponentIterator = ComponentIterator<ComponentKind::Direct>;
 using UltimateComponentIterator = ComponentIterator<ComponentKind::Ultimate>;
 using PotentialComponentIterator = ComponentIterator<ComponentKind::Potential>;
 using ScopeComponentIterator = ComponentIterator<ComponentKind::Scope>;
+using PotentialAndPointerComponentIterator =
+    ComponentIterator<ComponentKind::PotentialAndPointer>;
 
 // Common component searches, the iterator returned is referring to the first
 // component, according to the order defined for the related ComponentIterator,

flang/lib/Semantics/assignment.cpp

@@ -98,9 +98,9 @@ static std::optional<std::string> GetPointerComponentDesignatorName(
     const SomeExpr &expr) {
   if (const auto *derived{
           evaluate::GetDerivedTypeSpec(evaluate::DynamicType::From(expr))}) {
-    UltimateComponentIterator ultimates{*derived};
+    PotentialAndPointerComponentIterator potentials{*derived};
     if (auto pointer{
-            std::find_if(ultimates.begin(), ultimates.end(), IsPointer)}) {
+            std::find_if(potentials.begin(), potentials.end(), IsPointer)}) {
       return pointer.BuildResultDesignatorName();
     }
   }
@@ -116,7 +116,7 @@ bool CheckCopyabilityInPureScope(parser::ContextualMessages &messages,
       if (auto pointer{GetPointerComponentDesignatorName(expr)}) {
         evaluate::SayWithDeclaration(messages, *base,
             "A pure subprogram may not copy the value of '%s' because it is %s"
-            " and has the POINTER component '%s'"_err_en_US,
+            " and has the POINTER potential subobject component '%s'"_err_en_US,
             base->name(), why, *pointer);
         return false;
       }

flang/lib/Semantics/tools.cpp

@@ -806,34 +806,6 @@ bool IsModuleProcedure(const Symbol &symbol) {
   return ClassifyProcedure(symbol) == ProcedureDefinitionClass::Module;
 }
 
-PotentialComponentIterator::const_iterator FindPolymorphicPotentialComponent(
-    const DerivedTypeSpec &derived) {
-  PotentialComponentIterator potentials{derived};
-  return std::find_if(
-      potentials.begin(), potentials.end(), [](const Symbol &component) {
-        if (const auto *details{component.detailsIf<ObjectEntityDetails>()}) {
-          const DeclTypeSpec *type{details->type()};
-          return type && type->IsPolymorphic();
-        }
-        return false;
-      });
-}
-
-bool IsOrContainsPolymorphicComponent(const Symbol &original) {
-  const Symbol &symbol{ResolveAssociations(original)};
-  if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
-    if (const DeclTypeSpec * type{details->type()}) {
-      if (type->IsPolymorphic()) {
-        return true;
-      }
-      if (const DerivedTypeSpec * derived{type->AsDerived()}) {
-        return (bool)FindPolymorphicPotentialComponent(*derived);
-      }
-    }
-  }
-  return false;
-}
-
 class ImageControlStmtHelper {
   using ImageControlStmts =
       std::variant<parser::ChangeTeamConstruct, parser::CriticalConstruct,
@@ -1130,6 +1102,9 @@ ComponentIterator<componentKind>::const_iterator::PlanComponentTraversal(
           traverse = !IsPointer(component);
         } else if constexpr (componentKind == ComponentKind::Scope) {
           traverse = !IsAllocatableOrPointer(component);
+        } else if constexpr (componentKind ==
+            ComponentKind::PotentialAndPointer) {
+          traverse = !IsPointer(component);
         }
         if (traverse) {
           const Symbol &newTypeSymbol{derived->typeSymbol()};
@@ -1165,6 +1140,8 @@ static bool StopAtComponentPre(const Symbol &component) {
             component.get<ObjectEntityDetails>().type()->AsIntrinsic());
   } else if constexpr (componentKind == ComponentKind::Potential) {
     return !IsPointer(component);
+  } else if constexpr (componentKind == ComponentKind::PotentialAndPointer) {
+    return true;
   }
 }
 
@@ -1233,6 +1210,7 @@ template class ComponentIterator<ComponentKind::Direct>;
 template class ComponentIterator<ComponentKind::Ultimate>;
 template class ComponentIterator<ComponentKind::Potential>;
 template class ComponentIterator<ComponentKind::Scope>;
+template class ComponentIterator<ComponentKind::PotentialAndPointer>;
 
 UltimateComponentIterator::const_iterator FindCoarrayUltimateComponent(
     const DerivedTypeSpec &derived) {

flang/test/Semantics/call12.f90

@@ -17,6 +17,9 @@ module m
   type :: hasCoarray
     real, allocatable :: co[:]
   end type
+  type :: hasHiddenPtr
+    type(hasPtr), allocatable :: a
+  end type
  contains
   integer pure function purefunc(x)
     integer, intent(in) :: x
@@ -26,14 +29,17 @@ integer pure function f00(p0)
     procedure(purefunc) :: p0
     f00 = p0(1)
   end function
-  pure function test(ptr, in, hpd)
+  pure function test(ptr, in, hpd, hhpd)
     use used
     type(t), pointer :: ptr, ptr2
     type(t), target, intent(in) :: in
     type(t), target :: y, z
     type(hasPtr) :: hp
     type(hasPtr), intent(in) :: hpd
+    type(hasHiddenPtr) :: hhp
+    type(hasHiddenPtr), intent(in) :: hhpd
     type(hasPtr), allocatable :: alloc
+    type(hasHiddenPtr), allocatable :: hpAlloc
     type(hasCoarray), pointer :: hcp
     integer :: n
     common /block/ y
@@ -76,10 +82,14 @@ pure function test(ptr, in, hpd)
     n = size([hasPtr(ptr%a)]) ! C1594(4)
     !ERROR: Externally visible object 'in' may not be associated with pointer component 'p' in a pure procedure
     n = size([hasPtr(in%a)]) ! C1594(4)
-    !ERROR: A pure subprogram may not copy the value of 'hpd' because it is an INTENT(IN) dummy argument and has the POINTER component '%p'
+    !ERROR: A pure subprogram may not copy the value of 'hpd' because it is an INTENT(IN) dummy argument and has the POINTER potential subobject component '%p'
     hp = hpd ! C1594(5)
-    !ERROR: A pure subprogram may not copy the value of 'hpd' because it is an INTENT(IN) dummy argument and has the POINTER component '%p'
+    !ERROR: A pure subprogram may not copy the value of 'hpd' because it is an INTENT(IN) dummy argument and has the POINTER potential subobject component '%p'
     allocate(alloc, source=hpd)
+    !ERROR: A pure subprogram may not copy the value of 'hhpd' because it is an INTENT(IN) dummy argument and has the POINTER potential subobject component '%a%p'
+    hhp = hhpd
+    !ERROR: A pure subprogram may not copy the value of 'hhpd' because it is an INTENT(IN) dummy argument and has the POINTER potential subobject component '%a%p'
+    allocate(hpAlloc, source=hhpd)
     !ERROR: Actual procedure argument for dummy argument 'p0=' of a PURE procedure must have an explicit interface
     n = f00(extfunc)
    contains