Skip to content

Commit 418a20e

Browse files
klauslerklausler
committed
[flang] Catch C15104(4) violations when coindexing is present
The value of a structure constructor component can't have a pointer ultimate component if it is a coindexed designator.
1 parent c189852 commit 418a20e

File tree

6 files changed

+84
-109
lines changed

6 files changed

+84
-109
lines changed

‎flang/include/flang/Semantics/tools.h

Lines changed: 0 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -47,10 +47,6 @@ const Scope *FindModuleFileContaining(const Scope &);
4747
const Scope *FindPureProcedureContaining(const Scope &);
4848
const Scope *FindOpenACCConstructContaining(const Scope *);
4949

50-
const Symbol *FindPointerComponent(const Scope &);
51-
const Symbol *FindPointerComponent(const DerivedTypeSpec &);
52-
const Symbol *FindPointerComponent(const DeclTypeSpec &);
53-
const Symbol *FindPointerComponent(const Symbol &);
5450
const Symbol *FindInterface(const Symbol &);
5551
const Symbol *FindSubprogram(const Symbol &);
5652
const Symbol *FindOverriddenBinding(

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

Lines changed: 16 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -444,7 +444,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
444444
dummy.type.type().AsFortran());
445445
}
446446

447-
bool actualIsCoindexed{ExtractCoarrayRef(actual).has_value()};
447+
auto actualCoarrayRef{ExtractCoarrayRef(actual)};
448448
bool dummyIsAssumedSize{dummy.type.attrs().test(
449449
characteristics::TypeAndShape::Attr::AssumedSize)};
450450
bool dummyIsAsynchronous{
@@ -455,7 +455,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
455455
dummy.attrs.test(characteristics::DummyDataObject::Attr::Value)};
456456
bool dummyIsPolymorphic{dummy.type.type().IsPolymorphic()};
457457
if (actualIsPolymorphic && dummyIsPolymorphic &&
458-
actualIsCoindexed) { // 15.5.2.4(2)
458+
actualCoarrayRef) { // 15.5.2.4(2)
459459
messages.Say(
460460
"Coindexed polymorphic object may not be associated with a polymorphic %s"_err_en_US,
461461
dummyName);
@@ -499,7 +499,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
499499
}
500500
}
501501
}
502-
if (actualIsCoindexed) {
502+
if (actualCoarrayRef) {
503503
if (dummy.intent != common::Intent::In && !dummyIsValue) {
504504
if (auto bad{FindAllocatableUltimateComponent(
505505
*actualDerived)}) { // 15.5.2.4(6)
@@ -508,15 +508,13 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
508508
bad.BuildResultDesignatorName(), dummyName);
509509
}
510510
}
511-
if (auto coarrayRef{evaluate::ExtractCoarrayRef(actual)}) { // C1537
512-
const Symbol &coarray{coarrayRef->GetLastSymbol()};
513-
if (const DeclTypeSpec * type{coarray.GetType()}) {
514-
if (const DerivedTypeSpec * derived{type->AsDerived()}) {
515-
if (auto bad{semantics::FindPointerUltimateComponent(*derived)}) {
516-
evaluate::SayWithDeclaration(messages, coarray,
517-
"Coindexed object '%s' with POINTER ultimate component '%s' cannot be associated with %s"_err_en_US,
518-
coarray.name(), bad.BuildResultDesignatorName(), dummyName);
519-
}
511+
const Symbol &coarray{actualCoarrayRef->GetLastSymbol()};
512+
if (const DeclTypeSpec * type{coarray.GetType()}) { // C1537
513+
if (const DerivedTypeSpec * derived{type->AsDerived()}) {
514+
if (auto bad{semantics::FindPointerUltimateComponent(*derived)}) {
515+
evaluate::SayWithDeclaration(messages, coarray,
516+
"Coindexed object '%s' with POINTER ultimate component '%s' cannot be associated with %s"_err_en_US,
517+
coarray.name(), bad.BuildResultDesignatorName(), dummyName);
520518
}
521519
}
522520
}
@@ -557,7 +555,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
557555
if (actualRank == 0 && !actualIsAssumedRank &&
558556
!dummyIsAllocatableOrPointer) {
559557
// Actual is scalar, dummy is an array. F'2023 15.5.2.5p14
560-
if (actualIsCoindexed) {
558+
if (actualCoarrayRef) {
561559
basicError = true;
562560
messages.Say(
563561
"Coindexed scalar actual argument must be associated with a scalar %s"_err_en_US,
@@ -764,7 +762,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
764762
dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)};
765763
if ((actualIsAsynchronous || actualIsVolatile) &&
766764
(dummyIsAsynchronous || dummyIsVolatile) && !dummyIsValue) {
767-
if (actualIsCoindexed) { // C1538
765+
if (actualCoarrayRef) { // C1538
768766
messages.Say(
769767
"Coindexed ASYNCHRONOUS or VOLATILE actual argument may not be associated with %s with ASYNCHRONOUS or VOLATILE attributes unless VALUE"_err_en_US,
770768
dummyName);
@@ -785,12 +783,12 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
785783
dummy.attrs.test(characteristics::DummyDataObject::Attr::Optional)};
786784
if (dummyIsAllocatable) {
787785
if (actualIsAllocatable) {
788-
if (actualIsCoindexed && dummy.intent != common::Intent::In) {
786+
if (actualCoarrayRef && dummy.intent != common::Intent::In) {
789787
messages.Say(
790788
"ALLOCATABLE %s must have INTENT(IN) to be associated with a coindexed actual argument"_err_en_US,
791789
dummyName);
792790
}
793-
if (!actualIsCoindexed && actualLastSymbol && dummy.type.corank() == 0 &&
791+
if (!actualCoarrayRef && actualLastSymbol && dummy.type.corank() == 0 &&
794792
actualLastSymbol->Corank() > 0) {
795793
messages.Say(
796794
"ALLOCATABLE %s is not a coarray but actual argument has corank %d"_err_en_US,
@@ -971,8 +969,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
971969
if (dummy.attrs.test(characteristics::DummyDataObject::Attr::Target) &&
972970
context.ShouldWarn(common::UsageWarning::NonTargetPassedToTarget)) {
973971
bool actualIsVariable{evaluate::IsVariable(actual)};
974-
bool actualIsTemp{!actualIsVariable || HasVectorSubscript(actual) ||
975-
evaluate::ExtractCoarrayRef(actual)};
972+
bool actualIsTemp{
973+
!actualIsVariable || HasVectorSubscript(actual) || actualCoarrayRef};
976974
if (actualIsTemp) {
977975
messages.Say(common::UsageWarning::NonTargetPassedToTarget,
978976
"Any pointer associated with TARGET %s during this call will not be associated with the value of '%s' afterwards"_warn_en_US,

‎flang/lib/Semantics/expression.cpp

Lines changed: 16 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -2246,14 +2246,22 @@ MaybeExpr ExpressionAnalyzer::Analyze(
22462246
} else if (IsNullAllocatable(&*value) && IsAllocatable(*symbol)) {
22472247
result.Add(*symbol, Expr<SomeType>{NullPointer{}});
22482248
continue;
2249-
} else if (const Symbol * pointer{FindPointerComponent(*symbol)};
2250-
pointer && pureContext) { // C1594(4)
2251-
if (const Symbol *
2252-
visible{semantics::FindExternallyVisibleObject(
2253-
*value, *pureContext)}) {
2254-
Say(expr.source,
2255-
"The externally visible object '%s' may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US,
2256-
visible->name(), symbol->name(), pointer->name());
2249+
} else if (auto *derived{evaluate::GetDerivedTypeSpec(
2250+
evaluate::DynamicType::From(*symbol))}) {
2251+
if (auto iter{FindPointerUltimateComponent(*derived)};
2252+
iter && pureContext) { // F'2023 C15104(4)
2253+
if (const Symbol *
2254+
visible{semantics::FindExternallyVisibleObject(
2255+
*value, *pureContext)}) {
2256+
Say(expr.source,
2257+
"The externally visible object '%s' may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US,
2258+
visible->name(), symbol->name(),
2259+
iter.BuildResultDesignatorName());
2260+
} else if (ExtractCoarrayRef(*value)) {
2261+
Say(expr.source,
2262+
"A coindexed object may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US,
2263+
symbol->name(), iter.BuildResultDesignatorName());
2264+
}
22572265
}
22582266
}
22592267
// Make implicit conversion explicit to allow folding of the structure

‎flang/lib/Semantics/tools.cpp

Lines changed: 0 additions & 63 deletions
Original file line numberDiff line numberDiff line change
@@ -311,69 +311,6 @@ bool IsBindCProcedure(const Scope &scope) {
311311
}
312312
}
313313

314-
static const Symbol *FindPointerComponent(
315-
const Scope &scope, std::set<const Scope *> &visited) {
316-
if (!scope.IsDerivedType()) {
317-
return nullptr;
318-
}
319-
if (!visited.insert(&scope).second) {
320-
return nullptr;
321-
}
322-
// If there's a top-level pointer component, return it for clearer error
323-
// messaging.
324-
for (const auto &pair : scope) {
325-
const Symbol &symbol{*pair.second};
326-
if (IsPointer(symbol)) {
327-
return &symbol;
328-
}
329-
}
330-
for (const auto &pair : scope) {
331-
const Symbol &symbol{*pair.second};
332-
if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
333-
if (const DeclTypeSpec * type{details->type()}) {
334-
if (const DerivedTypeSpec * derived{type->AsDerived()}) {
335-
if (const Scope * nested{derived->scope()}) {
336-
if (const Symbol *
337-
pointer{FindPointerComponent(*nested, visited)}) {
338-
return pointer;
339-
}
340-
}
341-
}
342-
}
343-
}
344-
}
345-
return nullptr;
346-
}
347-
348-
const Symbol *FindPointerComponent(const Scope &scope) {
349-
std::set<const Scope *> visited;
350-
return FindPointerComponent(scope, visited);
351-
}
352-
353-
const Symbol *FindPointerComponent(const DerivedTypeSpec &derived) {
354-
if (const Scope * scope{derived.scope()}) {
355-
return FindPointerComponent(*scope);
356-
} else {
357-
return nullptr;
358-
}
359-
}
360-
361-
const Symbol *FindPointerComponent(const DeclTypeSpec &type) {
362-
if (const DerivedTypeSpec * derived{type.AsDerived()}) {
363-
return FindPointerComponent(*derived);
364-
} else {
365-
return nullptr;
366-
}
367-
}
368-
369-
const Symbol *FindPointerComponent(const DeclTypeSpec *type) {
370-
return type ? FindPointerComponent(*type) : nullptr;
371-
}
372-
373-
const Symbol *FindPointerComponent(const Symbol &symbol) {
374-
return IsPointer(symbol) ? &symbol : FindPointerComponent(symbol.GetType());
375-
}
376-
377314
// C1594 specifies several ways by which an object might be globally visible.
378315
const Symbol *FindExternallyVisibleObject(
379316
const Symbol &object, const Scope &scope, bool isPointerDefinition) {

‎flang/test/Semantics/structconst03.f90

Lines changed: 26 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -49,7 +49,7 @@ module module1
4949

5050
contains
5151

52-
pure subroutine ps1(dummy1, dummy2, dummy3, dummy4)
52+
pure subroutine ps1(dummy1, dummy2, dummy3, dummy4, co2, co3, co4)
5353
real, target :: local1
5454
type(t1(0)) :: x1
5555
type(t2(0)) :: x2
@@ -61,6 +61,9 @@ pure subroutine ps1(dummy1, dummy2, dummy3, dummy4)
6161
real, intent(inout), target :: dummy4[*]
6262
real, target :: commonvar1
6363
common /cblock/ commonvar1
64+
type(has_pointer1), intent(in out) :: co2[*]
65+
type(has_pointer2), intent(in out) :: co3[*]
66+
type(has_pointer3), intent(in out) :: co4[*]
6467
x1 = t1(0)(local1)
6568
!ERROR: Externally visible object 'usedfrom1' may not be associated with pointer component 'pt1' in a pure procedure
6669
x1 = t1(0)(usedfrom1)
@@ -82,14 +85,20 @@ pure subroutine ps1(dummy1, dummy2, dummy3, dummy4)
8285
x3 = t3(0)(has_pointer2(has_pointer1(modulevar1)))
8386
!ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure
8487
x4 = t4(0)(has_pointer3(has_pointer1(modulevar1)))
85-
!ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component 'ptop'
88+
!ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component '%ptop'
8689
x2 = t2(0)(modulevar2)
87-
!ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component 'ptop'
90+
!ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component '%pnested%ptop'
8891
x3 = t3(0)(modulevar3)
89-
!ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component 'ptop'
92+
!ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component '%has_pointer2%pnested%ptop'
9093
x4 = t4(0)(modulevar4)
94+
!ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp1' which has the pointer component '%ptop'
95+
x2 = t2(0)(co2[1])
96+
!ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp2' which has the pointer component '%pnested%ptop'
97+
x3 = t3(0)(co3[1])
98+
!ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp3' which has the pointer component '%has_pointer2%pnested%ptop'
99+
x4 = t4(0)(co4[1])
91100
contains
92-
pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
101+
pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a, co2a, co3a, co4a)
93102
real, target :: local1a
94103
type(t1(0)) :: x1a
95104
type(t2(0)) :: x2a
@@ -99,6 +108,9 @@ pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
99108
real, intent(inout), target :: dummy2a
100109
real, pointer :: dummy3a
101110
real, intent(inout), target :: dummy4a[*]
111+
type(has_pointer1), intent(in out) :: co2a[*]
112+
type(has_pointer2), intent(in out) :: co3a[*]
113+
type(has_pointer3), intent(in out) :: co4a[*]
102114
x1a = t1(0)(local1a)
103115
!ERROR: Externally visible object 'usedfrom1' may not be associated with pointer component 'pt1' in a pure procedure
104116
x1a = t1(0)(usedfrom1)
@@ -123,12 +135,18 @@ pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
123135
x3a = t3(0)(has_pointer2(has_pointer1(modulevar1)))
124136
!ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure
125137
x4a = t4(0)(has_pointer3(has_pointer1(modulevar1)))
126-
!ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component 'ptop'
138+
!ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component '%ptop'
127139
x2a = t2(0)(modulevar2)
128-
!ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component 'ptop'
140+
!ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component '%pnested%ptop'
129141
x3a = t3(0)(modulevar3)
130-
!ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component 'ptop'
142+
!ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component '%has_pointer2%pnested%ptop'
131143
x4a = t4(0)(modulevar4)
144+
!ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp1' which has the pointer component '%ptop'
145+
x2a = t2(0)(co2a[1])
146+
!ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp2' which has the pointer component '%pnested%ptop'
147+
x3a = t3(0)(co3a[1])
148+
!ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp3' which has the pointer component '%has_pointer2%pnested%ptop'
149+
x4a = t4(0)(co4a[1])
132150
end subroutine subr
133151
end subroutine
134152

0 commit comments

Comments
 (0)