[flang] Emit error on impossible-to-implement construct

[klausler]

An assignment to a whole polymorphic allocatable changes its dynamic type to the type of the right-hand side expression. But when the assignment is under control of a WHERE statement, or a FORALL / DO CONCURRENT with a mask expression, there is no interpretation of the assignment, as the type of a variable must be the same for all of its elements.

There is no restriction in the standard against this usage, and no other Fortran compiler complains about it. But it is not possible to implement it in general, and the behavior produced by other compilers is not reasonable, much less worthy of emulating. It's best to simply disallow it with an error message.

Fixes #133669, or more accurately, resolves it.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

Changes

An assignment to a whole polymorphic allocatable changes its dynamic type to the type of the right-hand side expression. But when the assignment is under control of a WHERE statement, or a FORALL / DO CONCURRENT with a mask expression, there is no interpretation of the assignment, as the type of a variable must be the same for all of its elements.

There is no restriction in the standard against this usage, and no other Fortran compiler complains about it. But it is not possible to implement it in general, and the behavior produced by other compilers is not reasonable, much less worthy of emulating. It's best to simply disallow it with an error message.

Fixes #133669, or more accurately, resolves it.

---

Full diff: https://github.com/llvm/llvm-project/pull/160384.diff

4 Files Affected:

• (modified) flang/docs/Extensions.md (+11)
• (modified) flang/lib/Semantics/assignment.cpp (+29-1)
• (modified) flang/lib/Semantics/assignment.h (+2)
• (added) flang/test/Semantics/bug133669.f90 (+51)

diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index c442a9cd6859e..5a706cf3ee21c 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -557,6 +557,17 @@ end
   generic intrinsic function's inferred result type does not
   match an explicit declaration.  This message is a warning.
 
+* There is no restriction in the standard against assigning
+  to a whole polymorphic allocatable under control of a `WHERE`
+  or concurrent-header mask, but it can't work in general,
+  since the type of the variable can't be modified elementally.
+  The compiler flags this case as an error as there is no
+  possible implementation.
+  (All other compilers allow it, but the results are never meaningful;
+  some never change the type, some change the type according to
+  the value of the last mask element, and others treat these
+  assignment statements as no-ops.)
+
 ## Standard features that might as well not be
 
 * f18 supports designators with constant expressions, properly
diff --git a/flang/lib/Semantics/assignment.cpp b/flang/lib/Semantics/assignment.cpp
index 88e08887160d9..eb34fcfc27a98 100644
--- a/flang/lib/Semantics/assignment.cpp
+++ b/flang/lib/Semantics/assignment.cpp
@@ -39,9 +39,10 @@ class AssignmentContext {
 
   template <typename A> void PushWhereContext(const A &);
   void PopWhereContext();
+  void PushConcurrentContext(const parser::ConcurrentHeader &);
+  void PopConcurrentContext(const parser::ConcurrentHeader &);
   void Analyze(const parser::AssignmentStmt &);
   void Analyze(const parser::PointerAssignmentStmt &);
-  void Analyze(const parser::ConcurrentControl &);
   SemanticsContext &context() { return context_; }
 
 private:
@@ -59,6 +60,7 @@ class AssignmentContext {
   int whereDepth_{0}; // number of WHEREs currently nested in
   // shape of masks in LHS of assignments in current WHERE:
   std::vector<std::optional<std::int64_t>> whereExtents_;
+  int concurrentMaskDepth_{0}; // DO CONCURRENT/FORALL nesting with mask exprs
 };
 
 void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
@@ -76,6 +78,12 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
         whole{evaluate::UnwrapWholeSymbolOrComponentDataRef(lhs)}) {
       if (IsAllocatable(whole->GetUltimate())) {
         flags.set(DefinabilityFlag::PotentialDeallocation);
+        if (IsPolymorphic(*whole) &&
+            (whereDepth_ > 0 || concurrentMaskDepth_ > 0)) {
+          Say(lhsLoc,
+              "Assignment to whole polymorphic allocatable '%s' may not be nested in a WHERE or a masked concurrent construct as its type cannot change elementally"_err_en_US,
+              whole->name());
+        }
       }
     }
     if (auto whyNot{WhyNotDefinable(lhsLoc, scope, flags, lhs)}) {
@@ -201,6 +209,20 @@ void AssignmentContext::PopWhereContext() {
   }
 }
 
+void AssignmentContext::PushConcurrentContext(
+    const parser::ConcurrentHeader &x) {
+  if (std::get<std::optional<parser::ScalarLogicalExpr>>(x.t)) {
+    ++concurrentMaskDepth_;
+  }
+}
+
+void AssignmentContext::PopConcurrentContext(
+    const parser::ConcurrentHeader &x) {
+  if (std::get<std::optional<parser::ScalarLogicalExpr>>(x.t)) {
+    --concurrentMaskDepth_;
+  }
+}
+
 AssignmentChecker::~AssignmentChecker() {}
 
 SemanticsContext &AssignmentChecker::context() {
@@ -238,6 +260,12 @@ void AssignmentChecker::Enter(const parser::MaskedElsewhereStmt &x) {
 void AssignmentChecker::Leave(const parser::MaskedElsewhereStmt &) {
   context_.value().PopWhereContext();
 }
+void AssignmentChecker::Enter(const parser::ConcurrentHeader &x) {
+  context_.value().PushConcurrentContext(x);
+}
+void AssignmentChecker::Leave(const parser::ConcurrentHeader &x) {
+  context_.value().PopConcurrentContext(x);
+}
 
 } // namespace Fortran::semantics
 template class Fortran::common::Indirection<
diff --git a/flang/lib/Semantics/assignment.h b/flang/lib/Semantics/assignment.h
index ba537744bfaaa..b4a150d8cf916 100644
--- a/flang/lib/Semantics/assignment.h
+++ b/flang/lib/Semantics/assignment.h
@@ -46,6 +46,8 @@ class AssignmentChecker : public virtual BaseChecker {
   void Leave(const parser::EndWhereStmt &);
   void Enter(const parser::MaskedElsewhereStmt &);
   void Leave(const parser::MaskedElsewhereStmt &);
+  void Enter(const parser::ConcurrentHeader &);
+  void Leave(const parser::ConcurrentHeader &);
 
   SemanticsContext &context();
 
diff --git a/flang/test/Semantics/bug133669.f90 b/flang/test/Semantics/bug133669.f90
new file mode 100644
index 0000000000000..234d10b46e476
--- /dev/null
+++ b/flang/test/Semantics/bug133669.f90
@@ -0,0 +1,51 @@
+!RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+ contains
+  subroutine s(x, y, mask)
+    class(*), allocatable, intent(in out) :: x(:), y(:)
+    logical, intent(in) :: mask(:)
+    select type(x)
+    type is(integer)
+      print *, 'before, x is integer', x
+    type is(real)
+      print *, 'before, x is real', x
+    class default
+      print *, 'before, x has some other type'
+    end select
+    select type(y)
+    type is(integer)
+      print *, 'y is integer', y
+    type is(real)
+      print *, 'y is real', y
+    end select
+    print *, 'mask', mask
+    !ERROR: Assignment to whole polymorphic allocatable 'x' may not be nested in a WHERE or a masked concurrent construct as its type cannot change elementally
+    where(mask) x = y
+    select type(x)
+    type is(integer)
+      print *, 'after, x is integer', x
+    type is(real)
+      print *, 'after, x is real', x
+    class default
+      print *, 'before, x has some other type'
+    end select
+    print *
+  end
+end
+
+program main
+  use m
+  class(*), allocatable :: x(:), y(:)
+  x = [1, 2]
+  y = [3., 4.]
+  call s(x, y, [.false., .false.])
+  x = [1, 2]
+  y = [3., 4.]
+  call s(x, y, [.false., .true.])
+  x = [1, 2]
+  y = [3., 4.]
+  call s(x, y, [.true., .false.])
+  x = [1, 2]
+  y = [3., 4.]
+  call s(x, y, [.true., .true.])
+end program main