[flang] Fix spurious error on defined assignment in PURE #139186
Merged
Conversation
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
llvmbot
added
flang
|
@llvm/pr-subscribers-flang-semantics Author: Peter Klausler (klausler) ChangesAn 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 #139129. Full diff: https://github.com/llvm/llvm-project/pull/139186.diff 11 Files Affected:
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'
|
eugeneepshteyn
approved these changes
May 9, 2025
akuhlens
approved these changes
May 9, 2025
klausler
force-pushed
the
bug139129
branch
2 times, most recently
from
2cd1129 to
7f1fec0
Compare
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 llvm#139129.
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
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 #139129.