Skip to content

Commit 53f0367

Browse files
klauslerklausler
authored
[flang] Fix spurious error on defined assignment in PURE (#139186)
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.
1 parent e75fda1 commit 53f0367

File tree

13 files changed

+101
-68
lines changed

13 files changed

+101
-68
lines changed

‎flang/include/flang/Evaluate/tools.h

Lines changed: 10 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -504,42 +504,31 @@ template <typename A> std::optional<Substring> ExtractSubstring(const A &x) {
504504

505505
// If an expression is simply a whole symbol data designator,
506506
// extract and return that symbol, else null.
507+
const Symbol *UnwrapWholeSymbolDataRef(const DataRef &);
508+
const Symbol *UnwrapWholeSymbolDataRef(const std::optional<DataRef> &);
507509
template <typename A> const Symbol *UnwrapWholeSymbolDataRef(const A &x) {
508-
if (auto dataRef{ExtractDataRef(x)}) {
509-
if (const SymbolRef * p{std::get_if<SymbolRef>(&dataRef->u)}) {
510-
return &p->get();
511-
}
512-
}
513-
return nullptr;
510+
return UnwrapWholeSymbolDataRef(ExtractDataRef(x));
514511
}
515512

516513
// If an expression is a whole symbol or a whole component desginator,
517514
// extract and return that symbol, else null.
515+
const Symbol *UnwrapWholeSymbolOrComponentDataRef(const DataRef &);
516+
const Symbol *UnwrapWholeSymbolOrComponentDataRef(
517+
const std::optional<DataRef> &);
518518
template <typename A>
519519
const Symbol *UnwrapWholeSymbolOrComponentDataRef(const A &x) {
520-
if (auto dataRef{ExtractDataRef(x)}) {
521-
if (const SymbolRef * p{std::get_if<SymbolRef>(&dataRef->u)}) {
522-
return &p->get();
523-
} else if (const Component * c{std::get_if<Component>(&dataRef->u)}) {
524-
if (c->base().Rank() == 0) {
525-
return &c->GetLastSymbol();
526-
}
527-
}
528-
}
529-
return nullptr;
520+
return UnwrapWholeSymbolOrComponentDataRef(ExtractDataRef(x));
530521
}
531522

532523
// If an expression is a whole symbol or a whole component designator,
533524
// potentially followed by an image selector, extract and return that symbol,
534525
// else null.
535526
const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(const DataRef &);
527+
const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(
528+
const std::optional<DataRef> &);
536529
template <typename A>
537530
const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(const A &x) {
538-
if (auto dataRef{ExtractDataRef(x)}) {
539-
return UnwrapWholeSymbolOrComponentOrCoarrayRef(*dataRef);
540-
} else {
541-
return nullptr;
542-
}
531+
return UnwrapWholeSymbolOrComponentOrCoarrayRef(ExtractDataRef(x));
543532
}
544533

545534
// GetFirstSymbol(A%B%C[I]%D) -> A

‎flang/lib/Evaluate/tools.cpp

Lines changed: 30 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1318,17 +1318,39 @@ std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
13181318
return msg;
13191319
}
13201320

1321+
const Symbol *UnwrapWholeSymbolDataRef(const DataRef &dataRef) {
1322+
const SymbolRef *p{std::get_if<SymbolRef>(&dataRef.u)};
1323+
return p ? &p->get() : nullptr;
1324+
}
1325+
1326+
const Symbol *UnwrapWholeSymbolDataRef(const std::optional<DataRef> &dataRef) {
1327+
return dataRef ? UnwrapWholeSymbolDataRef(*dataRef) : nullptr;
1328+
}
1329+
1330+
const Symbol *UnwrapWholeSymbolOrComponentDataRef(const DataRef &dataRef) {
1331+
if (const Component * c{std::get_if<Component>(&dataRef.u)}) {
1332+
return c->base().Rank() == 0 ? &c->GetLastSymbol() : nullptr;
1333+
} else {
1334+
return UnwrapWholeSymbolDataRef(dataRef);
1335+
}
1336+
}
1337+
1338+
const Symbol *UnwrapWholeSymbolOrComponentDataRef(
1339+
const std::optional<DataRef> &dataRef) {
1340+
return dataRef ? UnwrapWholeSymbolOrComponentDataRef(*dataRef) : nullptr;
1341+
}
1342+
13211343
const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(const DataRef &dataRef) {
1322-
if (const SymbolRef * p{std::get_if<SymbolRef>(&dataRef.u)}) {
1323-
return &p->get();
1324-
} else if (const Component * c{std::get_if<Component>(&dataRef.u)}) {
1325-
if (c->base().Rank() == 0) {
1326-
return &c->GetLastSymbol();
1327-
}
1328-
} else if (const CoarrayRef * c{std::get_if<CoarrayRef>(&dataRef.u)}) {
1344+
if (const CoarrayRef * c{std::get_if<CoarrayRef>(&dataRef.u)}) {
13291345
return UnwrapWholeSymbolOrComponentOrCoarrayRef(c->base());
1346+
} else {
1347+
return UnwrapWholeSymbolOrComponentDataRef(dataRef);
13301348
}
1331-
return nullptr;
1349+
}
1350+
1351+
const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(
1352+
const std::optional<DataRef> &dataRef) {
1353+
return dataRef ? UnwrapWholeSymbolOrComponentOrCoarrayRef(*dataRef) : nullptr;
13321354
}
13331355

13341356
// GetLastPointerSymbol()

‎flang/lib/Semantics/assignment.cpp

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -72,6 +72,11 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
7272
std::holds_alternative<evaluate::ProcedureRef>(assignment->u)};
7373
if (isDefinedAssignment) {
7474
flags.set(DefinabilityFlag::AllowEventLockOrNotifyType);
75+
} else if (const Symbol *
76+
whole{evaluate::UnwrapWholeSymbolOrComponentDataRef(lhs)}) {
77+
if (IsAllocatable(whole->GetUltimate())) {
78+
flags.set(DefinabilityFlag::PotentialDeallocation);
79+
}
7580
}
7681
if (auto whyNot{WhyNotDefinable(lhsLoc, scope, flags, lhs)}) {
7782
if (whyNot->IsFatal()) {

‎flang/lib/Semantics/check-deallocate.cpp

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -36,7 +36,8 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
3636
} else if (auto whyNot{WhyNotDefinable(name.source,
3737
context_.FindScope(name.source),
3838
{DefinabilityFlag::PointerDefinition,
39-
DefinabilityFlag::AcceptAllocatable},
39+
DefinabilityFlag::AcceptAllocatable,
40+
DefinabilityFlag::PotentialDeallocation},
4041
*symbol)}) {
4142
// Catch problems with non-definability of the
4243
// pointer/allocatable
@@ -74,7 +75,8 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
7475
} else if (auto whyNot{WhyNotDefinable(source,
7576
context_.FindScope(source),
7677
{DefinabilityFlag::PointerDefinition,
77-
DefinabilityFlag::AcceptAllocatable},
78+
DefinabilityFlag::AcceptAllocatable,
79+
DefinabilityFlag::PotentialDeallocation},
7880
*expr)}) {
7981
context_
8082
.Say(source,

‎flang/lib/Semantics/check-declarations.cpp

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -949,8 +949,8 @@ void CheckHelper::CheckObjectEntity(
949949
!IsFunctionResult(symbol) /*ditto*/) {
950950
// Check automatically deallocated local variables for possible
951951
// problems with finalization in PURE.
952-
if (auto whyNot{
953-
WhyNotDefinable(symbol.name(), symbol.owner(), {}, symbol)}) {
952+
if (auto whyNot{WhyNotDefinable(symbol.name(), symbol.owner(),
953+
{DefinabilityFlag::PotentialDeallocation}, symbol)}) {
954954
if (auto *msg{messages_.Say(
955955
"'%s' may not be a local variable in a pure subprogram"_err_en_US,
956956
symbol.name())}) {

‎flang/lib/Semantics/definable.cpp

Lines changed: 20 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -193,6 +193,15 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
193193
return WhyNotDefinableLast(at, scope, flags, dataRef->GetLastSymbol());
194194
}
195195
}
196+
auto dyType{evaluate::DynamicType::From(ultimate)};
197+
const auto *inPure{FindPureProcedureContaining(scope)};
198+
if (inPure && !flags.test(DefinabilityFlag::PolymorphicOkInPure) &&
199+
flags.test(DefinabilityFlag::PotentialDeallocation) && dyType &&
200+
dyType->IsPolymorphic()) {
201+
return BlameSymbol(at,
202+
"'%s' is a whole polymorphic object in a pure subprogram"_en_US,
203+
original);
204+
}
196205
if (flags.test(DefinabilityFlag::PointerDefinition)) {
197206
if (flags.test(DefinabilityFlag::AcceptAllocatable)) {
198207
if (!IsAllocatableOrObjectPointer(&ultimate)) {
@@ -210,26 +219,17 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
210219
"'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US,
211220
original);
212221
}
213-
if (FindPureProcedureContaining(scope)) {
214-
if (auto dyType{evaluate::DynamicType::From(ultimate)}) {
215-
if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
216-
if (dyType->IsPolymorphic()) { // C1596
217-
return BlameSymbol(
218-
at, "'%s' is polymorphic in a pure subprogram"_en_US, original);
219-
}
220-
}
221-
if (const Symbol * impure{HasImpureFinal(ultimate)}) {
222-
return BlameSymbol(at, "'%s' has an impure FINAL procedure '%s'"_en_US,
223-
original, impure->name());
224-
}
222+
if (dyType && inPure) {
223+
if (const Symbol * impure{HasImpureFinal(ultimate)}) {
224+
return BlameSymbol(at, "'%s' has an impure FINAL procedure '%s'"_en_US,
225+
original, impure->name());
226+
}
227+
if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
225228
if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(dyType)}) {
226-
if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
227-
if (auto bad{
228-
FindPolymorphicAllocatablePotentialComponent(*derived)}) {
229-
return BlameSymbol(at,
230-
"'%s' has polymorphic component '%s' in a pure subprogram"_en_US,
231-
original, bad.BuildResultDesignatorName());
232-
}
229+
if (auto bad{FindPolymorphicAllocatablePotentialComponent(*derived)}) {
230+
return BlameSymbol(at,
231+
"'%s' has polymorphic component '%s' in a pure subprogram"_en_US,
232+
original, bad.BuildResultDesignatorName());
233233
}
234234
}
235235
}
@@ -243,7 +243,7 @@ static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
243243
const evaluate::DataRef &dataRef) {
244244
auto whyNotBase{
245245
WhyNotDefinableBase(at, scope, flags, dataRef.GetFirstSymbol(),
246-
std::holds_alternative<evaluate::SymbolRef>(dataRef.u),
246+
evaluate::UnwrapWholeSymbolDataRef(dataRef) != nullptr,
247247
DefinesComponentPointerTarget(dataRef, flags))};
248248
if (!whyNotBase || !whyNotBase->IsFatal()) {
249249
if (auto whyNotLast{

‎flang/lib/Semantics/definable.h

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -33,7 +33,7 @@ ENUM_CLASS(DefinabilityFlag,
3333
SourcedAllocation, // ALLOCATE(a,SOURCE=)
3434
PolymorphicOkInPure, // don't check for polymorphic type in pure subprogram
3535
DoNotNoteDefinition, // context does not imply definition
36-
AllowEventLockOrNotifyType)
36+
AllowEventLockOrNotifyType, PotentialDeallocation)
3737

3838
using DefinabilityFlags =
3939
common::EnumSet<DefinabilityFlag, DefinabilityFlag_enumSize>;

‎flang/lib/Semantics/expression.cpp

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -3475,15 +3475,15 @@ const Assignment *ExpressionAnalyzer::Analyze(const parser::AssignmentStmt &x) {
34753475
const Symbol *lastWhole{
34763476
lastWhole0 ? &ResolveAssociations(*lastWhole0) : nullptr};
34773477
if (!lastWhole || !IsAllocatable(*lastWhole)) {
3478-
Say("Left-hand side of assignment may not be polymorphic unless assignment is to an entire allocatable"_err_en_US);
3478+
Say("Left-hand side of intrinsic assignment may not be polymorphic unless assignment is to an entire allocatable"_err_en_US);
34793479
} else if (evaluate::IsCoarray(*lastWhole)) {
3480-
Say("Left-hand side of assignment may not be polymorphic if it is a coarray"_err_en_US);
3480+
Say("Left-hand side of intrinsic assignment may not be polymorphic if it is a coarray"_err_en_US);
34813481
}
34823482
}
34833483
if (auto *derived{GetDerivedTypeSpec(*dyType)}) {
34843484
if (auto iter{FindAllocatableUltimateComponent(*derived)}) {
34853485
if (ExtractCoarrayRef(lhs)) {
3486-
Say("Left-hand side of assignment must not be coindexed due to allocatable ultimate component '%s'"_err_en_US,
3486+
Say("Left-hand side of intrinsic assignment must not be coindexed due to allocatable ultimate component '%s'"_err_en_US,
34873487
iter.BuildResultDesignatorName());
34883488
}
34893489
}

‎flang/test/Semantics/assign11.f90

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -9,10 +9,10 @@ program test
99
end type
1010
type(t) auc[*]
1111
pa = 1 ! ok
12-
!ERROR: Left-hand side of assignment may not be polymorphic unless assignment is to an entire allocatable
12+
!ERROR: Left-hand side of intrinsic assignment may not be polymorphic unless assignment is to an entire allocatable
1313
pp = 1
14-
!ERROR: Left-hand side of assignment may not be polymorphic if it is a coarray
14+
!ERROR: Left-hand side of intrinsic assignment may not be polymorphic if it is a coarray
1515
pac = 1
16-
!ERROR: Left-hand side of assignment must not be coindexed due to allocatable ultimate component '%a'
16+
!ERROR: Left-hand side of intrinsic assignment must not be coindexed due to allocatable ultimate component '%a'
1717
auc[1] = t()
1818
end

‎flang/test/Semantics/bug139129.f90

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,17 @@
1+
!RUN: %flang_fc1 -fsyntax-only %s
2+
module m
3+
type t
4+
contains
5+
procedure asst
6+
generic :: assignment(=) => asst
7+
end type
8+
contains
9+
pure subroutine asst(lhs, rhs)
10+
class(t), intent(in out) :: lhs
11+
class(t), intent(in) :: rhs
12+
end
13+
pure subroutine test(x, y)
14+
class(t), intent(in out) :: x, y
15+
x = y ! spurious definability error
16+
end
17+
end

‎flang/test/Semantics/call28.f90

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -11,9 +11,7 @@ pure subroutine s1(x)
1111
end subroutine
1212
pure subroutine s2(x)
1313
class(t), intent(in out) :: x
14-
!ERROR: Left-hand side of assignment may not be polymorphic unless assignment is to an entire allocatable
15-
!ERROR: Left-hand side of assignment is not definable
16-
!BECAUSE: 'x' is polymorphic in a pure subprogram
14+
!ERROR: Left-hand side of intrinsic assignment may not be polymorphic unless assignment is to an entire allocatable
1715
x = t()
1816
end subroutine
1917
pure subroutine s3(x)

‎flang/test/Semantics/deallocate07.f90

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -19,11 +19,11 @@ pure subroutine subr(pp1, pp2, mp2)
1919
!ERROR: Name in DEALLOCATE statement is not definable
2020
!BECAUSE: 'mv1' may not be defined in pure subprogram 'subr' because it is host-associated
2121
deallocate(mv1%pc)
22-
!ERROR: Object in DEALLOCATE statement is not deallocatable
23-
!BECAUSE: 'pp1' is polymorphic in a pure subprogram
22+
!ERROR: Name in DEALLOCATE statement is not definable
23+
!BECAUSE: 'pp1' is a whole polymorphic object in a pure subprogram
2424
deallocate(pp1)
25-
!ERROR: Object in DEALLOCATE statement is not deallocatable
26-
!BECAUSE: 'pc' is polymorphic in a pure subprogram
25+
!ERROR: Name in DEALLOCATE statement is not definable
26+
!BECAUSE: 'pc' is a whole polymorphic object in a pure subprogram
2727
deallocate(pp2%pc)
2828
!ERROR: Object in DEALLOCATE statement is not deallocatable
2929
!BECAUSE: 'mp2' has polymorphic component '%pc' in a pure subprogram

‎flang/test/Semantics/declarations05.f90

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -22,7 +22,7 @@ impure subroutine final(x)
2222
end
2323
pure subroutine test
2424
!ERROR: 'x0' may not be a local variable in a pure subprogram
25-
!BECAUSE: 'x0' is polymorphic in a pure subprogram
25+
!BECAUSE: 'x0' is a whole polymorphic object in a pure subprogram
2626
class(t0), allocatable :: x0
2727
!ERROR: 'x1' may not be a local variable in a pure subprogram
2828
!BECAUSE: 'x1' has an impure FINAL procedure 'final'

0 commit comments

Comments
 (0)