[flang-commits] [flang] [flang] Emit error on impossible-to-implement construct (PR #160384)
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Tue Sep 23 12:54:17 PDT 2025
https://github.com/klausler created https://github.com/llvm/llvm-project/pull/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.
>From e3c0997869313dc15c17477f655a989b16d204d2 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Tue, 23 Sep 2025 12:46:05 -0700
Subject: [PATCH] [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 https://github.com/llvm/llvm-project/issues/133669, or more
accurately, resolves it.
---
flang/docs/Extensions.md | 11 +++++++
flang/lib/Semantics/assignment.cpp | 30 +++++++++++++++++-
flang/lib/Semantics/assignment.h | 2 ++
flang/test/Semantics/bug133669.f90 | 51 ++++++++++++++++++++++++++++++
4 files changed, 93 insertions(+), 1 deletion(-)
create mode 100644 flang/test/Semantics/bug133669.f90
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
More information about the flang-commits
mailing list