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