[flang-commits] [flang] [flang] Add parsing of DO CONCURRENT REDUCE clause (PR #92518)
via flang-commits
flang-commits at lists.llvm.org
Fri May 17 03:44:42 PDT 2024
https://github.com/khaki3 created https://github.com/llvm/llvm-project/pull/92518
Derived from #92480. This PR supports parsing of the DO CONCURRENT REDUCE clause in Fortran 2023. Following the style of the OpenMP parser in MLIR, the front end accepts both arbitrary operations and procedures for the REDUCE clause. But later Semantics can notify type errors and resolve procedure names.
>From 6116f8ac841eec714903379615f21b656655c293 Mon Sep 17 00:00:00 2001
From: Kazuaki Matsumura <kmatsumura at nvidia.com>
Date: Fri, 17 May 2024 03:41:29 -0700
Subject: [PATCH] [flang] Add parsing of DO CONCURRENT REDUCE clause
---
flang/examples/FeatureList/FeatureList.cpp | 2 +
flang/include/flang/Parser/dump-parse-tree.h | 2 +
flang/include/flang/Parser/parse-tree.h | 29 ++++--
flang/include/flang/Semantics/symbol.h | 1 +
flang/lib/Parser/executable-parsers.cpp | 10 ++
flang/lib/Parser/unparse.cpp | 4 +
flang/lib/Semantics/check-do-forall.cpp | 89 ++++++++++++++++
flang/lib/Semantics/resolve-names.cpp | 103 +++++++++++++------
flang/test/Semantics/resolve123.f90 | 79 ++++++++++++++
flang/test/Semantics/resolve124.f90 | 89 ++++++++++++++++
flang/test/Semantics/resolve55.f90 | 19 ++--
11 files changed, 382 insertions(+), 45 deletions(-)
create mode 100644 flang/test/Semantics/resolve123.f90
create mode 100644 flang/test/Semantics/resolve124.f90
diff --git a/flang/examples/FeatureList/FeatureList.cpp b/flang/examples/FeatureList/FeatureList.cpp
index 3ca92da4f6467..28689b5d3c4b0 100644
--- a/flang/examples/FeatureList/FeatureList.cpp
+++ b/flang/examples/FeatureList/FeatureList.cpp
@@ -410,10 +410,12 @@ struct NodeVisitor {
READ_FEATURE(LetterSpec)
READ_FEATURE(LiteralConstant)
READ_FEATURE(IntLiteralConstant)
+ READ_FEATURE(ReduceOperation)
READ_FEATURE(LocalitySpec)
READ_FEATURE(LocalitySpec::DefaultNone)
READ_FEATURE(LocalitySpec::Local)
READ_FEATURE(LocalitySpec::LocalInit)
+ READ_FEATURE(LocalitySpec::Reduce)
READ_FEATURE(LocalitySpec::Shared)
READ_FEATURE(LockStmt)
READ_FEATURE(LockStmt::LockStat)
diff --git a/flang/include/flang/Parser/dump-parse-tree.h b/flang/include/flang/Parser/dump-parse-tree.h
index 68ae50c312cde..15948bb073664 100644
--- a/flang/include/flang/Parser/dump-parse-tree.h
+++ b/flang/include/flang/Parser/dump-parse-tree.h
@@ -436,10 +436,12 @@ class ParseTreeDumper {
NODE(parser, LetterSpec)
NODE(parser, LiteralConstant)
NODE(parser, IntLiteralConstant)
+ NODE(parser, ReduceOperation)
NODE(parser, LocalitySpec)
NODE(LocalitySpec, DefaultNone)
NODE(LocalitySpec, Local)
NODE(LocalitySpec, LocalInit)
+ NODE(LocalitySpec, Reduce)
NODE(LocalitySpec, Shared)
NODE(parser, LockStmt)
NODE(LockStmt, LockStat)
diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h
index 0a40aa8b8f616..68a4319a85047 100644
--- a/flang/include/flang/Parser/parse-tree.h
+++ b/flang/include/flang/Parser/parse-tree.h
@@ -1870,6 +1870,13 @@ struct ProcComponentRef {
WRAPPER_CLASS_BOILERPLATE(ProcComponentRef, Scalar<StructureComponent>);
};
+// R1522 procedure-designator ->
+// procedure-name | proc-component-ref | data-ref % binding-name
+struct ProcedureDesignator {
+ UNION_CLASS_BOILERPLATE(ProcedureDesignator);
+ std::variant<Name, ProcComponentRef> u;
+};
+
// R914 coindexed-named-object -> data-ref
struct CoindexedNamedObject {
BOILERPLATE(CoindexedNamedObject);
@@ -2236,16 +2243,29 @@ struct ConcurrentHeader {
t;
};
+// F'2023 R1131 reduce-operation ->
+// + | * | .AND. | .OR. | .EQV. | .NEQV. |
+// MAX | MIN | IAND | IOR | IEOR
+struct ReduceOperation {
+ UNION_CLASS_BOILERPLATE(ReduceOperation);
+ std::variant<DefinedOperator, ProcedureDesignator> u;
+};
+
// R1130 locality-spec ->
// LOCAL ( variable-name-list ) | LOCAL_INIT ( variable-name-list ) |
+// REDUCE ( reduce-operation : variable-name-list ) |
// SHARED ( variable-name-list ) | DEFAULT ( NONE )
struct LocalitySpec {
UNION_CLASS_BOILERPLATE(LocalitySpec);
WRAPPER_CLASS(Local, std::list<Name>);
WRAPPER_CLASS(LocalInit, std::list<Name>);
+ struct Reduce {
+ TUPLE_CLASS_BOILERPLATE(Reduce);
+ std::tuple<ReduceOperation, std::list<Name>> t;
+ };
WRAPPER_CLASS(Shared, std::list<Name>);
EMPTY_CLASS(DefaultNone);
- std::variant<Local, LocalInit, Shared, DefaultNone> u;
+ std::variant<Local, LocalInit, Reduce, Shared, DefaultNone> u;
};
// R1123 loop-control ->
@@ -3180,13 +3200,6 @@ WRAPPER_CLASS(ExternalStmt, std::list<Name>);
// R1519 intrinsic-stmt -> INTRINSIC [::] intrinsic-procedure-name-list
WRAPPER_CLASS(IntrinsicStmt, std::list<Name>);
-// R1522 procedure-designator ->
-// procedure-name | proc-component-ref | data-ref % binding-name
-struct ProcedureDesignator {
- UNION_CLASS_BOILERPLATE(ProcedureDesignator);
- std::variant<Name, ProcComponentRef> u;
-};
-
// R1525 alt-return-spec -> * label
WRAPPER_CLASS(AltReturnSpec, Label);
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index 50f7b68d80cb1..8ccf93c803845 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -714,6 +714,7 @@ class Symbol {
CrayPointer, CrayPointee,
LocalityLocal, // named in LOCAL locality-spec
LocalityLocalInit, // named in LOCAL_INIT locality-spec
+ LocalityReduce, // named in REDUCE locality-spec
LocalityShared, // named in SHARED locality-spec
InDataStmt, // initialized in a DATA statement, =>object, or /init/
InNamelist, // in a Namelist group
diff --git a/flang/lib/Parser/executable-parsers.cpp b/flang/lib/Parser/executable-parsers.cpp
index 382a593416872..6bacdb34f8c70 100644
--- a/flang/lib/Parser/executable-parsers.cpp
+++ b/flang/lib/Parser/executable-parsers.cpp
@@ -252,13 +252,23 @@ TYPE_PARSER(parenthesized(construct<ConcurrentHeader>(
TYPE_PARSER(construct<ConcurrentControl>(name / "=", scalarIntExpr / ":",
scalarIntExpr, maybe(":" >> scalarIntExpr)))
+// F'2023 R1131 reduce-operation ->
+// + | * | .AND. | .OR. | .EQV. | .NEQV. |
+// MAX | MIN | IAND | IOR | IEOR
+TYPE_PARSER(construct<ReduceOperation>(Parser<DefinedOperator>{}) ||
+ construct<ReduceOperation>(Parser<ProcedureDesignator>{}))
+
// R1130 locality-spec ->
// LOCAL ( variable-name-list ) | LOCAL_INIT ( variable-name-list ) |
+// REDUCE ( reduce-operation : variable-name-list ) |
// SHARED ( variable-name-list ) | DEFAULT ( NONE )
TYPE_PARSER(construct<LocalitySpec>(construct<LocalitySpec::Local>(
"LOCAL" >> parenthesized(listOfNames))) ||
construct<LocalitySpec>(construct<LocalitySpec::LocalInit>(
"LOCAL_INIT"_sptok >> parenthesized(listOfNames))) ||
+ construct<LocalitySpec>(construct<LocalitySpec::Reduce>(
+ "REDUCE"_sptok >> "("_tok >> Parser<ReduceOperation>{} / ":",
+ listOfNames / ")")) ||
construct<LocalitySpec>(construct<LocalitySpec::Shared>(
"SHARED" >> parenthesized(listOfNames))) ||
construct<LocalitySpec>(
diff --git a/flang/lib/Parser/unparse.cpp b/flang/lib/Parser/unparse.cpp
index 1639e900903fe..969b9c3a3802b 100644
--- a/flang/lib/Parser/unparse.cpp
+++ b/flang/lib/Parser/unparse.cpp
@@ -1038,6 +1038,10 @@ class UnparseVisitor {
void Unparse(const LocalitySpec::LocalInit &x) {
Word("LOCAL_INIT("), Walk(x.v, ", "), Put(')');
}
+ void Unparse(const LocalitySpec::Reduce &x) {
+ Word("REDUCE("), Walk(std::get<parser::ReduceOperation>(x.t)), Put(':');
+ Walk(std::get<std::list<parser::Name>>(x.t), ", "), Put(')');
+ }
void Unparse(const LocalitySpec::Shared &x) {
Word("SHARED("), Walk(x.v, ", "), Put(')');
}
diff --git a/flang/lib/Semantics/check-do-forall.cpp b/flang/lib/Semantics/check-do-forall.cpp
index c1eab090a4bb1..450a6ccda172b 100644
--- a/flang/lib/Semantics/check-do-forall.cpp
+++ b/flang/lib/Semantics/check-do-forall.cpp
@@ -683,6 +683,89 @@ class DoContext {
}
}
+ void CheckReduce(
+ const parser::LocalitySpec::Reduce &reduce) const {
+ const parser::ReduceOperation &reduceOperation =
+ std::get<parser::ReduceOperation>(reduce.t);
+ // F'2023 C1132, reduction variables should have suitable intrinsic type
+ bool supported_identifier = true;
+ common::visit(
+ common::visitors{
+ [&](const parser::DefinedOperator &dOpr) {
+ const auto &intrinsicOp{
+ std::get<parser::DefinedOperator::IntrinsicOperator>(dOpr.u)
+ };
+ for (const Fortran::parser::Name &x :
+ std::get<std::list<Fortran::parser::Name>>(reduce.t)) {
+ const auto *type{x.symbol->GetType()};
+ bool suitable_type = false;
+ switch (intrinsicOp) {
+ case parser::DefinedOperator::IntrinsicOperator::Add:
+ case parser::DefinedOperator::IntrinsicOperator::Multiply:
+ if (type->IsNumeric(TypeCategory::Integer) ||
+ type->IsNumeric(TypeCategory::Real) ||
+ type->IsNumeric(TypeCategory::Complex)) {
+ // TODO: check composite type.
+ suitable_type = true;
+ }
+ break;
+ case parser::DefinedOperator::IntrinsicOperator::AND:
+ case parser::DefinedOperator::IntrinsicOperator::OR:
+ case parser::DefinedOperator::IntrinsicOperator::EQV:
+ case parser::DefinedOperator::IntrinsicOperator::NEQV:
+ if (type->category() == DeclTypeSpec::Category::Logical) {
+ suitable_type = true;
+ }
+ break;
+ default:
+ supported_identifier = false;
+ return;
+ }
+ if (!suitable_type) {
+ context_.Say(currentStatementSourcePosition_,
+ "Reduction variable '%s' does not have a "
+ "suitable type."_err_en_US, x.symbol->name());
+ }
+ }
+ },
+ [&](const parser::ProcedureDesignator &procD) {
+ const parser::Name *name{std::get_if<parser::Name>(&procD.u)};
+ if (!(name && name->symbol)) {
+ supported_identifier = false;
+ return;
+ }
+ const SourceName &realName{name->symbol->GetUltimate().name()};
+ for (const Fortran::parser::Name &x : std::get<std::list<
+ Fortran::parser::Name>>(reduce.t)) {
+ const auto *type{x.symbol->GetType()};
+ bool suitable_type = false;
+ if (realName == "max" || realName == "min") {
+ if (type->IsNumeric(TypeCategory::Integer) ||
+ type->IsNumeric(TypeCategory::Real))
+ suitable_type = true;
+ } else if (realName == "iand" || realName == "ior" ||
+ realName == "ieor") {
+ if (type->IsNumeric(TypeCategory::Integer))
+ suitable_type = true;
+ } else {
+ supported_identifier = false;
+ return;
+ }
+ if (!suitable_type) {
+ context_.Say(currentStatementSourcePosition_,
+ "Reduction variable '%s' does not have a "
+ "suitable type."_err_en_US, x.symbol->name());
+ }
+ }
+ }
+ },
+ reduceOperation.u);
+ if (!supported_identifier) {
+ context_.Say(currentStatementSourcePosition_,
+ "Invalid reduction identifier in REDUCE clause."_err_en_US);
+ }
+ }
+
// C1123, concurrent limit or step expressions can't reference index-names
void CheckConcurrentHeader(const parser::ConcurrentHeader &header) const {
if (const auto &mask{
@@ -737,6 +820,12 @@ class DoContext {
std::get<std::optional<parser::ScalarLogicalExpr>>(header.t)}) {
CheckMaskDoesNotReferenceLocal(*mask, localVars);
}
+ for (auto &ls : localitySpecs) {
+ if (const auto *reduce{
+ std::get_if<parser::LocalitySpec::Reduce>(&ls.u)}) {
+ CheckReduce(*reduce);
+ }
+ }
CheckDefaultNoneImpliesExplicitLocality(localitySpecs, block);
}
}
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 40eee89de131a..61f0811982feb 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -537,7 +537,9 @@ class ScopeHandler : public ImplicitRulesVisitor {
void SayAlreadyDeclared(const SourceName &, const SourceName &);
void SayWithReason(
const parser::Name &, Symbol &, MessageFixedText &&, Message &&);
- void SayWithDecl(const parser::Name &, Symbol &, MessageFixedText &&);
+ template <typename... A>
+ void SayWithDecl(const parser::Name &, Symbol &, MessageFixedText &&,
+ A &&...args);
void SayLocalMustBeVariable(const parser::Name &, Symbol &);
void SayDerivedType(const SourceName &, MessageFixedText &&, const Scope &);
void Say2(const SourceName &, MessageFixedText &&, const SourceName &,
@@ -1041,10 +1043,10 @@ class DeclarationVisitor : public ArraySpecVisitor,
Symbol &DeclareObjectEntity(const parser::Name &, Attrs = Attrs{});
// Make sure that there's an entity in an enclosing scope called Name
Symbol &FindOrDeclareEnclosingEntity(const parser::Name &);
- // Declare a LOCAL/LOCAL_INIT entity. If there isn't a type specified
+ // Declare a LOCAL/LOCAL_INIT/REDUCE entity. If there isn't a type specified
// it comes from the entity in the containing scope, or implicit rules.
// Return pointer to the new symbol, or nullptr on error.
- Symbol *DeclareLocalEntity(const parser::Name &);
+ Symbol *DeclareLocalEntity(const parser::Name &, Symbol::Flag);
// Declare a statement entity (i.e., an implied DO loop index for
// a DATA statement or an array constructor). If there isn't an explict
// type specified, implicit rules apply. Return pointer to the new symbol,
@@ -1145,7 +1147,8 @@ class DeclarationVisitor : public ArraySpecVisitor,
const parser::Name *FindComponent(const parser::Name *, const parser::Name &);
void Initialization(const parser::Name &, const parser::Initialization &,
bool inComponentDecl);
- bool PassesLocalityChecks(const parser::Name &name, Symbol &symbol);
+ bool PassesLocalityChecks(const parser::Name &name, Symbol &symbol,
+ Symbol::Flag flag);
bool CheckForHostAssociatedImplicit(const parser::Name &);
// Declare an object or procedure entity.
@@ -1214,6 +1217,7 @@ class ConstructVisitor : public virtual DeclarationVisitor {
bool Pre(const parser::ConcurrentHeader &);
bool Pre(const parser::LocalitySpec::Local &);
bool Pre(const parser::LocalitySpec::LocalInit &);
+ bool Pre(const parser::LocalitySpec::Reduce &);
bool Pre(const parser::LocalitySpec::Shared &);
bool Pre(const parser::AcSpec &);
bool Pre(const parser::AcImpliedDo &);
@@ -1573,6 +1577,7 @@ class ResolveNamesVisitor : public virtual ScopeHandler,
ResolveName(*parser::Unwrap<parser::Name>(x.name));
}
void Post(const parser::ProcComponentRef &);
+ bool Pre(const parser::ReduceOperation &);
bool Pre(const parser::FunctionReference &);
bool Pre(const parser::CallStmt &);
bool Pre(const parser::ImportStmt &);
@@ -2254,9 +2259,11 @@ void ScopeHandler::SayWithReason(const parser::Name &name, Symbol &symbol,
context().SetError(symbol, isFatal);
}
-void ScopeHandler::SayWithDecl(
- const parser::Name &name, Symbol &symbol, MessageFixedText &&msg) {
- auto &message{Say(name, std::move(msg), symbol.name())
+template <typename... A> void ScopeHandler::SayWithDecl(
+ const parser::Name &name, Symbol &symbol, MessageFixedText &&msg,
+ A &&...args) {
+ auto &message{Say(name.source, std::move(msg), symbol.name(),
+ std::forward<A>(args)...)
.Attach(Message{symbol.name(),
symbol.test(Symbol::Flag::Implicit)
? "Implicit declaration of '%s'"_en_US
@@ -6458,44 +6465,60 @@ bool DeclarationVisitor::PassesSharedLocalityChecks(
return true;
}
-// Checks for locality-specs LOCAL and LOCAL_INIT
+// Checks for locality-specs LOCAL, LOCAL_INIT, and REDUCE
bool DeclarationVisitor::PassesLocalityChecks(
- const parser::Name &name, Symbol &symbol) {
- if (IsAllocatable(symbol)) { // C1128
- SayWithDecl(name, symbol,
- "ALLOCATABLE variable '%s' not allowed in a locality-spec"_err_en_US);
+ const parser::Name &name, Symbol &symbol, Symbol::Flag flag) {
+ bool isReduce = flag == Symbol::Flag::LocalityReduce;
+ if (IsAllocatable(symbol) && !isReduce) { // C1128, F'2023 C1130
+ SayWithDecl(name, symbol, "ALLOCATABLE variable '%s' not allowed in a "
+ "LOCAL%s locality-spec"_err_en_US,
+ (flag == Symbol::Flag::LocalityLocalInit) ? "_INIT" : "");
return false;
}
- if (IsOptional(symbol)) { // C1128
+ if (IsOptional(symbol)) { // C1128, F'2023 C1130-C1131
SayWithDecl(name, symbol,
"OPTIONAL argument '%s' not allowed in a locality-spec"_err_en_US);
return false;
}
- if (IsIntentIn(symbol)) { // C1128
+ if (IsIntentIn(symbol)) { // C1128, F'2023 C1130-C1131
SayWithDecl(name, symbol,
"INTENT IN argument '%s' not allowed in a locality-spec"_err_en_US);
return false;
}
- if (IsFinalizable(symbol)) { // C1128
- SayWithDecl(name, symbol,
- "Finalizable variable '%s' not allowed in a locality-spec"_err_en_US);
+ if (IsFinalizable(symbol) && !isReduce) { // C1128, F'2023 C1130
+ SayWithDecl(name, symbol, "Finalizable variable '%s' not allowed in a "
+ "LOCAL%s locality-spec"_err_en_US,
+ (flag == Symbol::Flag::LocalityLocalInit) ? "_INIT" : "");
return false;
}
- if (evaluate::IsCoarray(symbol)) { // C1128
- SayWithDecl(
- name, symbol, "Coarray '%s' not allowed in a locality-spec"_err_en_US);
+ if (evaluate::IsCoarray(symbol) && !isReduce) { // C1128, F'2023 C1130
+ SayWithDecl(name, symbol, "Coarray '%s' not allowed in a "
+ "LOCAL%s locality-spec"_err_en_US,
+ (flag == Symbol::Flag::LocalityLocalInit) ? "_INIT" : "");
return false;
}
if (const DeclTypeSpec * type{symbol.GetType()}) {
if (type->IsPolymorphic() && IsDummy(symbol) &&
- !IsPointer(symbol)) { // C1128
- SayWithDecl(name, symbol,
- "Nonpointer polymorphic argument '%s' not allowed in a "
- "locality-spec"_err_en_US);
+ !IsPointer(symbol) && !isReduce) { // C1128, F'2023 C1130
+ SayWithDecl(name, symbol, "Nonpointer polymorphic argument '%s' not "
+ "allowed in a LOCAL%s locality-spec"_err_en_US,
+ (flag == Symbol::Flag::LocalityLocalInit) ? "_INIT" : "");
return false;
}
}
- if (IsAssumedSizeArray(symbol)) { // C1128
+ if (symbol.attrs().test(Attr::ASYNCHRONOUS) && isReduce) { // F'2023 C1131
+ SayWithDecl(name, symbol,
+ "ASYNCHRONOUS variable '%s' not allowed in a "
+ "REDUCE locality-spec"_err_en_US);
+ return false;
+ }
+ if (symbol.attrs().test(Attr::VOLATILE) && isReduce) { // F'2023 C1131
+ SayWithDecl(name, symbol,
+ "VOLATILE variable '%s' not allowed in a "
+ "REDUCE locality-spec"_err_en_US);
+ return false;
+ }
+ if (IsAssumedSizeArray(symbol)) { // C1128, F'2023 C1130-C1131
SayWithDecl(name, symbol,
"Assumed size array '%s' not allowed in a locality-spec"_err_en_US);
return false;
@@ -6524,9 +6547,10 @@ Symbol &DeclarationVisitor::FindOrDeclareEnclosingEntity(
return *prev;
}
-Symbol *DeclarationVisitor::DeclareLocalEntity(const parser::Name &name) {
+Symbol *DeclarationVisitor::DeclareLocalEntity(
+ const parser::Name &name, Symbol::Flag flag) {
Symbol &prev{FindOrDeclareEnclosingEntity(name)};
- if (!PassesLocalityChecks(name, prev)) {
+ if (!PassesLocalityChecks(name, prev, flag)) {
return nullptr;
}
return &MakeHostAssocSymbol(name, prev);
@@ -6866,7 +6890,7 @@ bool ConstructVisitor::Pre(const parser::ConcurrentHeader &header) {
bool ConstructVisitor::Pre(const parser::LocalitySpec::Local &x) {
for (auto &name : x.v) {
- if (auto *symbol{DeclareLocalEntity(name)}) {
+ if (auto *symbol{DeclareLocalEntity(name, Symbol::Flag::LocalityLocal)}) {
symbol->set(Symbol::Flag::LocalityLocal);
}
}
@@ -6875,13 +6899,25 @@ bool ConstructVisitor::Pre(const parser::LocalitySpec::Local &x) {
bool ConstructVisitor::Pre(const parser::LocalitySpec::LocalInit &x) {
for (auto &name : x.v) {
- if (auto *symbol{DeclareLocalEntity(name)}) {
+ if (auto *symbol{
+ DeclareLocalEntity(name, Symbol::Flag::LocalityLocalInit)}) {
symbol->set(Symbol::Flag::LocalityLocalInit);
}
}
return false;
}
+bool ConstructVisitor::Pre(const parser::LocalitySpec::Reduce &x) {
+ Walk(std::get<parser::ReduceOperation>(x.t));
+ for (auto &name : std::get<std::list<parser::Name>>(x.t)) {
+ if (auto *symbol{
+ DeclareLocalEntity(name, Symbol::Flag::LocalityReduce)}) {
+ symbol->set(Symbol::Flag::LocalityReduce);
+ }
+ }
+ return false;
+}
+
bool ConstructVisitor::Pre(const parser::LocalitySpec::Shared &x) {
for (const auto &name : x.v) {
if (!FindSymbol(name)) {
@@ -8216,6 +8252,15 @@ void ResolveNamesVisitor::HandleProcedureName(
}
}
+bool ResolveNamesVisitor::Pre(const parser::ReduceOperation &x) {
+ if (const auto *procD{parser::Unwrap<parser::ProcedureDesignator>(x.u)}) {
+ if (const auto *name{parser::Unwrap<parser::Name>(procD->u)}) {
+ HandleProcedureName(Symbol::Flag::Function, *name);
+ }
+ }
+ return false;
+}
+
bool ResolveNamesVisitor::CheckImplicitNoneExternal(
const SourceName &name, const Symbol &symbol) {
if (symbol.has<ProcEntityDetails>() && isImplicitNoneExternal() &&
diff --git a/flang/test/Semantics/resolve123.f90 b/flang/test/Semantics/resolve123.f90
new file mode 100644
index 0000000000000..1b2c4613f2fef
--- /dev/null
+++ b/flang/test/Semantics/resolve123.f90
@@ -0,0 +1,79 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Tests for F'2023 C1131:
+! A variable-name that appears in a REDUCE locality-spec shall not have the
+! ASYNCHRONOUS, INTENT (IN), OPTIONAL, or VOLATILE attribute, shall not be
+! coindexed, and shall not be an assumed-size array. A variable-name that is not
+! permitted to appear in a variable definition context shall not appear in a
+! REDUCE locality-spec.
+
+subroutine s1()
+! Cannot have ASYNCHRONOUS variable in a REDUCE locality spec
+ integer, asynchronous :: k
+!ERROR: ASYNCHRONOUS variable 'k' not allowed in a REDUCE locality-spec
+ do concurrent(i=1:5) reduce(+:k)
+ k = k + i
+ end do
+end subroutine s1
+
+subroutine s2(arg)
+! Cannot have a dummy OPTIONAL in a REDUCE locality spec
+ integer, optional :: arg
+!ERROR: OPTIONAL argument 'arg' not allowed in a locality-spec
+ do concurrent(i=1:5) reduce(*:arg)
+ arg = arg * 1
+ end do
+end subroutine s2
+
+subroutine s3(arg)
+! This is OK
+ real :: arg
+ integer :: reduce, reduce2, reduce3
+ do concurrent(i=1:5) reduce(max:arg,reduce) reduce(iand:reduce2,reduce3)
+ arg = max(arg, i)
+ reduce = max(reduce, i)
+ reduce3 = iand(reduce3, i)
+ end do
+end subroutine s3
+
+subroutine s4(arg)
+! Cannot have a dummy INTENT(IN) in a REDUCE locality spec
+ real, intent(in) :: arg
+!ERROR: INTENT IN argument 'arg' not allowed in a locality-spec
+ do concurrent(i=1:5) reduce(min:arg)
+!ERROR: Left-hand side of assignment is not definable
+!ERROR: 'arg' is an INTENT(IN) dummy argument
+ arg = min(arg, i)
+ end do
+end subroutine s4
+
+module m
+contains
+ subroutine s5()
+ ! Cannot have VOLATILE variable in a REDUCE locality spec
+ integer, volatile :: var
+ !ERROR: VOLATILE variable 'var' not allowed in a REDUCE locality-spec
+ do concurrent(i=1:5) reduce(ieor:var)
+ var = ieor(var, i)
+ end do
+ end subroutine s5
+ subroutine f(x)
+ integer :: x
+ end subroutine f
+end module m
+
+subroutine s8(arg)
+! Cannot have an assumed size array
+ integer, dimension(*) :: arg
+!ERROR: Assumed size array 'arg' not allowed in a locality-spec
+ do concurrent(i=1:5) reduce(ior:arg)
+ arg(i) = ior(arg(i), i)
+ end do
+end subroutine s8
+
+subroutine s9()
+! Reduction variable should not appear in a variable definition context
+ integer :: i
+!ERROR: 'i' is already declared in this scoping unit
+ do concurrent(i=1:5) reduce(+:i)
+ end do
+end subroutine s9
diff --git a/flang/test/Semantics/resolve124.f90 b/flang/test/Semantics/resolve124.f90
new file mode 100644
index 0000000000000..efb920c6f5d7f
--- /dev/null
+++ b/flang/test/Semantics/resolve124.f90
@@ -0,0 +1,89 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Tests for F'2023 C1132:
+! A variable-name that appears in a REDUCE locality-spec shall be of intrinsic
+! type suitable for the intrinsic operation or function specified by its
+! reduce-operation.
+
+subroutine s1(n)
+! This is OK
+ integer :: i1, i2, i3, i4, i5, i6, i7, n
+ real(8) :: r1, r2, r3, r4
+ complex :: c1, c2
+ logical :: l1, l2, l3(n,n), l4(n)
+ do concurrent(i=1:5) &
+ & reduce(+:i1,r1,c1) reduce(*:i2,r2,c2) reduce(iand:i3) reduce(ieor:i4) &
+ & reduce(ior:i5) reduce(max:i6,r3) reduce(min:i7,r4) reduce(.and.:l1) &
+ & reduce(.or.:l2) reduce(.eqv.:l3) reduce(.neqv.:l4)
+ end do
+end subroutine s1
+
+subroutine s2()
+! Cannot apply logical operations to integer variables
+ integer :: i1, i2, i3, i4
+!ERROR: Reduction variable 'i1' does not have a suitable type.
+!ERROR: Reduction variable 'i2' does not have a suitable type.
+!ERROR: Reduction variable 'i3' does not have a suitable type.
+!ERROR: Reduction variable 'i4' does not have a suitable type.
+ do concurrent(i=1:5) &
+ & reduce(.and.:i1) reduce(.or.:i2) reduce(.eqv.:i3) reduce(.neqv.:i4)
+ end do
+end subroutine s2
+
+subroutine s3()
+! Cannot apply integer/logical operations to real variables
+ real :: r1, r2, r3, r4
+!ERROR: Reduction variable 'r1' does not have a suitable type.
+!ERROR: Reduction variable 'r2' does not have a suitable type.
+!ERROR: Reduction variable 'r3' does not have a suitable type.
+!ERROR: Reduction variable 'r4' does not have a suitable type.
+!ERROR: Reduction variable 'r5' does not have a suitable type.
+!ERROR: Reduction variable 'r6' does not have a suitable type.
+!ERROR: Reduction variable 'r7' does not have a suitable type.
+ do concurrent(i=1:5) &
+ & reduce(iand:r1) reduce(ieor:r2) reduce(ior:r3) reduce(.and.:r4) &
+ & reduce(.or.:r5) reduce(.eqv.:r6) reduce(.neqv.:r7)
+ end do
+end subroutine s3
+
+subroutine s4()
+! Cannot apply integer/logical operations to complex variables
+ complex :: c1, c2, c3, c4, c5, c6, c7, c8, c9
+!ERROR: Reduction variable 'c1' does not have a suitable type.
+!ERROR: Reduction variable 'c2' does not have a suitable type.
+!ERROR: Reduction variable 'c3' does not have a suitable type.
+!ERROR: Reduction variable 'c4' does not have a suitable type.
+!ERROR: Reduction variable 'c5' does not have a suitable type.
+!ERROR: Reduction variable 'c6' does not have a suitable type.
+!ERROR: Reduction variable 'c7' does not have a suitable type.
+!ERROR: Reduction variable 'c8' does not have a suitable type.
+!ERROR: Reduction variable 'c9' does not have a suitable type.
+ do concurrent(i=1:5) &
+ & reduce(iand:c1) reduce(ieor:c2) reduce(ior:c3) reduce(max:c4) &
+ & reduce(min:c5) reduce(.and.:c6) reduce(.or.:c7) reduce(.eqv.:c8) &
+ & reduce(.neqv.:c9)
+ end do
+end subroutine s4
+
+subroutine s5()
+! Cannot apply integer operations to logical variables
+ logical :: l1, l2, l3, l4, l5, l6, l7
+!ERROR: Reduction variable 'l1' does not have a suitable type.
+!ERROR: Reduction variable 'l2' does not have a suitable type.
+!ERROR: Reduction variable 'l3' does not have a suitable type.
+!ERROR: Reduction variable 'l4' does not have a suitable type.
+!ERROR: Reduction variable 'l5' does not have a suitable type.
+!ERROR: Reduction variable 'l6' does not have a suitable type.
+!ERROR: Reduction variable 'l7' does not have a suitable type.
+ do concurrent(i=1:5) &
+ & reduce(+:l1) reduce(*:l2) reduce(iand:l3) reduce(ieor:l4) &
+ & reduce(ior:l5) reduce(max:l6) reduce(min:l7)
+ end do
+end subroutine s5
+
+subroutine s6()
+! Cannot reduce a character
+ character ch
+!ERROR: Reduction variable 'ch' does not have a suitable type.
+ do concurrent(i=1:5) reduce(+:ch)
+ end do
+end subroutine s6
diff --git a/flang/test/Semantics/resolve55.f90 b/flang/test/Semantics/resolve55.f90
index 1133e791fa389..54ecb341a82e4 100644
--- a/flang/test/Semantics/resolve55.f90
+++ b/flang/test/Semantics/resolve55.f90
@@ -1,16 +1,19 @@
! RUN: %python %S/test_errors.py %s %flang_fc1
-! Tests for C1128:
+! Tests for C1128 and F'2023 C1130:
! A variable-name that appears in a LOCAL or LOCAL_INIT locality-spec shall not
! have the ALLOCATABLE; INTENT (IN); or OPTIONAL attribute; shall not be of
! finalizable type; shall not be a nonpointer polymorphic dummy argument; and
! shall not be a coarray or an assumed-size array.
subroutine s1()
-! Cannot have ALLOCATABLE variable in a locality spec
+! Cannot have ALLOCATABLE variable in a LOCAL/LOCAL_INIT locality spec
integer, allocatable :: k
-!ERROR: ALLOCATABLE variable 'k' not allowed in a locality-spec
+!ERROR: ALLOCATABLE variable 'k' not allowed in a LOCAL locality-spec
do concurrent(i=1:5) local(k)
end do
+!ERROR: ALLOCATABLE variable 'k' not allowed in a LOCAL_INIT locality-spec
+ do concurrent(i=1:5) local_init(k)
+ end do
end subroutine s1
subroutine s2(arg)
@@ -37,7 +40,7 @@ subroutine s4(arg)
end subroutine s4
module m
-! Cannot have a variable of a finalizable type in a locality spec
+! Cannot have a variable of a finalizable type in a LOCAL locality spec
type t1
integer :: i
contains
@@ -46,7 +49,7 @@ module m
contains
subroutine s5()
type(t1) :: var
- !ERROR: Finalizable variable 'var' not allowed in a locality-spec
+ !ERROR: Finalizable variable 'var' not allowed in a LOCAL locality-spec
do concurrent(i=1:5) local(var)
end do
end subroutine s5
@@ -56,7 +59,7 @@ end subroutine f
end module m
subroutine s6
-! Cannot have a nonpointer polymorphic dummy argument in a locality spec
+! Cannot have a nonpointer polymorphic dummy argument in a LOCAL locality spec
type :: t
integer :: field
end type t
@@ -70,7 +73,7 @@ subroutine s(x, y)
end do
! This is not allowed
-!ERROR: Nonpointer polymorphic argument 'y' not allowed in a locality-spec
+!ERROR: Nonpointer polymorphic argument 'y' not allowed in a LOCAL locality-spec
do concurrent(i=1:5) local(y)
end do
end subroutine s
@@ -79,7 +82,7 @@ end subroutine s6
subroutine s7()
! Cannot have a coarray
integer, codimension[*] :: coarray_var
-!ERROR: Coarray 'coarray_var' not allowed in a locality-spec
+!ERROR: Coarray 'coarray_var' not allowed in a LOCAL locality-spec
do concurrent(i=1:5) local(coarray_var)
end do
end subroutine s7
More information about the flang-commits
mailing list