[flang-commits] [flang] [flang] Enforce C15104(5) for coindexed values (PR #130203)

[Peter Klausler via flang-commits]

https://github.com/klausler created https://github.com/llvm/llvm-project/pull/130203

A object's value can't be copied from another image by means of an intrinsic assignment statement if it has a derived type that contains a pointer subobject ultimate component.

>From a3ddd4dd639a570dd5c3e486ed3c3a445b88770c Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Thu, 6 Mar 2025 15:14:31 -0800
Subject: [PATCH] [flang] Enforce C15104(5) for coindexed values

A object's value can't be copied from another image by means of
an intrinsic assignment statement if it has a derived type that
contains a pointer subobject ultimate component.
---
 flang/lib/Semantics/assignment.cpp | 14 ++++++++++----
 flang/test/Semantics/call12.f90    |  7 +++++++
 2 files changed, 17 insertions(+), 4 deletions(-)

diff --git a/flang/lib/Semantics/assignment.cpp b/flang/lib/Semantics/assignment.cpp
index 8de20d3126a6c..935f5a03bdb6a 100644
--- a/flang/lib/Semantics/assignment.cpp
+++ b/flang/lib/Semantics/assignment.cpp
@@ -134,10 +134,16 @@ static std::optional<std::string> GetPointerComponentDesignatorName(
 // Checks C1594(5,6); false if check fails
 bool CheckCopyabilityInPureScope(parser::ContextualMessages &messages,
     const SomeExpr &expr, const Scope &scope) {
-  if (const Symbol * base{GetFirstSymbol(expr)}) {
-    if (const char *why{
-            WhyBaseObjectIsSuspicious(base->GetUltimate(), scope)}) {
-      if (auto pointer{GetPointerComponentDesignatorName(expr)}) {
+  if (auto pointer{GetPointerComponentDesignatorName(expr)}) {
+    if (const Symbol * base{GetFirstSymbol(expr)}) {
+      const char *why{WhyBaseObjectIsSuspicious(base->GetUltimate(), scope)};
+      if (!why) {
+        if (auto coarray{evaluate::ExtractCoarrayRef(expr)}) {
+          base = &coarray->GetLastSymbol();
+          why = "coindexed";
+        }
+      }
+      if (why) {
         evaluate::SayWithDeclaration(messages, *base,
             "A pure subprogram may not copy the value of '%s' because it is %s"
             " and has the POINTER potential subobject component '%s'"_err_en_US,
diff --git a/flang/test/Semantics/call12.f90 b/flang/test/Semantics/call12.f90
index cd4006a53b3e7..e7c0fd8b9b8cb 100644
--- a/flang/test/Semantics/call12.f90
+++ b/flang/test/Semantics/call12.f90
@@ -104,4 +104,11 @@ pure subroutine internal
       localhp = hasPtr(z%a)
     end subroutine
   end function
+  pure subroutine test2(hpd, hhpd)
+    use used
+    type(hasHiddenPtr), intent(in out) :: hpd, hhpd[*]
+    hpd = hhpd ! ok
+    !ERROR: A pure subprogram may not copy the value of 'hhpd' because it is coindexed and has the POINTER potential subobject component '%a%p'
+    hpd = hhpd[1]
+  end subroutine
 end module