From 2780c209e1e242fd9e7d71045f88fe4e824cee20 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler@nvidia.com>
Date: Tue, 30 Sep 2025 10:34:41 -0700
Subject: [PATCH] [flang] Emit error on impossible-to-implement construct
 (#160384)

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 https://github.com/llvm/llvm-project/issues/133669, or more
accurately, resolves it.
---
 flang/docs/Extensions.md           | 11 +++++++
 flang/lib/Semantics/assignment.cpp |  6 +++-
 flang/test/Semantics/bug133669.f90 | 51 ++++++++++++++++++++++++++++++
 3 files changed, 67 insertions(+), 1 deletion(-)
 create mode 100644 flang/test/Semantics/bug133669.f90

diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index c442a9cd6859..9f9de6529dd0 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`
+  construct or statement, but there is no good portable
+  behavior to implement and the standard isn't entirely clear
+  what it should mean.
+  (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, some treat these
+  assignment statements as no-ops, and the rest crash during compilation.)
+  The compiler flags this case as an error.
+
 ## 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 88e08887160d..f4aa496e485e 100644
--- a/flang/lib/Semantics/assignment.cpp
+++ b/flang/lib/Semantics/assignment.cpp
@@ -41,7 +41,6 @@ public:
   void PopWhereContext();
   void Analyze(const parser::AssignmentStmt &);
   void Analyze(const parser::PointerAssignmentStmt &);
-  void Analyze(const parser::ConcurrentControl &);
   SemanticsContext &context() { return context_; }
 
 private:
@@ -76,6 +75,11 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
         whole{evaluate::UnwrapWholeSymbolOrComponentDataRef(lhs)}) {
       if (IsAllocatable(whole->GetUltimate())) {
         flags.set(DefinabilityFlag::PotentialDeallocation);
+        if (IsPolymorphic(*whole) && whereDepth_ > 0) {
+          Say(lhsLoc,
+              "Assignment to whole polymorphic allocatable '%s' may not be nested in a WHERE statement or construct"_err_en_US,
+              whole->name());
+        }
       }
     }
     if (auto whyNot{WhyNotDefinable(lhsLoc, scope, flags, lhs)}) {
diff --git a/flang/test/Semantics/bug133669.f90 b/flang/test/Semantics/bug133669.f90
new file mode 100644
index 000000000000..b4d55db193a2
--- /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 statement or construct
+    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