[flang-commits] [flang] 031b4e5 - [flang] Support SELECT RANK on allocatables & pointers
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Tue Aug 29 14:56:36 PDT 2023
Author: Peter Klausler
Date: 2023-08-29T14:56:15-07:00
New Revision: 031b4e5e795a72e23c69da3d06ae7a958d217a8e
URL: https://github.com/llvm/llvm-project/commit/031b4e5e795a72e23c69da3d06ae7a958d217a8e
DIFF: https://github.com/llvm/llvm-project/commit/031b4e5e795a72e23c69da3d06ae7a958d217a8e.diff
LOG: [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
Added:
flang/test/Semantics/select-rank03.f90
Modified:
flang/include/flang/Evaluate/tools.h
flang/include/flang/Semantics/symbol.h
flang/include/flang/Semantics/tools.h
flang/lib/Evaluate/intrinsics.cpp
flang/lib/Evaluate/tools.cpp
flang/lib/Lower/Bridge.cpp
flang/lib/Lower/ConvertExprToHLFIR.cpp
flang/lib/Lower/IO.cpp
flang/lib/Lower/Mangler.cpp
flang/lib/Lower/OpenMP.cpp
flang/lib/Semantics/check-allocate.cpp
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/check-deallocate.cpp
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/check-omp-structure.cpp
flang/lib/Semantics/check-select-rank.cpp
flang/lib/Semantics/definable.cpp
flang/lib/Semantics/resolve-directives.cpp
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/tools.cpp
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index 716c4a97269428..0a9e7ce87be38e 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -1189,7 +1189,10 @@ bool IsFunction(const Symbol &);
bool IsFunction(const Scope &);
bool IsProcedure(const Symbol &);
bool IsProcedure(const Scope &);
+bool IsProcedurePointer(const Symbol *);
bool IsProcedurePointer(const Symbol &);
+bool IsObjectPointer(const Symbol *);
+bool IsAllocatableOrObjectPointer(const Symbol *);
bool IsAutomatic(const Symbol &);
bool IsSaved(const Symbol &); // saved implicitly or explicitly
bool IsDummy(const Symbol &);
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index 98ea0adc829324..1ba489fe21a722 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -237,7 +237,8 @@ class EntityDetails : public WithBindName {
llvm::raw_ostream &, const EntityDetails &);
};
-// Symbol is associated with a name or expression in a SELECT TYPE or ASSOCIATE.
+// Symbol is associated with a name or expression in an ASSOCIATE,
+// SELECT TYPE, or SELECT RANK construct.
class AssocEntityDetails : public EntityDetails {
public:
AssocEntityDetails() {}
@@ -252,7 +253,7 @@ class AssocEntityDetails : public EntityDetails {
private:
MaybeExpr expr_;
- std::optional<int> rank_;
+ std::optional<int> rank_; // for SELECT RANK
};
llvm::raw_ostream &operator<<(llvm::raw_ostream &, const AssocEntityDetails &);
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index 27303b8fb38381..02d1a40a03c955 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -143,6 +143,7 @@ inline bool IsPointer(const Symbol &symbol) {
inline bool IsAllocatable(const Symbol &symbol) {
return symbol.attrs().test(Attr::ALLOCATABLE);
}
+// IsAllocatableOrObjectPointer() may be the better choice
inline bool IsAllocatableOrPointer(const Symbol &symbol) {
return IsPointer(symbol) || IsAllocatable(symbol);
}
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 0f3404999962f1..45c54b37dd1d55 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2221,7 +2221,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
if (dummy[*dimArg].optionality == Optionality::required) {
if (const Symbol *whole{
UnwrapWholeSymbolOrComponentDataRef(actualForDummy[*dimArg])}) {
- if (IsOptional(*whole) || IsAllocatableOrPointer(*whole)) {
+ if (IsOptional(*whole) || IsAllocatableOrObjectPointer(whole)) {
if (rank == Rank::scalarIfDim || arrayRank.value_or(-1) == 1) {
messages.Say(
"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);
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 0daf03707515d0..86777ac44745ef 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -1158,7 +1158,8 @@ std::optional<Expr<SomeType>> DataConstantConversionExtension(
bool IsAllocatableOrPointerObject(
const Expr<SomeType> &expr, FoldingContext &context) {
const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)};
- return (sym && semantics::IsAllocatableOrPointer(sym->GetUltimate())) ||
+ return (sym &&
+ semantics::IsAllocatableOrObjectPointer(&sym->GetUltimate())) ||
evaluate::IsObjectPointer(expr, context);
}
@@ -1388,17 +1389,39 @@ bool IsProcedure(const Scope &scope) {
return symbol && IsProcedure(*symbol);
}
+bool IsProcedurePointer(const Symbol &original) {
+ const Symbol &symbol{GetAssociationRoot(original)};
+ return IsPointer(symbol) && IsProcedure(symbol);
+}
+
+bool IsProcedurePointer(const Symbol *symbol) {
+ return symbol && IsProcedurePointer(*symbol);
+}
+
+bool IsObjectPointer(const Symbol *original) {
+ if (original) {
+ const Symbol &symbol{GetAssociationRoot(*original)};
+ return IsPointer(symbol) && !IsProcedure(symbol);
+ } else {
+ return false;
+ }
+}
+
+bool IsAllocatableOrObjectPointer(const Symbol *original) {
+ if (original) {
+ const Symbol &symbol{GetAssociationRoot(*original)};
+ return IsAllocatable(symbol) || (IsPointer(symbol) && !IsProcedure(symbol));
+ } else {
+ return false;
+ }
+}
+
const Symbol *FindCommonBlockContaining(const Symbol &original) {
const Symbol &root{GetAssociationRoot(original)};
const auto *details{root.detailsIf<ObjectEntityDetails>()};
return details ? details->commonBlock() : nullptr;
}
-bool IsProcedurePointer(const Symbol &original) {
- const Symbol &symbol{GetAssociationRoot(original)};
- return IsPointer(symbol) && IsProcedure(symbol);
-}
-
// 3.11 automatic data object
bool IsAutomatic(const Symbol &original) {
const Symbol &symbol{original.GetUltimate()};
@@ -1516,14 +1539,14 @@ bool IsAssumedShape(const Symbol &symbol) {
const Symbol &ultimate{ResolveAssociations(symbol)};
const auto *object{ultimate.detailsIf<ObjectEntityDetails>()};
return object && object->CanBeAssumedShape() &&
- !semantics::IsAllocatableOrPointer(ultimate);
+ !semantics::IsAllocatableOrObjectPointer(&ultimate);
}
bool IsDeferredShape(const Symbol &symbol) {
const Symbol &ultimate{ResolveAssociations(symbol)};
const auto *object{ultimate.detailsIf<ObjectEntityDetails>()};
return object && object->CanBeDeferredShape() &&
- semantics::IsAllocatableOrPointer(ultimate);
+ semantics::IsAllocatableOrObjectPointer(&ultimate);
}
bool IsFunctionResult(const Symbol &original) {
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index bf66d2402eb9b6..68f04875665ea3 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -581,7 +581,7 @@ class FirConverter : public Fortran::lower::AbstractConverter {
llvm::ArrayRef<mlir::Value> typeParams) -> mlir::Value {
mlir::Value allocVal = builder->allocateLocal(
loc,
- Fortran::semantics::IsAllocatableOrPointer(hsym.GetUltimate())
+ Fortran::semantics::IsAllocatableOrObjectPointer(&hsym.GetUltimate())
? hSymType
: symType,
mangleName(sym), toStringRef(sym.GetUltimate().name()),
diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp
index ba2d4b64557150..7305215c39b9a9 100644
--- a/flang/lib/Lower/ConvertExprToHLFIR.cpp
+++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp
@@ -129,7 +129,7 @@ class HlfirDesignatorBuilder {
// shape is deferred and should not be loaded now to preserve
// pointer/allocatable aspects.
if (componentSym.Rank() == 0 ||
- Fortran::semantics::IsAllocatableOrPointer(componentSym))
+ Fortran::semantics::IsAllocatableOrObjectPointer(&componentSym))
return mlir::Value{};
fir::FirOpBuilder &builder = getBuilder();
@@ -488,8 +488,8 @@ class HlfirDesignatorBuilder {
// array ref designates the target (this is done in "visit"). Other
// components need special care to deal with the array%array_comp(indices)
// case.
- if (Fortran::semantics::IsAllocatableOrPointer(
- component->GetLastSymbol()))
+ if (Fortran::semantics::IsAllocatableOrObjectPointer(
+ &component->GetLastSymbol()))
baseType = visit(*component, partInfo);
else
baseType = hlfir::getFortranElementOrSequenceType(
@@ -734,7 +734,7 @@ class HlfirDesignatorBuilder {
if (charTy.hasConstantLen())
partInfo.typeParams.push_back(
builder.createIntegerConstant(loc, idxTy, charTy.getLen()));
- else if (!Fortran::semantics::IsAllocatableOrPointer(componentSym))
+ else if (!Fortran::semantics::IsAllocatableOrObjectPointer(&componentSym))
TODO(loc, "compute character length of automatic character component "
"in a PDT");
// Otherwise, the length of the component is deferred and will only
diff --git a/flang/lib/Lower/IO.cpp b/flang/lib/Lower/IO.cpp
index a35b7a991b8578..ac1fe7f68a9a66 100644
--- a/flang/lib/Lower/IO.cpp
+++ b/flang/lib/Lower/IO.cpp
@@ -498,7 +498,7 @@ getNamelistGroup(Fortran::lower::AbstractConverter &converter,
// A global pointer or allocatable variable has a descriptor for typical
// accesses. Variables in multiple namelist groups may already have one.
// Create descriptors for other cases.
- if (!IsAllocatableOrPointer(s)) {
+ if (!IsAllocatableOrObjectPointer(&s)) {
std::string mangleName =
Fortran::lower::mangle::globalNamelistDescriptorName(s);
if (builder.getNamedGlobal(mangleName))
diff --git a/flang/lib/Lower/Mangler.cpp b/flang/lib/Lower/Mangler.cpp
index dc0e0a09e6d0e7..4ea6238eded002 100644
--- a/flang/lib/Lower/Mangler.cpp
+++ b/flang/lib/Lower/Mangler.cpp
@@ -277,5 +277,5 @@ std::string Fortran::lower::mangle::mangleArrayLiteral(
std::string Fortran::lower::mangle::globalNamelistDescriptorName(
const Fortran::semantics::Symbol &sym) {
std::string name = mangleName(sym);
- return IsAllocatableOrPointer(sym) ? name : name + ".desc"s;
+ return IsAllocatableOrObjectPointer(&sym) ? name : name + ".desc"s;
}
diff --git a/flang/lib/Lower/OpenMP.cpp b/flang/lib/Lower/OpenMP.cpp
index 273dc688d8a4bb..6decb0276636f0 100644
--- a/flang/lib/Lower/OpenMP.cpp
+++ b/flang/lib/Lower/OpenMP.cpp
@@ -1553,7 +1553,8 @@ bool ClauseProcessor::processCopyin() const {
checkAndCopyHostAssociateVar(&*mem, &insPt);
break;
}
- if (Fortran::semantics::IsAllocatableOrPointer(sym->GetUltimate()))
+ if (Fortran::semantics::IsAllocatableOrObjectPointer(
+ &sym->GetUltimate()))
TODO(converter.getCurrentLocation(),
"pointer or allocatable variables in Copyin clause");
assert(sym->has<Fortran::semantics::HostAssocDetails>() &&
@@ -1815,7 +1816,7 @@ static fir::GlobalOp globalInitialization(
firOpBuilder.createGlobal(currentLocation, ty, globalName, linkage);
// Create default initialization for non-character scalar.
- if (Fortran::semantics::IsAllocatableOrPointer(sym)) {
+ if (Fortran::semantics::IsAllocatableOrObjectPointer(&sym)) {
mlir::Type baseAddrType = ty.dyn_cast<fir::BoxType>().getEleTy();
Fortran::lower::createGlobalInitialization(
firOpBuilder, global, [&](fir::FirOpBuilder &b) {
diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp
index d4039b3177c594..12d795290d927a 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -39,14 +39,14 @@ class AllocationCheckerHelper {
public:
AllocationCheckerHelper(
const parser::Allocation &alloc, AllocateCheckerInfo &info)
- : allocateInfo_{info}, allocateObject_{std::get<parser::AllocateObject>(
- alloc.t)},
+ : allocateInfo_{info},
+ allocateObject_{std::get<parser::AllocateObject>(alloc.t)},
name_{parser::GetLastName(allocateObject_)},
- symbol_{name_.symbol ? &name_.symbol->GetUltimate() : nullptr},
+ original_{name_.symbol ? &name_.symbol->GetUltimate() : nullptr},
+ symbol_{original_ ? &ResolveAssociations(*original_) : nullptr},
type_{symbol_ ? symbol_->GetType() : nullptr},
- allocateShapeSpecRank_{ShapeSpecRank(alloc)}, rank_{symbol_
- ? symbol_->Rank()
- : 0},
+ allocateShapeSpecRank_{ShapeSpecRank(alloc)},
+ rank_{original_ ? original_->Rank() : 0},
allocateCoarraySpecRank_{CoarraySpecRank(alloc)},
corank_{symbol_ ? symbol_->Corank() : 0} {}
@@ -91,7 +91,8 @@ class AllocationCheckerHelper {
AllocateCheckerInfo &allocateInfo_;
const parser::AllocateObject &allocateObject_;
const parser::Name &name_;
- const Symbol *symbol_{nullptr};
+ const Symbol *original_{nullptr}; // no USE or host association
+ const Symbol *symbol_{nullptr}; // no USE, host, or construct association
const DeclTypeSpec *type_{nullptr};
const int allocateShapeSpecRank_;
const int rank_{0};
@@ -558,17 +559,17 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
}
}
} else {
- // first part of C942
+ // explicit shape-spec-list
if (allocateShapeSpecRank_ != rank_) {
context
.Say(name_.source,
"The number of shape specifications, when they appear, must match the rank of allocatable object"_err_en_US)
- .Attach(symbol_->name(), "Declared here with rank %d"_en_US, rank_);
+ .Attach(
+ original_->name(), "Declared here with rank %d"_en_US, rank_);
return false;
}
}
- } else {
- // C940
+ } else { // allocating a scalar object
if (hasAllocateShapeSpecList()) {
context.Say(name_.source,
"Shape specifications must not appear when allocatable object is scalar"_err_en_US);
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 0469a72bcc7316..c48c382218dc9b 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -1430,7 +1430,7 @@ static void CheckTransfer(evaluate::ActualArguments &arguments,
whole->name());
} else if (context.ShouldWarn(
common::UsageWarning::TransferSizePresence) &&
- IsAllocatableOrPointer(*whole)) {
+ IsAllocatableOrObjectPointer(whole)) {
messages.Say(
"SIZE= argument that is allocatable or pointer must be present at execution; parenthesize to silence this warning"_warn_en_US);
}
diff --git a/flang/lib/Semantics/check-deallocate.cpp b/flang/lib/Semantics/check-deallocate.cpp
index e3aad077ed0db0..798c5802656097 100644
--- a/flang/lib/Semantics/check-deallocate.cpp
+++ b/flang/lib/Semantics/check-deallocate.cpp
@@ -19,20 +19,18 @@ namespace Fortran::semantics {
void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
for (const parser::AllocateObject &allocateObject :
std::get<std::list<parser::AllocateObject>>(deallocateStmt.t)) {
- parser::CharBlock source;
- const Symbol *symbol{nullptr};
common::visit(
common::visitors{
[&](const parser::Name &name) {
- source = name.source;
- symbol = name.symbol;
+ const Symbol *symbol{
+ name.symbol ? &name.symbol->GetUltimate() : nullptr};
+ ;
if (context_.HasError(symbol)) {
// already reported an error
} else if (!IsVariableName(*symbol)) {
context_.Say(name.source,
"Name in DEALLOCATE statement must be a variable name"_err_en_US);
- } else if (!IsAllocatableOrPointer(
- symbol->GetUltimate())) { // C932
+ } else if (!IsAllocatableOrObjectPointer(symbol)) { // C936
context_.Say(name.source,
"Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
} else if (auto whyNot{WhyNotDefinable(name.source,
@@ -61,30 +59,32 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
[&](const parser::StructureComponent &structureComponent) {
// Only perform structureComponent checks if it was successfully
// analyzed by expression analysis.
- source = structureComponent.component.source;
- symbol = structureComponent.component.symbol;
+ auto source{structureComponent.component.source};
if (const auto *expr{GetExpr(context_, allocateObject)}) {
- if (symbol) {
- if (!IsAllocatableOrPointer(*symbol)) { // C932
- context_.Say(source,
- "Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
- } else if (auto whyNot{WhyNotDefinable(source,
- context_.FindScope(source),
- {DefinabilityFlag::PointerDefinition,
- DefinabilityFlag::AcceptAllocatable},
- *expr)}) {
- context_
- .Say(source,
- "Name in DEALLOCATE statement is not definable"_err_en_US)
- .Attach(std::move(*whyNot));
- } else if (auto whyNot{WhyNotDefinable(source,
- context_.FindScope(source),
- DefinabilityFlags{}, *expr)}) {
- context_
- .Say(source,
- "Object in DEALLOCATE statement is not deallocatable"_err_en_US)
- .Attach(std::move(*whyNot));
- }
+ if (const Symbol *
+ symbol{structureComponent.component.symbol
+ ? &structureComponent.component.symbol
+ ->GetUltimate()
+ : nullptr};
+ !IsAllocatableOrObjectPointer(symbol)) { // F'2023 C936
+ context_.Say(source,
+ "Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
+ } else if (auto whyNot{WhyNotDefinable(source,
+ context_.FindScope(source),
+ {DefinabilityFlag::PointerDefinition,
+ DefinabilityFlag::AcceptAllocatable},
+ *expr)}) {
+ context_
+ .Say(source,
+ "Name in DEALLOCATE statement is not definable"_err_en_US)
+ .Attach(std::move(*whyNot));
+ } else if (auto whyNot{WhyNotDefinable(source,
+ context_.FindScope(source), DefinabilityFlags{},
+ *expr)}) {
+ context_
+ .Say(source,
+ "Object in DEALLOCATE statement is not deallocatable"_err_en_US)
+ .Attach(std::move(*whyNot));
}
}
},
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 6ff9b2250f9225..62efd8b49d385d 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -731,7 +731,7 @@ void CheckHelper::CheckObjectEntity(
"!DIR$ IGNORE_TKR(R) may not apply in an ELEMENTAL procedure"_err_en_US);
}
if (IsPassedViaDescriptor(symbol)) {
- if (IsAllocatableOrPointer(symbol)) {
+ if (IsAllocatableOrObjectPointer(&symbol)) {
if (inExplicitInterface) {
WarnIfNotInModuleFile(
"!DIR$ IGNORE_TKR should not apply to an allocatable or pointer"_warn_en_US);
diff --git a/flang/lib/Semantics/check-omp-structure.cpp b/flang/lib/Semantics/check-omp-structure.cpp
index 5523dc939696a0..ffd577aa203756 100644
--- a/flang/lib/Semantics/check-omp-structure.cpp
+++ b/flang/lib/Semantics/check-omp-structure.cpp
@@ -203,8 +203,8 @@ void OmpStructureChecker::CheckMultListItems() {
"ALIGNED clause"_err_en_US,
name->ToString());
} else if (!(IsBuiltinCPtr(*(name->symbol)) ||
- IsAllocatableOrPointer(
- (name->symbol->GetUltimate())))) {
+ IsAllocatableOrObjectPointer(
+ &name->symbol->GetUltimate()))) {
context_.Say(itr->second->source,
"'%s' in ALIGNED clause must be of type C_PTR, POINTER or "
"ALLOCATABLE"_err_en_US,
diff --git a/flang/lib/Semantics/check-select-rank.cpp b/flang/lib/Semantics/check-select-rank.cpp
index ab8a1f3fb7788e..424f9b45d64cdf 100644
--- a/flang/lib/Semantics/check-select-rank.cpp
+++ b/flang/lib/Semantics/check-select-rank.cpp
@@ -86,7 +86,7 @@ void SelectRankConstructChecker::Leave(
.Attach(prevLocStar, "Previous use"_en_US);
}
if (saveSelSymbol &&
- IsAllocatableOrPointer(*saveSelSymbol)) { // C1155
+ IsAllocatableOrPointer(*saveSelSymbol)) { // F'2023 C1160
context_.Say(parser::FindSourceLocation(selectRankStmtSel),
"RANK (*) cannot be used when selector is "
"POINTER or ALLOCATABLE"_err_en_US);
diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp
index c3826e7f29d7e0..7e33357734fa72 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -169,7 +169,7 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
const Symbol &ultimate{original.GetUltimate()};
if (flags.test(DefinabilityFlag::PointerDefinition)) {
if (flags.test(DefinabilityFlag::AcceptAllocatable)) {
- if (!IsAllocatableOrPointer(ultimate)) {
+ if (!IsAllocatableOrObjectPointer(&ultimate)) {
return BlameSymbol(
at, "'%s' is neither a pointer nor an allocatable"_en_US, original);
}
diff --git a/flang/lib/Semantics/resolve-directives.cpp b/flang/lib/Semantics/resolve-directives.cpp
index c60c693072f499..84f00ef82755ef 100644
--- a/flang/lib/Semantics/resolve-directives.cpp
+++ b/flang/lib/Semantics/resolve-directives.cpp
@@ -1113,7 +1113,7 @@ void AccAttributeVisitor::EnsureAllocatableOrPointer(
common::visitors{
[&](const parser::Designator &designator) {
const auto &lastName{GetLastName(designator)};
- if (!IsAllocatableOrPointer(*lastName.symbol)) {
+ if (!IsAllocatableOrObjectPointer(lastName.symbol)) {
context_.Say(designator.source,
"Argument `%s` on the %s clause must be a variable or "
"array with the POINTER or ALLOCATABLE attribute"_err_en_US,
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index c401e9214524b4..2a0f4ab9f41712 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -6942,7 +6942,11 @@ void ConstructVisitor::Post(const parser::TypeGuardStmt::Guard &x) {
void ConstructVisitor::Post(const parser::SelectRankCaseStmt::Rank &x) {
if (auto *symbol{MakeAssocEntity()}) {
SetTypeFromAssociation(*symbol);
- SetAttrsFromAssociation(*symbol);
+ // Don't call SetAttrsFromAssociation() for SELECT RANK.
+ symbol->attrs() |=
+ evaluate::GetAttrs(GetCurrentAssociation().selector.expr) &
+ Attrs{Attr::ALLOCATABLE, Attr::ASYNCHRONOUS, Attr::POINTER,
+ Attr::TARGET, Attr::VOLATILE};
if (const auto *init{std::get_if<parser::ScalarIntConstantExpr>(&x.u)}) {
if (auto val{EvaluateInt64(context(), *init)}) {
auto &details{symbol->get<AssocEntityDetails>()};
@@ -7039,6 +7043,7 @@ void ConstructVisitor::SetTypeFromAssociation(Symbol &symbol) {
}
// If current selector is a variable, set some of its attributes on symbol.
+// For ASSOCIATE, CHANGE TEAM, and SELECT TYPE only; not SELECT RANK.
void ConstructVisitor::SetAttrsFromAssociation(Symbol &symbol) {
Attrs attrs{evaluate::GetAttrs(GetCurrentAssociation().selector.expr)};
symbol.attrs() |=
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 075b7f94c4cfa8..7c523971e8e247 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -1208,13 +1208,13 @@ ComponentIterator<componentKind>::const_iterator::PlanComponentTraversal(
// Order Component (only visit parents)
traverse = component.test(Symbol::Flag::ParentComp);
} else if constexpr (componentKind == ComponentKind::Direct) {
- traverse = !IsAllocatableOrPointer(component);
+ traverse = !IsAllocatableOrObjectPointer(&component);
} else if constexpr (componentKind == ComponentKind::Ultimate) {
- traverse = !IsAllocatableOrPointer(component);
+ traverse = !IsAllocatableOrObjectPointer(&component);
} else if constexpr (componentKind == ComponentKind::Potential) {
traverse = !IsPointer(component);
} else if constexpr (componentKind == ComponentKind::Scope) {
- traverse = !IsAllocatableOrPointer(component);
+ traverse = !IsAllocatableOrObjectPointer(&component);
} else if constexpr (componentKind ==
ComponentKind::PotentialAndPointer) {
traverse = !IsPointer(component);
@@ -1248,7 +1248,7 @@ static bool StopAtComponentPre(const Symbol &component) {
return true;
} else if constexpr (componentKind == ComponentKind::Ultimate) {
return component.has<ProcEntityDetails>() ||
- IsAllocatableOrPointer(component) ||
+ IsAllocatableOrObjectPointer(&component) ||
(component.get<ObjectEntityDetails>().type() &&
component.get<ObjectEntityDetails>().type()->AsIntrinsic());
} else if constexpr (componentKind == ComponentKind::Potential) {
diff --git a/flang/test/Semantics/select-rank03.f90 b/flang/test/Semantics/select-rank03.f90
new file mode 100644
index 00000000000000..038380435d00d7
--- /dev/null
+++ b/flang/test/Semantics/select-rank03.f90
@@ -0,0 +1,115 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+program test
+ real, allocatable :: a0, a1(:)
+ real, pointer :: p0, p1(:)
+ real, target :: t0, t1(1)
+ contains
+ subroutine allocatables(a)
+ real, allocatable :: a(..)
+ !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE
+ select rank(a)
+ rank (0)
+ allocate(a) ! ok
+ deallocate(a) ! ok
+ allocate(a, source=a0) ! ok
+ allocate(a, mold=p0) ! ok
+ a = 1. ! ok
+ !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches scalar REAL(4) and rank 1 array of REAL(4)
+ a = [1.]
+ !ERROR: If SOURCE appears, the related expression must be scalar or have the same rank as each allocatable object in ALLOCATE
+ allocate(a, source=a1)
+ allocate(a, mold=p1) ! ok, mold= ignored
+ rank (1)
+ allocate(a(1)) ! ok
+ deallocate(a) ! ok
+ a = 1. ! ok
+ a = [1.] ! ok
+ !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ allocate(a, source=a0)
+ !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ allocate(a, mold=p0)
+ allocate(a, source=a1) ! ok
+ allocate(a, mold=p1) ! ok
+ rank (2)
+ allocate(a(1,1)) ! ok
+ deallocate(a) ! ok
+ a = 1. ! ok
+ !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches rank 2 array of REAL(4) and rank 1 array of REAL(4)
+ a = [1.]
+ !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ allocate(a, source=a0)
+ !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ allocate(a, mold=p0)
+ !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ allocate(a, source=a1)
+ !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ allocate(a, mold=p1)
+ rank (*)
+ !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ allocate(a)
+ deallocate(a)
+ a = 1.
+ rank default
+ !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ allocate(a)
+ deallocate(a)
+ a = 1.
+ end select
+ end
+ subroutine pointers(p)
+ real, pointer :: p(..)
+ !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE
+ select rank(p)
+ rank (0)
+ allocate(p) ! ok
+ deallocate(p) ! ok
+ allocate(p, source=a0) ! ok
+ allocate(p, mold=p0) ! ok
+ !ERROR: If SOURCE appears, the related expression must be scalar or have the same rank as each allocatable object in ALLOCATE
+ allocate(p, source=a1)
+ allocate(p, mold=p1) ! ok, mold ignored
+ p => t0 ! ok
+ !ERROR: Pointer has rank 0 but target has rank 1
+ p => t1
+ rank (1)
+ allocate(p(1)) ! ok
+ deallocate(p) ! ok
+ !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ allocate(p, source=a0)
+ !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ allocate(p, mold=p0)
+ allocate(p, source=a1) ! ok
+ allocate(p, mold=p1) ! ok
+ !ERROR: Pointer has rank 1 but target has rank 0
+ p => t0
+ p => t1 ! ok
+ rank (2)
+ allocate(p(1,1)) ! ok
+ deallocate(p) ! ok
+ !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ allocate(p, source=a0)
+ !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ allocate(p, mold=p0)
+ !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ allocate(p, source=a1)
+ !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ allocate(p, mold=p1)
+ !ERROR: Pointer has rank 2 but target has rank 0
+ p => t0
+ !ERROR: Pointer has rank 2 but target has rank 1
+ p => t1
+ rank (*)
+ !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ allocate(p)
+ deallocate(p)
+ rank default
+ !ERROR: Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD
+ allocate(p)
+ deallocate(p)
+ !ERROR: pointer 'p' associated with object 't0' with incompatible type or shape
+ p => t0
+ !ERROR: pointer 'p' associated with object 't1' with incompatible type or shape
+ p => t1
+ end select
+ end
+end
More information about the flang-commits
mailing list