[flang-commits] [flang] [flang] Refine checks on assignments to coarrays (PR #129966)

[Peter Klausler via flang-commits]

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

F'2023 10.2.1.2 paragraph 2 imposes some requirements on the left-hand sides of assignments when they have coindices, and one was not checked while another was inaccurately checked.  In short, intrinsic assignment to a coindexed object can't change its type, and neither can it affect allocatable components.

>From 3ff1defa27209c97ac2059b0011ece1b74140e45 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Wed, 5 Mar 2025 17:17:38 -0800
Subject: [PATCH] [flang] Refine checks on assignments to coarrays

F'2023 10.2.1.2 paragraph 2 imposes some requirements on the left-hand sides
of assignments when they have coindices, and one was not checked while another
was inaccurately checked.  In short, intrinsic assignment to a coindexed object
can't change its type, and neither can it affect allocatable components.
---
 flang/lib/Semantics/expression.cpp | 25 ++++++++++++++++---------
 flang/test/Semantics/assign11.f90  |  9 ++++++---
 2 files changed, 22 insertions(+), 12 deletions(-)

diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 827defd605f7f..a58c14fa9184d 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -3293,15 +3293,22 @@ const Assignment *ExpressionAnalyzer::Analyze(const parser::AssignmentStmt &x) {
             "in a non-pointer intrinsic assignment statement");
         analyzer.CheckForAssumedRank("in an assignment statement");
         const Expr<SomeType> &lhs{analyzer.GetExpr(0)};
-        if (auto dyType{lhs.GetType()};
-            dyType && dyType->IsPolymorphic()) { // 10.2.1.2p1(1)
-          const Symbol *lastWhole0{UnwrapWholeSymbolOrComponentDataRef(lhs)};
-          const Symbol *lastWhole{
-              lastWhole0 ? &ResolveAssociations(*lastWhole0) : nullptr};
-          if (!lastWhole || !IsAllocatable(*lastWhole)) {
-            Say("Left-hand side of assignment may not be polymorphic unless assignment is to an entire allocatable"_err_en_US);
-          } else if (evaluate::IsCoarray(*lastWhole)) {
-            Say("Left-hand side of assignment may not be polymorphic if it is a coarray"_err_en_US);
+        if (auto dyType{lhs.GetType()}) {
+          if (dyType->IsPolymorphic()) { // 10.2.1.2p1(1)
+            const Symbol *lastWhole0{UnwrapWholeSymbolOrComponentDataRef(lhs)};
+            const Symbol *lastWhole{
+                lastWhole0 ? &ResolveAssociations(*lastWhole0) : nullptr};
+            if (!lastWhole || !IsAllocatable(*lastWhole)) {
+              Say("Left-hand side of assignment may not be polymorphic unless assignment is to an entire allocatable"_err_en_US);
+            }
+          }
+          if (auto *derived{GetDerivedTypeSpec(*dyType)}) {
+            if (auto iter{FindAllocatableUltimateComponent(*derived)}) {
+              if (ExtractCoarrayRef(lhs)) {
+                Say("Left-hand side of assignment must not be coindexed due to allocatable ultimate component '%s'"_err_en_US,
+                    iter.BuildResultDesignatorName());
+              }
+            }
           }
         }
       }
diff --git a/flang/test/Semantics/assign11.f90 b/flang/test/Semantics/assign11.f90
index eaa9533409502..645cd4e1c65ac 100644
--- a/flang/test/Semantics/assign11.f90
+++ b/flang/test/Semantics/assign11.f90
@@ -3,10 +3,13 @@
 program test
   class(*), allocatable :: pa
   class(*), pointer :: pp
-  class(*), allocatable :: pac[:]
+  type t
+    real, allocatable :: a
+  end type
+  type(t) auc[*]
   pa = 1 ! ok
   !ERROR: Left-hand side of assignment may not be polymorphic unless assignment is to an entire allocatable
   pp = 1
-  !ERROR: Left-hand side of assignment may not be polymorphic if it is a coarray
-  pac = 1
+  !ERROR: Left-hand side of assignment must not be coindexed due to allocatable ultimate component '%a'
+  auc[1] = t()
 end