Skip to content

Commit 4776a6a

Browse files
klauslerklausler
committed
[flang] Fix spurious error on defined assignment in PURE
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 9f8ff4b commit 4776a6a

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
@@ -502,42 +502,31 @@ template <typename A> std::optional<Substring> ExtractSubstring(const A &x) {
502502

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

514511
// If an expression is a whole symbol or a whole component desginator,
515512
// extract and return that symbol, else null.
513+
const Symbol *UnwrapWholeSymbolOrComponentDataRef(const DataRef &);
514+
const Symbol *UnwrapWholeSymbolOrComponentDataRef(
515+
const std::optional<DataRef> &);
516516
template <typename A>
517517
const Symbol *UnwrapWholeSymbolOrComponentDataRef(const A &x) {
518-
if (auto dataRef{ExtractDataRef(x)}) {
519-
if (const SymbolRef * p{std::get_if<SymbolRef>(&dataRef->u)}) {
520-
return &p->get();
521-
} else if (const Component * c{std::get_if<Component>(&dataRef->u)}) {
522-
if (c->base().Rank() == 0) {
523-
return &c->GetLastSymbol();
524-
}
525-
}
526-
}
527-
return nullptr;
518+
return UnwrapWholeSymbolOrComponentDataRef(ExtractDataRef(x));
528519
}
529520

530521
// If an expression is a whole symbol or a whole component designator,
531522
// potentially followed by an image selector, extract and return that symbol,
532523
// else null.
533524
const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(const DataRef &);
525+
const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(
526+
const std::optional<DataRef> &);
534527
template <typename A>
535528
const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(const A &x) {
536-
if (auto dataRef{ExtractDataRef(x)}) {
537-
return UnwrapWholeSymbolOrComponentOrCoarrayRef(*dataRef);
538-
} else {
539-
return nullptr;
540-
}
529+
return UnwrapWholeSymbolOrComponentOrCoarrayRef(ExtractDataRef(x));
541530
}
542531

543532
// 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
@@ -1320,17 +1320,39 @@ std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
13201320
return msg;
13211321
}
13221322

1323+
const Symbol *UnwrapWholeSymbolDataRef(const DataRef &dataRef) {
1324+
const SymbolRef *p{std::get_if<SymbolRef>(&dataRef.u)};
1325+
return p ? &p->get() : nullptr;
1326+
}
1327+
1328+
const Symbol *UnwrapWholeSymbolDataRef(const std::optional<DataRef> &dataRef) {
1329+
return dataRef ? UnwrapWholeSymbolDataRef(*dataRef) : nullptr;
1330+
}
1331+
1332+
const Symbol *UnwrapWholeSymbolOrComponentDataRef(const DataRef &dataRef) {
1333+
if (const Component * c{std::get_if<Component>(&dataRef.u)}) {
1334+
return c->base().Rank() == 0 ? &c->GetLastSymbol() : nullptr;
1335+
} else {
1336+
return UnwrapWholeSymbolDataRef(dataRef);
1337+
}
1338+
}
1339+
1340+
const Symbol *UnwrapWholeSymbolOrComponentDataRef(
1341+
const std::optional<DataRef> &dataRef) {
1342+
return dataRef ? UnwrapWholeSymbolOrComponentDataRef(*dataRef) : nullptr;
1343+
}
1344+
13231345
const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(const DataRef &dataRef) {
1324-
if (const SymbolRef * p{std::get_if<SymbolRef>(&dataRef.u)}) {
1325-
return &p->get();
1326-
} else if (const Component * c{std::get_if<Component>(&dataRef.u)}) {
1327-
if (c->base().Rank() == 0) {
1328-
return &c->GetLastSymbol();
1329-
}
1330-
} else if (const CoarrayRef * c{std::get_if<CoarrayRef>(&dataRef.u)}) {
1346+
if (const CoarrayRef * c{std::get_if<CoarrayRef>(&dataRef.u)}) {
13311347
return UnwrapWholeSymbolOrComponentOrCoarrayRef(c->base());
1348+
} else {
1349+
return UnwrapWholeSymbolOrComponentDataRef(dataRef);
13321350
}
1333-
return nullptr;
1351+
}
1352+
1353+
const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(
1354+
const std::optional<DataRef> &dataRef) {
1355+
return dataRef ? UnwrapWholeSymbolOrComponentOrCoarrayRef(*dataRef) : nullptr;
13341356
}
13351357

13361358
// 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
@@ -3391,15 +3391,15 @@ const Assignment *ExpressionAnalyzer::Analyze(const parser::AssignmentStmt &x) {
33913391
const Symbol *lastWhole{
33923392
lastWhole0 ? &ResolveAssociations(*lastWhole0) : nullptr};
33933393
if (!lastWhole || !IsAllocatable(*lastWhole)) {
3394-
Say("Left-hand side of assignment may not be polymorphic unless assignment is to an entire allocatable"_err_en_US);
3394+
Say("Left-hand side of intrinsic assignment may not be polymorphic unless assignment is to an entire allocatable"_err_en_US);
33953395
} else if (evaluate::IsCoarray(*lastWhole)) {
3396-
Say("Left-hand side of assignment may not be polymorphic if it is a coarray"_err_en_US);
3396+
Say("Left-hand side of intrinsic assignment may not be polymorphic if it is a coarray"_err_en_US);
33973397
}
33983398
}
33993399
if (auto *derived{GetDerivedTypeSpec(*dyType)}) {
34003400
if (auto iter{FindAllocatableUltimateComponent(*derived)}) {
34013401
if (ExtractCoarrayRef(lhs)) {
3402-
Say("Left-hand side of assignment must not be coindexed due to allocatable ultimate component '%s'"_err_en_US,
3402+
Say("Left-hand side of intrinsic assignment must not be coindexed due to allocatable ultimate component '%s'"_err_en_US,
34033403
iter.BuildResultDesignatorName());
34043404
}
34053405
}

‎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

0 commit comments

Comments
 (0)