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

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.

Author: klausler

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

flang/lib/Semantics/assignment.cpp

@@ -41,7 +41,6 @@ class AssignmentContext {
   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)}) {

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