[flang-commits] [flang] [flang] Fix spurious error on defined assignment in PURE (PR #139186)
via flang-commits
flang-commits at lists.llvm.org
Thu May 8 17:57:19 PDT 2025
llvmbot wrote:
<!--LLVM PR SUMMARY COMMENT-->
@llvm/pr-subscribers-flang-semantics
Author: Peter Klausler (klausler)
<details>
<summary>Changes</summary>
An assignment to a whole polymorphic object in a PURE subprogram that is implemented by means of a defined assignment procedure shouldn't be subjected to the same definability checks as it would be for an intrinsic assignment (which would also require it to be allocatable).
Fixes https://github.com/llvm/llvm-project/issues/139129.
---
Full diff: https://github.com/llvm/llvm-project/pull/139186.diff
11 Files Affected:
- (modified) flang/lib/Semantics/assignment.cpp (+5)
- (modified) flang/lib/Semantics/check-deallocate.cpp (+2-1)
- (modified) flang/lib/Semantics/check-declarations.cpp (+2-2)
- (modified) flang/lib/Semantics/definable.cpp (+21-21)
- (modified) flang/lib/Semantics/definable.h (+1-1)
- (modified) flang/lib/Semantics/expression.cpp (+3-3)
- (modified) flang/test/Semantics/assign11.f90 (+3-3)
- (added) flang/test/Semantics/bug139129.f90 (+17)
- (modified) flang/test/Semantics/call28.f90 (+1-3)
- (modified) flang/test/Semantics/deallocate07.f90 (+3-3)
- (modified) flang/test/Semantics/declarations05.f90 (+1-1)
``````````diff
diff --git a/flang/lib/Semantics/assignment.cpp b/flang/lib/Semantics/assignment.cpp
index 935f5a03bdb6a..6e55d0210ee0e 100644
--- a/flang/lib/Semantics/assignment.cpp
+++ b/flang/lib/Semantics/assignment.cpp
@@ -72,6 +72,11 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
std::holds_alternative<evaluate::ProcedureRef>(assignment->u)};
if (isDefinedAssignment) {
flags.set(DefinabilityFlag::AllowEventLockOrNotifyType);
+ } else if (const Symbol *
+ whole{evaluate::UnwrapWholeSymbolOrComponentDataRef(lhs)}) {
+ if (IsAllocatable(whole->GetUltimate())) {
+ flags.set(DefinabilityFlag::PotentialDeallocation);
+ }
}
if (auto whyNot{WhyNotDefinable(lhsLoc, scope, flags, lhs)}) {
if (whyNot->IsFatal()) {
diff --git a/flang/lib/Semantics/check-deallocate.cpp b/flang/lib/Semantics/check-deallocate.cpp
index 3bcd4d87b0906..332e6b52e1c9a 100644
--- a/flang/lib/Semantics/check-deallocate.cpp
+++ b/flang/lib/Semantics/check-deallocate.cpp
@@ -36,7 +36,8 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
} else if (auto whyNot{WhyNotDefinable(name.source,
context_.FindScope(name.source),
{DefinabilityFlag::PointerDefinition,
- DefinabilityFlag::AcceptAllocatable},
+ DefinabilityFlag::AcceptAllocatable,
+ DefinabilityFlag::PotentialDeallocation},
*symbol)}) {
// Catch problems with non-definability of the
// pointer/allocatable
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 318085518cc57..c3a228f3ab8a9 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -949,8 +949,8 @@ void CheckHelper::CheckObjectEntity(
!IsFunctionResult(symbol) /*ditto*/) {
// Check automatically deallocated local variables for possible
// problems with finalization in PURE.
- if (auto whyNot{
- WhyNotDefinable(symbol.name(), symbol.owner(), {}, symbol)}) {
+ if (auto whyNot{WhyNotDefinable(symbol.name(), symbol.owner(),
+ {DefinabilityFlag::PotentialDeallocation}, symbol)}) {
if (auto *msg{messages_.Say(
"'%s' may not be a local variable in a pure subprogram"_err_en_US,
symbol.name())}) {
diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp
index 99a31553f2782..931c8e52fc6d7 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -193,6 +193,15 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
return WhyNotDefinableLast(at, scope, flags, dataRef->GetLastSymbol());
}
}
+ auto dyType{evaluate::DynamicType::From(ultimate)};
+ const auto *inPure{FindPureProcedureContaining(scope)};
+ if (inPure && !flags.test(DefinabilityFlag::PolymorphicOkInPure) &&
+ flags.test(DefinabilityFlag::PotentialDeallocation) && dyType &&
+ dyType->IsPolymorphic()) {
+ return BlameSymbol(at,
+ "'%s' is a whole polymorphic object in a pure subprogram"_en_US,
+ original);
+ }
if (flags.test(DefinabilityFlag::PointerDefinition)) {
if (flags.test(DefinabilityFlag::AcceptAllocatable)) {
if (!IsAllocatableOrObjectPointer(&ultimate)) {
@@ -210,26 +219,17 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
"'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US,
original);
}
- if (FindPureProcedureContaining(scope)) {
- if (auto dyType{evaluate::DynamicType::From(ultimate)}) {
- if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
- if (dyType->IsPolymorphic()) { // C1596
- return BlameSymbol(
- at, "'%s' is polymorphic in a pure subprogram"_en_US, original);
- }
- }
- if (const Symbol * impure{HasImpureFinal(ultimate)}) {
- return BlameSymbol(at, "'%s' has an impure FINAL procedure '%s'"_en_US,
- original, impure->name());
- }
+ if (dyType && inPure) {
+ if (const Symbol * impure{HasImpureFinal(ultimate)}) {
+ return BlameSymbol(at, "'%s' has an impure FINAL procedure '%s'"_en_US,
+ original, impure->name());
+ }
+ if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(dyType)}) {
- if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
- if (auto bad{
- FindPolymorphicAllocatablePotentialComponent(*derived)}) {
- return BlameSymbol(at,
- "'%s' has polymorphic component '%s' in a pure subprogram"_en_US,
- original, bad.BuildResultDesignatorName());
- }
+ if (auto bad{FindPolymorphicAllocatablePotentialComponent(*derived)}) {
+ return BlameSymbol(at,
+ "'%s' has polymorphic component '%s' in a pure subprogram"_en_US,
+ original, bad.BuildResultDesignatorName());
}
}
}
@@ -241,10 +241,10 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
const Scope &scope, DefinabilityFlags flags,
const evaluate::DataRef &dataRef) {
+ bool isWholeSymbol{std::holds_alternative<evaluate::SymbolRef>(dataRef.u)};
auto whyNotBase{
WhyNotDefinableBase(at, scope, flags, dataRef.GetFirstSymbol(),
- std::holds_alternative<evaluate::SymbolRef>(dataRef.u),
- DefinesComponentPointerTarget(dataRef, flags))};
+ isWholeSymbol, DefinesComponentPointerTarget(dataRef, flags))};
if (!whyNotBase || !whyNotBase->IsFatal()) {
if (auto whyNotLast{
WhyNotDefinableLast(at, scope, flags, dataRef.GetLastSymbol())}) {
diff --git a/flang/lib/Semantics/definable.h b/flang/lib/Semantics/definable.h
index 902702dbccbf3..0d027961417be 100644
--- a/flang/lib/Semantics/definable.h
+++ b/flang/lib/Semantics/definable.h
@@ -33,7 +33,7 @@ ENUM_CLASS(DefinabilityFlag,
SourcedAllocation, // ALLOCATE(a,SOURCE=)
PolymorphicOkInPure, // don't check for polymorphic type in pure subprogram
DoNotNoteDefinition, // context does not imply definition
- AllowEventLockOrNotifyType)
+ AllowEventLockOrNotifyType, PotentialDeallocation)
using DefinabilityFlags =
common::EnumSet<DefinabilityFlag, DefinabilityFlag_enumSize>;
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index e139bda7e4950..96d039edf89d7 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -3385,15 +3385,15 @@ const Assignment *ExpressionAnalyzer::Analyze(const parser::AssignmentStmt &x) {
const Symbol *lastWhole{
lastWhole0 ? &ResolveAssociations(*lastWhole0) : nullptr};
if (!lastWhole || !IsAllocatable(*lastWhole)) {
- Say("Left-hand side of assignment may not be polymorphic unless assignment is to an entire allocatable"_err_en_US);
+ Say("Left-hand side of intrinsic assignment may not be polymorphic unless assignment is to an entire allocatable"_err_en_US);
} else if (evaluate::IsCoarray(*lastWhole)) {
- Say("Left-hand side of assignment may not be polymorphic if it is a coarray"_err_en_US);
+ Say("Left-hand side of intrinsic assignment may not be polymorphic if it is a coarray"_err_en_US);
}
}
if (auto *derived{GetDerivedTypeSpec(*dyType)}) {
if (auto iter{FindAllocatableUltimateComponent(*derived)}) {
if (ExtractCoarrayRef(lhs)) {
- Say("Left-hand side of assignment must not be coindexed due to allocatable ultimate component '%s'"_err_en_US,
+ Say("Left-hand side of intrinsic assignment must not be coindexed due to allocatable ultimate component '%s'"_err_en_US,
iter.BuildResultDesignatorName());
}
}
diff --git a/flang/test/Semantics/assign11.f90 b/flang/test/Semantics/assign11.f90
index 37216526b5f33..9d70d7109e75e 100644
--- a/flang/test/Semantics/assign11.f90
+++ b/flang/test/Semantics/assign11.f90
@@ -9,10 +9,10 @@ program test
end type
type(t) auc[*]
pa = 1 ! ok
- !ERROR: Left-hand side of assignment may not be polymorphic unless assignment is to an entire allocatable
+ !ERROR: Left-hand side of intrinsic assignment may not be polymorphic unless assignment is to an entire allocatable
pp = 1
- !ERROR: Left-hand side of assignment may not be polymorphic if it is a coarray
+ !ERROR: Left-hand side of intrinsic assignment may not be polymorphic if it is a coarray
pac = 1
- !ERROR: Left-hand side of assignment must not be coindexed due to allocatable ultimate component '%a'
+ !ERROR: Left-hand side of intrinsic assignment must not be coindexed due to allocatable ultimate component '%a'
auc[1] = t()
end
diff --git a/flang/test/Semantics/bug139129.f90 b/flang/test/Semantics/bug139129.f90
new file mode 100644
index 0000000000000..2f0f865854706
--- /dev/null
+++ b/flang/test/Semantics/bug139129.f90
@@ -0,0 +1,17 @@
+!RUN: %flang_fc1 -fsyntax-only %s
+module m
+ type t
+ contains
+ procedure asst
+ generic :: assignment(=) => asst
+ end type
+ contains
+ pure subroutine asst(lhs, rhs)
+ class(t), intent(in out) :: lhs
+ class(t), intent(in) :: rhs
+ end
+ pure subroutine test(x, y)
+ class(t), intent(in out) :: x, y
+ x = y ! spurious definability error
+ end
+end
diff --git a/flang/test/Semantics/call28.f90 b/flang/test/Semantics/call28.f90
index 51430853d663f..f133276f7547e 100644
--- a/flang/test/Semantics/call28.f90
+++ b/flang/test/Semantics/call28.f90
@@ -11,9 +11,7 @@ pure subroutine s1(x)
end subroutine
pure subroutine s2(x)
class(t), intent(in out) :: x
- !ERROR: Left-hand side of assignment may not be polymorphic unless assignment is to an entire allocatable
- !ERROR: Left-hand side of assignment is not definable
- !BECAUSE: 'x' is polymorphic in a pure subprogram
+ !ERROR: Left-hand side of intrinsic assignment may not be polymorphic unless assignment is to an entire allocatable
x = t()
end subroutine
pure subroutine s3(x)
diff --git a/flang/test/Semantics/deallocate07.f90 b/flang/test/Semantics/deallocate07.f90
index 154c680f47c82..dd2885e2cab35 100644
--- a/flang/test/Semantics/deallocate07.f90
+++ b/flang/test/Semantics/deallocate07.f90
@@ -19,11 +19,11 @@ pure subroutine subr(pp1, pp2, mp2)
!ERROR: Name in DEALLOCATE statement is not definable
!BECAUSE: 'mv1' may not be defined in pure subprogram 'subr' because it is host-associated
deallocate(mv1%pc)
- !ERROR: Object in DEALLOCATE statement is not deallocatable
- !BECAUSE: 'pp1' is polymorphic in a pure subprogram
+ !ERROR: Name in DEALLOCATE statement is not definable
+ !BECAUSE: 'pp1' is a whole polymorphic object in a pure subprogram
deallocate(pp1)
!ERROR: Object in DEALLOCATE statement is not deallocatable
- !BECAUSE: 'pc' is polymorphic in a pure subprogram
+ !BECAUSE: 'pc' has polymorphic component '%pc' in a pure subprogram
deallocate(pp2%pc)
!ERROR: Object in DEALLOCATE statement is not deallocatable
!BECAUSE: 'mp2' has polymorphic component '%pc' in a pure subprogram
diff --git a/flang/test/Semantics/declarations05.f90 b/flang/test/Semantics/declarations05.f90
index b6dab7aeea0bc..b1e3d3c773160 100644
--- a/flang/test/Semantics/declarations05.f90
+++ b/flang/test/Semantics/declarations05.f90
@@ -22,7 +22,7 @@ impure subroutine final(x)
end
pure subroutine test
!ERROR: 'x0' may not be a local variable in a pure subprogram
- !BECAUSE: 'x0' is polymorphic in a pure subprogram
+ !BECAUSE: 'x0' is a whole polymorphic object in a pure subprogram
class(t0), allocatable :: x0
!ERROR: 'x1' may not be a local variable in a pure subprogram
!BECAUSE: 'x1' has an impure FINAL procedure 'final'
``````````
</details>
https://github.com/llvm/llvm-project/pull/139186
More information about the flang-commits
mailing list