[flang-commits] [flang] 2780c20 - [flang] Emit error on impossible-to-implement construct (#160384)

[via flang-commits]

Author: Peter Klausler
Date: 2025-09-30T10:34:41-07:00
New Revision: 2780c209e1e242fd9e7d71045f88fe4e824cee20

URL: https://github.com/llvm/llvm-project/commit/2780c209e1e242fd9e7d71045f88fe4e824cee20
DIFF: https://github.com/llvm/llvm-project/commit/2780c209e1e242fd9e7d71045f88fe4e824cee20.diff

LOG: [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.

Added: 
    flang/test/Semantics/bug133669.f90

Modified: 
    flang/docs/Extensions.md
    flang/lib/Semantics/assignment.cpp

Removed: 
    


################################################################################
diff  --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index c442a9cd6859e..9f9de6529dd03 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 88e08887160d9..f4aa496e485e1 100644
--- a/flang/lib/Semantics/assignment.cpp
+++ b/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)}) {

diff  --git a/flang/test/Semantics/bug133669.f90 b/flang/test/Semantics/bug133669.f90
new file mode 100644
index 0000000000000..b4d55db193a2c
--- /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