Skip to content

Commit 031b4e5

Browse files
klauslerklausler
committed
[flang] Support SELECT RANK on allocatables & pointers
Unlike other executable constructs with associating selectors, the selector of a SELECT RANK construct can have the ALLOCATABLE or POINTER attribute, and will work as an allocatable or object pointer within each rank case, so long as there is no RANK(*) case. Getting this right exposed a correctness risk with the popular predicate IsAllocatableOrPointer() -- it will be true for procedure pointers as well as object pointers, and in many contexts, a procedure pointer should not be acceptable. So this patch adds the new predicate IsAllocatableOrObjectPointer(), and updates some call sites of the original function to use the new one. Differential Revision: https://reviews.llvm.org/D159043
1 parent d77ae42 commit 031b4e5

21 files changed

+222
-72
lines changed

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

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1189,7 +1189,10 @@ bool IsFunction(const Symbol &);
11891189
bool IsFunction(const Scope &);
11901190
bool IsProcedure(const Symbol &);
11911191
bool IsProcedure(const Scope &);
1192+
bool IsProcedurePointer(const Symbol *);
11921193
bool IsProcedurePointer(const Symbol &);
1194+
bool IsObjectPointer(const Symbol *);
1195+
bool IsAllocatableOrObjectPointer(const Symbol *);
11931196
bool IsAutomatic(const Symbol &);
11941197
bool IsSaved(const Symbol &); // saved implicitly or explicitly
11951198
bool IsDummy(const Symbol &);

‎flang/include/flang/Semantics/symbol.h

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -237,7 +237,8 @@ class EntityDetails : public WithBindName {
237237
llvm::raw_ostream &, const EntityDetails &);
238238
};
239239

240-
// Symbol is associated with a name or expression in a SELECT TYPE or ASSOCIATE.
240+
// Symbol is associated with a name or expression in an ASSOCIATE,
241+
// SELECT TYPE, or SELECT RANK construct.
241242
class AssocEntityDetails : public EntityDetails {
242243
public:
243244
AssocEntityDetails() {}
@@ -252,7 +253,7 @@ class AssocEntityDetails : public EntityDetails {
252253

253254
private:
254255
MaybeExpr expr_;
255-
std::optional<int> rank_;
256+
std::optional<int> rank_; // for SELECT RANK
256257
};
257258
llvm::raw_ostream &operator<<(llvm::raw_ostream &, const AssocEntityDetails &);
258259

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -143,6 +143,7 @@ inline bool IsPointer(const Symbol &symbol) {
143143
inline bool IsAllocatable(const Symbol &symbol) {
144144
return symbol.attrs().test(Attr::ALLOCATABLE);
145145
}
146+
// IsAllocatableOrObjectPointer() may be the better choice
146147
inline bool IsAllocatableOrPointer(const Symbol &symbol) {
147148
return IsPointer(symbol) || IsAllocatable(symbol);
148149
}

‎flang/lib/Evaluate/intrinsics.cpp

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2221,7 +2221,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
22212221
if (dummy[*dimArg].optionality == Optionality::required) {
22222222
if (const Symbol *whole{
22232223
UnwrapWholeSymbolOrComponentDataRef(actualForDummy[*dimArg])}) {
2224-
if (IsOptional(*whole) || IsAllocatableOrPointer(*whole)) {
2224+
if (IsOptional(*whole) || IsAllocatableOrObjectPointer(whole)) {
22252225
if (rank == Rank::scalarIfDim || arrayRank.value_or(-1) == 1) {
22262226
messages.Say(
22272227
"The actual argument for DIM= is optional, pointer, or allocatable, and it is assumed to be present and equal to 1 at execution time"_port_en_US);

‎flang/lib/Evaluate/tools.cpp

Lines changed: 31 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1158,7 +1158,8 @@ std::optional<Expr<SomeType>> DataConstantConversionExtension(
11581158
bool IsAllocatableOrPointerObject(
11591159
const Expr<SomeType> &expr, FoldingContext &context) {
11601160
const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)};
1161-
return (sym && semantics::IsAllocatableOrPointer(sym->GetUltimate())) ||
1161+
return (sym &&
1162+
semantics::IsAllocatableOrObjectPointer(&sym->GetUltimate())) ||
11621163
evaluate::IsObjectPointer(expr, context);
11631164
}
11641165

@@ -1388,17 +1389,39 @@ bool IsProcedure(const Scope &scope) {
13881389
return symbol && IsProcedure(*symbol);
13891390
}
13901391

1392+
bool IsProcedurePointer(const Symbol &original) {
1393+
const Symbol &symbol{GetAssociationRoot(original)};
1394+
return IsPointer(symbol) && IsProcedure(symbol);
1395+
}
1396+
1397+
bool IsProcedurePointer(const Symbol *symbol) {
1398+
return symbol && IsProcedurePointer(*symbol);
1399+
}
1400+
1401+
bool IsObjectPointer(const Symbol *original) {
1402+
if (original) {
1403+
const Symbol &symbol{GetAssociationRoot(*original)};
1404+
return IsPointer(symbol) && !IsProcedure(symbol);
1405+
} else {
1406+
return false;
1407+
}
1408+
}
1409+
1410+
bool IsAllocatableOrObjectPointer(const Symbol *original) {
1411+
if (original) {
1412+
const Symbol &symbol{GetAssociationRoot(*original)};
1413+
return IsAllocatable(symbol) || (IsPointer(symbol) && !IsProcedure(symbol));
1414+
} else {
1415+
return false;
1416+
}
1417+
}
1418+
13911419
const Symbol *FindCommonBlockContaining(const Symbol &original) {
13921420
const Symbol &root{GetAssociationRoot(original)};
13931421
const auto *details{root.detailsIf<ObjectEntityDetails>()};
13941422
return details ? details->commonBlock() : nullptr;
13951423
}
13961424

1397-
bool IsProcedurePointer(const Symbol &original) {
1398-
const Symbol &symbol{GetAssociationRoot(original)};
1399-
return IsPointer(symbol) && IsProcedure(symbol);
1400-
}
1401-
14021425
// 3.11 automatic data object
14031426
bool IsAutomatic(const Symbol &original) {
14041427
const Symbol &symbol{original.GetUltimate()};
@@ -1516,14 +1539,14 @@ bool IsAssumedShape(const Symbol &symbol) {
15161539
const Symbol &ultimate{ResolveAssociations(symbol)};
15171540
const auto *object{ultimate.detailsIf<ObjectEntityDetails>()};
15181541
return object && object->CanBeAssumedShape() &&
1519-
!semantics::IsAllocatableOrPointer(ultimate);
1542+
!semantics::IsAllocatableOrObjectPointer(&ultimate);
15201543
}
15211544

15221545
bool IsDeferredShape(const Symbol &symbol) {
15231546
const Symbol &ultimate{ResolveAssociations(symbol)};
15241547
const auto *object{ultimate.detailsIf<ObjectEntityDetails>()};
15251548
return object && object->CanBeDeferredShape() &&
1526-
semantics::IsAllocatableOrPointer(ultimate);
1549+
semantics::IsAllocatableOrObjectPointer(&ultimate);
15271550
}
15281551

15291552
bool IsFunctionResult(const Symbol &original) {

‎flang/lib/Lower/Bridge.cpp

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -581,7 +581,7 @@ class FirConverter : public Fortran::lower::AbstractConverter {
581581
llvm::ArrayRef<mlir::Value> typeParams) -> mlir::Value {
582582
mlir::Value allocVal = builder->allocateLocal(
583583
loc,
584-
Fortran::semantics::IsAllocatableOrPointer(hsym.GetUltimate())
584+
Fortran::semantics::IsAllocatableOrObjectPointer(&hsym.GetUltimate())
585585
? hSymType
586586
: symType,
587587
mangleName(sym), toStringRef(sym.GetUltimate().name()),

‎flang/lib/Lower/ConvertExprToHLFIR.cpp

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -129,7 +129,7 @@ class HlfirDesignatorBuilder {
129129
// shape is deferred and should not be loaded now to preserve
130130
// pointer/allocatable aspects.
131131
if (componentSym.Rank() == 0 ||
132-
Fortran::semantics::IsAllocatableOrPointer(componentSym))
132+
Fortran::semantics::IsAllocatableOrObjectPointer(&componentSym))
133133
return mlir::Value{};
134134

135135
fir::FirOpBuilder &builder = getBuilder();
@@ -488,8 +488,8 @@ class HlfirDesignatorBuilder {
488488
// array ref designates the target (this is done in "visit"). Other
489489
// components need special care to deal with the array%array_comp(indices)
490490
// case.
491-
if (Fortran::semantics::IsAllocatableOrPointer(
492-
component->GetLastSymbol()))
491+
if (Fortran::semantics::IsAllocatableOrObjectPointer(
492+
&component->GetLastSymbol()))
493493
baseType = visit(*component, partInfo);
494494
else
495495
baseType = hlfir::getFortranElementOrSequenceType(
@@ -734,7 +734,7 @@ class HlfirDesignatorBuilder {
734734
if (charTy.hasConstantLen())
735735
partInfo.typeParams.push_back(
736736
builder.createIntegerConstant(loc, idxTy, charTy.getLen()));
737-
else if (!Fortran::semantics::IsAllocatableOrPointer(componentSym))
737+
else if (!Fortran::semantics::IsAllocatableOrObjectPointer(&componentSym))
738738
TODO(loc, "compute character length of automatic character component "
739739
"in a PDT");
740740
// Otherwise, the length of the component is deferred and will only

‎flang/lib/Lower/IO.cpp

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -498,7 +498,7 @@ getNamelistGroup(Fortran::lower::AbstractConverter &converter,
498498
// A global pointer or allocatable variable has a descriptor for typical
499499
// accesses. Variables in multiple namelist groups may already have one.
500500
// Create descriptors for other cases.
501-
if (!IsAllocatableOrPointer(s)) {
501+
if (!IsAllocatableOrObjectPointer(&s)) {
502502
std::string mangleName =
503503
Fortran::lower::mangle::globalNamelistDescriptorName(s);
504504
if (builder.getNamedGlobal(mangleName))

‎flang/lib/Lower/Mangler.cpp

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -277,5 +277,5 @@ std::string Fortran::lower::mangle::mangleArrayLiteral(
277277
std::string Fortran::lower::mangle::globalNamelistDescriptorName(
278278
const Fortran::semantics::Symbol &sym) {
279279
std::string name = mangleName(sym);
280-
return IsAllocatableOrPointer(sym) ? name : name + ".desc"s;
280+
return IsAllocatableOrObjectPointer(&sym) ? name : name + ".desc"s;
281281
}

‎flang/lib/Lower/OpenMP.cpp

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1553,7 +1553,8 @@ bool ClauseProcessor::processCopyin() const {
15531553
checkAndCopyHostAssociateVar(&*mem, &insPt);
15541554
break;
15551555
}
1556-
if (Fortran::semantics::IsAllocatableOrPointer(sym->GetUltimate()))
1556+
if (Fortran::semantics::IsAllocatableOrObjectPointer(
1557+
&sym->GetUltimate()))
15571558
TODO(converter.getCurrentLocation(),
15581559
"pointer or allocatable variables in Copyin clause");
15591560
assert(sym->has<Fortran::semantics::HostAssocDetails>() &&
@@ -1815,7 +1816,7 @@ static fir::GlobalOp globalInitialization(
18151816
firOpBuilder.createGlobal(currentLocation, ty, globalName, linkage);
18161817

18171818
// Create default initialization for non-character scalar.
1818-
if (Fortran::semantics::IsAllocatableOrPointer(sym)) {
1819+
if (Fortran::semantics::IsAllocatableOrObjectPointer(&sym)) {
18191820
mlir::Type baseAddrType = ty.dyn_cast<fir::BoxType>().getEleTy();
18201821
Fortran::lower::createGlobalInitialization(
18211822
firOpBuilder, global, [&](fir::FirOpBuilder &b) {

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

Lines changed: 12 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -39,14 +39,14 @@ class AllocationCheckerHelper {
3939
public:
4040
AllocationCheckerHelper(
4141
const parser::Allocation &alloc, AllocateCheckerInfo &info)
42-
: allocateInfo_{info}, allocateObject_{std::get<parser::AllocateObject>(
43-
alloc.t)},
42+
: allocateInfo_{info},
43+
allocateObject_{std::get<parser::AllocateObject>(alloc.t)},
4444
name_{parser::GetLastName(allocateObject_)},
45-
symbol_{name_.symbol ? &name_.symbol->GetUltimate() : nullptr},
45+
original_{name_.symbol ? &name_.symbol->GetUltimate() : nullptr},
46+
symbol_{original_ ? &ResolveAssociations(*original_) : nullptr},
4647
type_{symbol_ ? symbol_->GetType() : nullptr},
47-
allocateShapeSpecRank_{ShapeSpecRank(alloc)}, rank_{symbol_
48-
? symbol_->Rank()
49-
: 0},
48+
allocateShapeSpecRank_{ShapeSpecRank(alloc)},
49+
rank_{original_ ? original_->Rank() : 0},
5050
allocateCoarraySpecRank_{CoarraySpecRank(alloc)},
5151
corank_{symbol_ ? symbol_->Corank() : 0} {}
5252

@@ -91,7 +91,8 @@ class AllocationCheckerHelper {
9191
AllocateCheckerInfo &allocateInfo_;
9292
const parser::AllocateObject &allocateObject_;
9393
const parser::Name &name_;
94-
const Symbol *symbol_{nullptr};
94+
const Symbol *original_{nullptr}; // no USE or host association
95+
const Symbol *symbol_{nullptr}; // no USE, host, or construct association
9596
const DeclTypeSpec *type_{nullptr};
9697
const int allocateShapeSpecRank_;
9798
const int rank_{0};
@@ -558,17 +559,17 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
558559
}
559560
}
560561
} else {
561-
// first part of C942
562+
// explicit shape-spec-list
562563
if (allocateShapeSpecRank_ != rank_) {
563564
context
564565
.Say(name_.source,
565566
"The number of shape specifications, when they appear, must match the rank of allocatable object"_err_en_US)
566-
.Attach(symbol_->name(), "Declared here with rank %d"_en_US, rank_);
567+
.Attach(
568+
original_->name(), "Declared here with rank %d"_en_US, rank_);
567569
return false;
568570
}
569571
}
570-
} else {
571-
// C940
572+
} else { // allocating a scalar object
572573
if (hasAllocateShapeSpecList()) {
573574
context.Say(name_.source,
574575
"Shape specifications must not appear when allocatable object is scalar"_err_en_US);

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1430,7 +1430,7 @@ static void CheckTransfer(evaluate::ActualArguments &arguments,
14301430
whole->name());
14311431
} else if (context.ShouldWarn(
14321432
common::UsageWarning::TransferSizePresence) &&
1433-
IsAllocatableOrPointer(*whole)) {
1433+
IsAllocatableOrObjectPointer(whole)) {
14341434
messages.Say(
14351435
"SIZE= argument that is allocatable or pointer must be present at execution; parenthesize to silence this warning"_warn_en_US);
14361436
}

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

Lines changed: 29 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -19,20 +19,18 @@ namespace Fortran::semantics {
1919
void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
2020
for (const parser::AllocateObject &allocateObject :
2121
std::get<std::list<parser::AllocateObject>>(deallocateStmt.t)) {
22-
parser::CharBlock source;
23-
const Symbol *symbol{nullptr};
2422
common::visit(
2523
common::visitors{
2624
[&](const parser::Name &name) {
27-
source = name.source;
28-
symbol = name.symbol;
25+
const Symbol *symbol{
26+
name.symbol ? &name.symbol->GetUltimate() : nullptr};
27+
;
2928
if (context_.HasError(symbol)) {
3029
// already reported an error
3130
} else if (!IsVariableName(*symbol)) {
3231
context_.Say(name.source,
3332
"Name in DEALLOCATE statement must be a variable name"_err_en_US);
34-
} else if (!IsAllocatableOrPointer(
35-
symbol->GetUltimate())) { // C932
33+
} else if (!IsAllocatableOrObjectPointer(symbol)) { // C936
3634
context_.Say(name.source,
3735
"Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
3836
} else if (auto whyNot{WhyNotDefinable(name.source,
@@ -61,30 +59,32 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
6159
[&](const parser::StructureComponent &structureComponent) {
6260
// Only perform structureComponent checks if it was successfully
6361
// analyzed by expression analysis.
64-
source = structureComponent.component.source;
65-
symbol = structureComponent.component.symbol;
62+
auto source{structureComponent.component.source};
6663
if (const auto *expr{GetExpr(context_, allocateObject)}) {
67-
if (symbol) {
68-
if (!IsAllocatableOrPointer(*symbol)) { // C932
69-
context_.Say(source,
70-
"Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
71-
} else if (auto whyNot{WhyNotDefinable(source,
72-
context_.FindScope(source),
73-
{DefinabilityFlag::PointerDefinition,
74-
DefinabilityFlag::AcceptAllocatable},
75-
*expr)}) {
76-
context_
77-
.Say(source,
78-
"Name in DEALLOCATE statement is not definable"_err_en_US)
79-
.Attach(std::move(*whyNot));
80-
} else if (auto whyNot{WhyNotDefinable(source,
81-
context_.FindScope(source),
82-
DefinabilityFlags{}, *expr)}) {
83-
context_
84-
.Say(source,
85-
"Object in DEALLOCATE statement is not deallocatable"_err_en_US)
86-
.Attach(std::move(*whyNot));
87-
}
64+
if (const Symbol *
65+
symbol{structureComponent.component.symbol
66+
? &structureComponent.component.symbol
67+
->GetUltimate()
68+
: nullptr};
69+
!IsAllocatableOrObjectPointer(symbol)) { // F'2023 C936
70+
context_.Say(source,
71+
"Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
72+
} else if (auto whyNot{WhyNotDefinable(source,
73+
context_.FindScope(source),
74+
{DefinabilityFlag::PointerDefinition,
75+
DefinabilityFlag::AcceptAllocatable},
76+
*expr)}) {
77+
context_
78+
.Say(source,
79+
"Name in DEALLOCATE statement is not definable"_err_en_US)
80+
.Attach(std::move(*whyNot));
81+
} else if (auto whyNot{WhyNotDefinable(source,
82+
context_.FindScope(source), DefinabilityFlags{},
83+
*expr)}) {
84+
context_
85+
.Say(source,
86+
"Object in DEALLOCATE statement is not deallocatable"_err_en_US)
87+
.Attach(std::move(*whyNot));
8888
}
8989
}
9090
},

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -731,7 +731,7 @@ void CheckHelper::CheckObjectEntity(
731731
"!DIR$ IGNORE_TKR(R) may not apply in an ELEMENTAL procedure"_err_en_US);
732732
}
733733
if (IsPassedViaDescriptor(symbol)) {
734-
if (IsAllocatableOrPointer(symbol)) {
734+
if (IsAllocatableOrObjectPointer(&symbol)) {
735735
if (inExplicitInterface) {
736736
WarnIfNotInModuleFile(
737737
"!DIR$ IGNORE_TKR should not apply to an allocatable or pointer"_warn_en_US);

‎flang/lib/Semantics/check-omp-structure.cpp

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -203,8 +203,8 @@ void OmpStructureChecker::CheckMultListItems() {
203203
"ALIGNED clause"_err_en_US,
204204
name->ToString());
205205
} else if (!(IsBuiltinCPtr(*(name->symbol)) ||
206-
IsAllocatableOrPointer(
207-
(name->symbol->GetUltimate())))) {
206+
IsAllocatableOrObjectPointer(
207+
&name->symbol->GetUltimate()))) {
208208
context_.Say(itr->second->source,
209209
"'%s' in ALIGNED clause must be of type C_PTR, POINTER or "
210210
"ALLOCATABLE"_err_en_US,

‎flang/lib/Semantics/check-select-rank.cpp

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -86,7 +86,7 @@ void SelectRankConstructChecker::Leave(
8686
.Attach(prevLocStar, "Previous use"_en_US);
8787
}
8888
if (saveSelSymbol &&
89-
IsAllocatableOrPointer(*saveSelSymbol)) { // C1155
89+
IsAllocatableOrPointer(*saveSelSymbol)) { // F'2023 C1160
9090
context_.Say(parser::FindSourceLocation(selectRankStmtSel),
9191
"RANK (*) cannot be used when selector is "
9292
"POINTER or ALLOCATABLE"_err_en_US);

‎flang/lib/Semantics/definable.cpp

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -169,7 +169,7 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
169169
const Symbol &ultimate{original.GetUltimate()};
170170
if (flags.test(DefinabilityFlag::PointerDefinition)) {
171171
if (flags.test(DefinabilityFlag::AcceptAllocatable)) {
172-
if (!IsAllocatableOrPointer(ultimate)) {
172+
if (!IsAllocatableOrObjectPointer(&ultimate)) {
173173
return BlameSymbol(
174174
at, "'%s' is neither a pointer nor an allocatable"_en_US, original);
175175
}

‎flang/lib/Semantics/resolve-directives.cpp

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1113,7 +1113,7 @@ void AccAttributeVisitor::EnsureAllocatableOrPointer(
11131113
common::visitors{
11141114
[&](const parser::Designator &designator) {
11151115
const auto &lastName{GetLastName(designator)};
1116-
if (!IsAllocatableOrPointer(*lastName.symbol)) {
1116+
if (!IsAllocatableOrObjectPointer(lastName.symbol)) {
11171117
context_.Say(designator.source,
11181118
"Argument `%s` on the %s clause must be a variable or "
11191119
"array with the POINTER or ALLOCATABLE attribute"_err_en_US,

0 commit comments

Comments
 (0)