[flang] Catch C15104(4) violations when coindexing is present

[klausler]

The value of a structure constructor component can't have a pointer ultimate component if it is a coindexed designator.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

Changes

The value of a structure constructor component can't have a pointer ultimate component if it is a coindexed designator.

---

Patch is 21.57 KiB, truncated to 20.00 KiB below, full version: https://github.com/llvm/llvm-project/pull/130677.diff

6 Files Affected:

• (modified) flang/include/flang/Semantics/tools.h (-4)
• (modified) flang/lib/Semantics/check-call.cpp (+16-18)
• (modified) flang/lib/Semantics/expression.cpp (+16-8)
• (modified) flang/lib/Semantics/tools.cpp (-63)
• (modified) flang/test/Semantics/structconst03.f90 (+26-8)
• (modified) flang/test/Semantics/structconst04.f90 (+26-8)

diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index 16fd8d158b0e0..a6992fdc7431f 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -47,10 +47,6 @@ const Scope *FindModuleFileContaining(const Scope &);
 const Scope *FindPureProcedureContaining(const Scope &);
 const Scope *FindOpenACCConstructContaining(const Scope *);
 
-const Symbol *FindPointerComponent(const Scope &);
-const Symbol *FindPointerComponent(const DerivedTypeSpec &);
-const Symbol *FindPointerComponent(const DeclTypeSpec &);
-const Symbol *FindPointerComponent(const Symbol &);
 const Symbol *FindInterface(const Symbol &);
 const Symbol *FindSubprogram(const Symbol &);
 const Symbol *FindOverriddenBinding(
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 205b4a780258c..25cc2e9535a2f 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -444,7 +444,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
         dummy.type.type().AsFortran());
   }
 
-  bool actualIsCoindexed{ExtractCoarrayRef(actual).has_value()};
+  auto actualCoarrayRef{ExtractCoarrayRef(actual)};
   bool dummyIsAssumedSize{dummy.type.attrs().test(
       characteristics::TypeAndShape::Attr::AssumedSize)};
   bool dummyIsAsynchronous{
@@ -455,7 +455,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
       dummy.attrs.test(characteristics::DummyDataObject::Attr::Value)};
   bool dummyIsPolymorphic{dummy.type.type().IsPolymorphic()};
   if (actualIsPolymorphic && dummyIsPolymorphic &&
-      actualIsCoindexed) { // 15.5.2.4(2)
+      actualCoarrayRef) { // 15.5.2.4(2)
     messages.Say(
         "Coindexed polymorphic object may not be associated with a polymorphic %s"_err_en_US,
         dummyName);
@@ -499,7 +499,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
         }
       }
     }
-    if (actualIsCoindexed) {
+    if (actualCoarrayRef) {
       if (dummy.intent != common::Intent::In && !dummyIsValue) {
         if (auto bad{FindAllocatableUltimateComponent(
                 *actualDerived)}) { // 15.5.2.4(6)
@@ -508,15 +508,13 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
               bad.BuildResultDesignatorName(), dummyName);
         }
       }
-      if (auto coarrayRef{evaluate::ExtractCoarrayRef(actual)}) { // C1537
-        const Symbol &coarray{coarrayRef->GetLastSymbol()};
-        if (const DeclTypeSpec * type{coarray.GetType()}) {
-          if (const DerivedTypeSpec * derived{type->AsDerived()}) {
-            if (auto bad{semantics::FindPointerUltimateComponent(*derived)}) {
-              evaluate::SayWithDeclaration(messages, coarray,
-                  "Coindexed object '%s' with POINTER ultimate component '%s' cannot be associated with %s"_err_en_US,
-                  coarray.name(), bad.BuildResultDesignatorName(), dummyName);
-            }
+      const Symbol &coarray{actualCoarrayRef->GetLastSymbol()};
+      if (const DeclTypeSpec * type{coarray.GetType()}) { // C1537
+        if (const DerivedTypeSpec * derived{type->AsDerived()}) {
+          if (auto bad{semantics::FindPointerUltimateComponent(*derived)}) {
+            evaluate::SayWithDeclaration(messages, coarray,
+                "Coindexed object '%s' with POINTER ultimate component '%s' cannot be associated with %s"_err_en_US,
+                coarray.name(), bad.BuildResultDesignatorName(), dummyName);
           }
         }
       }
@@ -557,7 +555,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
     if (actualRank == 0 && !actualIsAssumedRank &&
         !dummyIsAllocatableOrPointer) {
       // Actual is scalar, dummy is an array.  F'2023 15.5.2.5p14
-      if (actualIsCoindexed) {
+      if (actualCoarrayRef) {
         basicError = true;
         messages.Say(
             "Coindexed scalar actual argument must be associated with a scalar %s"_err_en_US,
@@ -764,7 +762,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
       dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)};
   if ((actualIsAsynchronous || actualIsVolatile) &&
       (dummyIsAsynchronous || dummyIsVolatile) && !dummyIsValue) {
-    if (actualIsCoindexed) { // C1538
+    if (actualCoarrayRef) { // C1538
       messages.Say(
           "Coindexed ASYNCHRONOUS or VOLATILE actual argument may not be associated with %s with ASYNCHRONOUS or VOLATILE attributes unless VALUE"_err_en_US,
           dummyName);
@@ -785,12 +783,12 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
       dummy.attrs.test(characteristics::DummyDataObject::Attr::Optional)};
   if (dummyIsAllocatable) {
     if (actualIsAllocatable) {
-      if (actualIsCoindexed && dummy.intent != common::Intent::In) {
+      if (actualCoarrayRef && dummy.intent != common::Intent::In) {
         messages.Say(
             "ALLOCATABLE %s must have INTENT(IN) to be associated with a coindexed actual argument"_err_en_US,
             dummyName);
       }
-      if (!actualIsCoindexed && actualLastSymbol && dummy.type.corank() == 0 &&
+      if (!actualCoarrayRef && actualLastSymbol && dummy.type.corank() == 0 &&
           actualLastSymbol->Corank() > 0) {
         messages.Say(
             "ALLOCATABLE %s is not a coarray but actual argument has corank %d"_err_en_US,
@@ -971,8 +969,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
   if (dummy.attrs.test(characteristics::DummyDataObject::Attr::Target) &&
       context.ShouldWarn(common::UsageWarning::NonTargetPassedToTarget)) {
     bool actualIsVariable{evaluate::IsVariable(actual)};
-    bool actualIsTemp{!actualIsVariable || HasVectorSubscript(actual) ||
-        evaluate::ExtractCoarrayRef(actual)};
+    bool actualIsTemp{
+        !actualIsVariable || HasVectorSubscript(actual) || actualCoarrayRef};
     if (actualIsTemp) {
       messages.Say(common::UsageWarning::NonTargetPassedToTarget,
           "Any pointer associated with TARGET %s during this call will not be associated with the value of '%s' afterwards"_warn_en_US,
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 7b837930bf785..17884e59de481 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -2246,14 +2246,22 @@ MaybeExpr ExpressionAnalyzer::Analyze(
         } else if (IsNullAllocatable(&*value) && IsAllocatable(*symbol)) {
           result.Add(*symbol, Expr<SomeType>{NullPointer{}});
           continue;
-        } else if (const Symbol * pointer{FindPointerComponent(*symbol)};
-            pointer && pureContext) { // C1594(4)
-          if (const Symbol *
-              visible{semantics::FindExternallyVisibleObject(
-                  *value, *pureContext)}) {
-            Say(expr.source,
-                "The externally visible object '%s' may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US,
-                visible->name(), symbol->name(), pointer->name());
+        } else if (auto *derived{evaluate::GetDerivedTypeSpec(
+                       evaluate::DynamicType::From(*symbol))}) {
+          if (auto iter{FindPointerUltimateComponent(*derived)};
+              iter && pureContext) { // F'2023 C15104(4)
+            if (const Symbol *
+                visible{semantics::FindExternallyVisibleObject(
+                    *value, *pureContext)}) {
+              Say(expr.source,
+                  "The externally visible object '%s' may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US,
+                  visible->name(), symbol->name(),
+                  iter.BuildResultDesignatorName());
+            } else if (ExtractCoarrayRef(*value)) {
+              Say(expr.source,
+                  "A coindexed object may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US,
+                  symbol->name(), iter.BuildResultDesignatorName());
+            }
           }
         }
         // Make implicit conversion explicit to allow folding of the structure
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 5e58a0c75c77b..002944915908a 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -311,69 +311,6 @@ bool IsBindCProcedure(const Scope &scope) {
   }
 }
 
-static const Symbol *FindPointerComponent(
-    const Scope &scope, std::set<const Scope *> &visited) {
-  if (!scope.IsDerivedType()) {
-    return nullptr;
-  }
-  if (!visited.insert(&scope).second) {
-    return nullptr;
-  }
-  // If there's a top-level pointer component, return it for clearer error
-  // messaging.
-  for (const auto &pair : scope) {
-    const Symbol &symbol{*pair.second};
-    if (IsPointer(symbol)) {
-      return &symbol;
-    }
-  }
-  for (const auto &pair : scope) {
-    const Symbol &symbol{*pair.second};
-    if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
-      if (const DeclTypeSpec * type{details->type()}) {
-        if (const DerivedTypeSpec * derived{type->AsDerived()}) {
-          if (const Scope * nested{derived->scope()}) {
-            if (const Symbol *
-                pointer{FindPointerComponent(*nested, visited)}) {
-              return pointer;
-            }
-          }
-        }
-      }
-    }
-  }
-  return nullptr;
-}
-
-const Symbol *FindPointerComponent(const Scope &scope) {
-  std::set<const Scope *> visited;
-  return FindPointerComponent(scope, visited);
-}
-
-const Symbol *FindPointerComponent(const DerivedTypeSpec &derived) {
-  if (const Scope * scope{derived.scope()}) {
-    return FindPointerComponent(*scope);
-  } else {
-    return nullptr;
-  }
-}
-
-const Symbol *FindPointerComponent(const DeclTypeSpec &type) {
-  if (const DerivedTypeSpec * derived{type.AsDerived()}) {
-    return FindPointerComponent(*derived);
-  } else {
-    return nullptr;
-  }
-}
-
-const Symbol *FindPointerComponent(const DeclTypeSpec *type) {
-  return type ? FindPointerComponent(*type) : nullptr;
-}
-
-const Symbol *FindPointerComponent(const Symbol &symbol) {
-  return IsPointer(symbol) ? &symbol : FindPointerComponent(symbol.GetType());
-}
-
 // C1594 specifies several ways by which an object might be globally visible.
 const Symbol *FindExternallyVisibleObject(
     const Symbol &object, const Scope &scope, bool isPointerDefinition) {
diff --git a/flang/test/Semantics/structconst03.f90 b/flang/test/Semantics/structconst03.f90
index 7940ada944668..ecd31723b12bb 100644
--- a/flang/test/Semantics/structconst03.f90
+++ b/flang/test/Semantics/structconst03.f90
@@ -49,7 +49,7 @@ module module1
 
  contains
 
-  pure subroutine ps1(dummy1, dummy2, dummy3, dummy4)
+  pure subroutine ps1(dummy1, dummy2, dummy3, dummy4, co2, co3, co4)
     real, target :: local1
     type(t1(0)) :: x1
     type(t2(0)) :: x2
@@ -61,6 +61,9 @@ pure subroutine ps1(dummy1, dummy2, dummy3, dummy4)
     real, intent(inout), target :: dummy4[*]
     real, target :: commonvar1
     common /cblock/ commonvar1
+    type(has_pointer1), intent(in out) :: co2[*]
+    type(has_pointer2), intent(in out) :: co3[*]
+    type(has_pointer3), intent(in out) :: co4[*]
     x1 = t1(0)(local1)
     !ERROR: Externally visible object 'usedfrom1' may not be associated with pointer component 'pt1' in a pure procedure
     x1 = t1(0)(usedfrom1)
@@ -82,14 +85,20 @@ pure subroutine ps1(dummy1, dummy2, dummy3, dummy4)
     x3 = t3(0)(has_pointer2(has_pointer1(modulevar1)))
     !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure
     x4 = t4(0)(has_pointer3(has_pointer1(modulevar1)))
-    !ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component 'ptop'
+    !ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component '%ptop'
     x2 = t2(0)(modulevar2)
-    !ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component 'ptop'
+    !ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component '%pnested%ptop'
     x3 = t3(0)(modulevar3)
-    !ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component 'ptop'
+    !ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component '%has_pointer2%pnested%ptop'
     x4 = t4(0)(modulevar4)
+    !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp1' which has the pointer component '%ptop'
+    x2 = t2(0)(co2[1])
+    !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp2' which has the pointer component '%pnested%ptop'
+    x3 = t3(0)(co3[1])
+    !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp3' which has the pointer component '%has_pointer2%pnested%ptop'
+    x4 = t4(0)(co4[1])
    contains
-    pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
+    pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a, co2a, co3a, co4a)
       real, target :: local1a
       type(t1(0)) :: x1a
       type(t2(0)) :: x2a
@@ -99,6 +108,9 @@ pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
       real, intent(inout), target :: dummy2a
       real, pointer :: dummy3a
       real, intent(inout), target :: dummy4a[*]
+      type(has_pointer1), intent(in out) :: co2a[*]
+      type(has_pointer2), intent(in out) :: co3a[*]
+      type(has_pointer3), intent(in out) :: co4a[*]
       x1a = t1(0)(local1a)
       !ERROR: Externally visible object 'usedfrom1' may not be associated with pointer component 'pt1' in a pure procedure
       x1a = t1(0)(usedfrom1)
@@ -123,12 +135,18 @@ pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
       x3a = t3(0)(has_pointer2(has_pointer1(modulevar1)))
       !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure
       x4a = t4(0)(has_pointer3(has_pointer1(modulevar1)))
-      !ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component 'ptop'
+      !ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component '%ptop'
       x2a = t2(0)(modulevar2)
-      !ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component 'ptop'
+      !ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component '%pnested%ptop'
       x3a = t3(0)(modulevar3)
-      !ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component 'ptop'
+      !ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component '%has_pointer2%pnested%ptop'
       x4a = t4(0)(modulevar4)
+      !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp1' which has the pointer component '%ptop'
+      x2a = t2(0)(co2a[1])
+      !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp2' which has the pointer component '%pnested%ptop'
+      x3a = t3(0)(co3a[1])
+      !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp3' which has the pointer component '%has_pointer2%pnested%ptop'
+      x4a = t4(0)(co4a[1])
     end subroutine subr
   end subroutine
 
diff --git a/flang/test/Semantics/structconst04.f90 b/flang/test/Semantics/structconst04.f90
index f19852b95a607..abddf6001726c 100644
--- a/flang/test/Semantics/structconst04.f90
+++ b/flang/test/Semantics/structconst04.f90
@@ -44,7 +44,7 @@ module module1
 
  contains
 
-  pure subroutine ps1(dummy1, dummy2, dummy3, dummy4)
+  pure subroutine ps1(dummy1, dummy2, dummy3, dummy4, co2, co3, co4)
     real, target :: local1
     type(t1) :: x1
     type(t2) :: x2
@@ -56,6 +56,9 @@ pure subroutine ps1(dummy1, dummy2, dummy3, dummy4)
     real, intent(inout), target :: dummy4[*]
     real, target :: commonvar1
     common /cblock/ commonvar1
+    type(has_pointer1), intent(in out) :: co2[*]
+    type(has_pointer2), intent(in out) :: co3[*]
+    type(has_pointer3), intent(in out) :: co4[*]
     x1 = t1(local1)
     !ERROR: Externally visible object 'usedfrom1' may not be associated with pointer component 'pt1' in a pure procedure
     x1 = t1(usedfrom1)
@@ -77,14 +80,20 @@ pure subroutine ps1(dummy1, dummy2, dummy3, dummy4)
     x3 = t3(has_pointer2(has_pointer1(modulevar1)))
     !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure
     x4 = t4(has_pointer3(has_pointer1(modulevar1)))
-    !ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component 'ptop'
+    !ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component '%ptop'
     x2 = t2(modulevar2)
-    !ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component 'ptop'
+    !ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component '%pnested%ptop'
     x3 = t3(modulevar3)
-    !ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component 'ptop'
+    !ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component '%has_pointer2%pnested%ptop'
     x4 = t4(modulevar4)
+    !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp1' which has the pointer component '%ptop'
+    x2 = t2(co2[1])
+    !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp2' which has the pointer component '%pnested%ptop'
+    x3 = t3(co3[1])
+    !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp3' which has the pointer component '%has_pointer2%pnested%ptop'
+    x4 = t4(co4[1])
    contains
-    pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
+    pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a, co2a, co3a, co4a)
       real, target :: local1a
       type(t1) :: x1a
       type(t2) :: x2a
@@ -94,6 +103,9 @@ pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
       real, intent(inout), target :: dummy2a
       real, pointer :: dummy3a
       real, intent(inout), target :: dummy4a[*]
+      type(has_pointer1), intent(in out) :: co2a[*]
+      type(has_pointer2), intent(in out) :: co3a[*]
+      type(has_pointer3), intent(in out) :: co4a[*]
       x1a = t1(local1a)
       !ERROR: Externally visible object 'usedfrom1' may not be associated with pointer component 'pt1' in a pure procedure
       x1a = t1(usedfrom1)
@@ -118,12 +130,18 @@ pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
       x3a = t3(has_pointer2(has_pointer1(modulevar1)))
       !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure
       x4a = t4(has_pointer3(has_pointer1(modulevar1)))
-      !ERROR: The externally visible object 'modulevar2' may not be used in a pure pro...
[truncated]