diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -542,6 +542,8 @@ parser::CharBlock stmtLocation, parser::MessageFormattedText &&message, parser::CharBlock constructLocation); }; - +// Return the (possibly null) name of the ConstructNode +const std::optional &MaybeGetNodeName( + const ConstructNode &construct); } // namespace Fortran::semantics #endif // FORTRAN_SEMANTICS_TOOLS_H_ diff --git a/flang/lib/Semantics/check-acc-structure.cpp b/flang/lib/Semantics/check-acc-structure.cpp --- a/flang/lib/Semantics/check-acc-structure.cpp +++ b/flang/lib/Semantics/check-acc-structure.cpp @@ -5,7 +5,6 @@ // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception // //===----------------------------------------------------------------------===// - #include "check-acc-structure.h" #include "flang/Parser/parse-tree.h" #include "flang/Semantics/tools.h" @@ -59,16 +58,22 @@ return true; } - void Post(const parser::ReturnStmt &) { emitBranchOutError("RETURN"); } - void Post(const parser::ExitStmt &) { emitBranchOutError("EXIT"); } - void Post(const parser::StopStmt &) { emitBranchOutError("STOP"); } + void Post(const parser::ReturnStmt &) { EmitBranchOutError("RETURN"); } + void Post(const parser::ExitStmt &exitStmt) { + if (const auto &exitName{exitStmt.v}) { + CheckConstructNameBranching("EXIT", exitName.value()); + } + } + void Post(const parser::StopStmt &) { EmitBranchOutError("STOP"); } private: - parser::MessageFixedText GetEnclosingMsg() { - return "Enclosing block construct"_en_US; + parser::MessageFormattedText GetEnclosingMsg() const { + return {"Enclosing %s construct"_en_US, + parser::ToUpperCaseLetters( + llvm::acc::getOpenACCDirectiveName(currentDirective_).str())}; } - void emitBranchOutError(const char *stmt) { + void EmitBranchOutError(const char *stmt) const { context_ .Say(currentStatementSourcePosition_, "%s statement is not allowed in a %s construct"_err_en_US, stmt, @@ -77,6 +82,39 @@ .Attach(sourcePosition_, GetEnclosingMsg()); } + void EmitBranchOutErrorWithName( + const char *stmt, const parser::Name &toName) const { + const std::string branchingToName{toName.ToString()}; + const auto upperCaseConstructName{parser::ToUpperCaseLetters( + llvm::acc::getOpenACCDirectiveName(currentDirective_).str())}; + context_ + .Say(currentStatementSourcePosition_, + "%s to construct '%s' outside of %s construct is not allowed"_err_en_US, + stmt, branchingToName, upperCaseConstructName) + .Attach(sourcePosition_, GetEnclosingMsg()); + } + + // Current semantic checker is not following OpenACC constructs as they are + // not Fortran constructs. Hence the ConstructStack doesn't capture OpenACC + // constructs. Apply an inverse way to figure out if a construct-name is + // branching out of an OpenACC construct. The control flow goes out of an + // OpenACC construct, if a construct-name from statement is found in + // ConstructStack. + void CheckConstructNameBranching( + const char *stmt, const parser::Name &stmtName) { + const ConstructStack &stack{context_.constructStack()}; + for (auto iter{stack.cend()}; iter-- != stack.cbegin();) { + const ConstructNode &construct{*iter}; + const auto &constructName{MaybeGetNodeName(construct)}; + if (constructName) { + if (stmtName.source == constructName->source) { + EmitBranchOutErrorWithName(stmt, stmtName); + return; + } + } + } + } + SemanticsContext &context_; parser::CharBlock currentStatementSourcePosition_; parser::CharBlock sourcePosition_; diff --git a/flang/lib/Semantics/check-do-forall.cpp b/flang/lib/Semantics/check-do-forall.cpp --- a/flang/lib/Semantics/check-do-forall.cpp +++ b/flang/lib/Semantics/check-do-forall.cpp @@ -72,23 +72,10 @@ return bounds.name.thing; } -// Return the (possibly null) name of the construct -template -static const parser::Name *MaybeGetConstructName(const A &a) { - return common::GetPtrFromOptional(std::get<0>(std::get<0>(a.t).statement.t)); -} - static parser::MessageFixedText GetEnclosingDoMsg() { return "Enclosing DO CONCURRENT statement"_en_US; } -static const parser::Name *MaybeGetConstructName( - const parser::BlockConstruct &blockConstruct) { - return common::GetPtrFromOptional( - std::get>(blockConstruct.t) - .statement.v); -} - static void SayWithDo(SemanticsContext &context, parser::CharBlock stmtLocation, parser::MessageFixedText &&message, parser::CharBlock doLocation) { context.Say(stmtLocation, message).Attach(doLocation, GetEnclosingDoMsg()); @@ -329,12 +316,6 @@ } private: - // Return the (possibly null) name of the statement - template - static const parser::Name *MaybeGetStmtName(const A &a) { - return common::GetPtrFromOptional(std::get<0>(a.t)); - } - bool fromScope(const Symbol &symbol, const std::string &moduleName) { if (symbol.GetUltimate().owner().IsModule() && symbol.GetUltimate().owner().GetName().value().ToString() == @@ -845,12 +826,6 @@ doContext.Check(stmt); } -// Return the (possibly null) name of the ConstructNode -static const parser::Name *MaybeGetNodeName(const ConstructNode &construct) { - return std::visit( - [&](const auto &x) { return MaybeGetConstructName(*x); }, construct); -} - template static parser::CharBlock GetConstructPosition(const A &a) { return std::get<0>(a.t).source; @@ -910,7 +885,7 @@ } static bool StmtMatchesConstruct(const parser::Name *stmtName, - StmtType stmtType, const parser::Name *constructName, + StmtType stmtType, const std::optional &constructName, const ConstructNode &construct) { bool inDoConstruct{MaybeGetDoConstruct(construct) != nullptr}; if (!stmtName) { @@ -939,7 +914,8 @@ const ConstructStack &stack{context_.constructStack()}; for (auto iter{stack.cend()}; iter-- != stack.cbegin();) { const ConstructNode &construct{*iter}; - const parser::Name *constructName{MaybeGetNodeName(construct)}; + const std::optional &constructName{ + MaybeGetNodeName(construct)}; if (StmtMatchesConstruct(stmtName, stmtType, constructName, construct)) { CheckDoConcurrentExit(stmtType, construct); return; // We got a match, so we're finished checking diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -1359,4 +1359,19 @@ return details && details->commonBlock(); } +const std::optional &MaybeGetNodeName( + const ConstructNode &construct) { + return std::visit( + common::visitors{ + [&](const parser::BlockConstruct *blockConstruct) + -> const std::optional & { + return std::get<0>(blockConstruct->t).statement.v; + }, + [&](const auto *a) -> const std::optional & { + return std::get<0>(std::get<0>(a->t).statement.t); + }, + }, + construct); +} + } // namespace Fortran::semantics diff --git a/flang/test/Semantics/acc-branch.f90 b/flang/test/Semantics/acc-branch.f90 --- a/flang/test/Semantics/acc-branch.f90 +++ b/flang/test/Semantics/acc-branch.f90 @@ -2,12 +2,11 @@ ! Check OpenACC restruction in branch in and out of some construct ! - program openacc_clause_validity implicit none - integer :: i + integer :: i, j, k integer :: N = 256 real(8) :: a(256) @@ -25,12 +24,70 @@ do i = 1, N a(i) = 3.14 if(i == N-1) THEN - !ERROR: EXIT statement is not allowed in a PARALLEL construct exit end if end do !$acc end parallel + ! Exit branches out of parallel construct, not attached to an OpenACC parallel construct. + name1: do k=1, N + !$acc parallel + !$acc loop + outer: do i=1, N + inner: do j=1, N + ifname: if (j == 2) then + ! These are allowed. + exit + exit inner + exit outer + !ERROR: EXIT to construct 'name1' outside of PARALLEL construct is not allowed + exit name1 + ! Exit to construct other than loops. + exit ifname + end if ifname + end do inner + end do outer + !$acc end parallel + end do name1 + + ! Exit branches out of parallel construct, attached to an OpenACC parallel construct. + thisblk: BLOCK + fortname: if (.true.) then + name1: do k = 1, N + !$acc parallel + !ERROR: EXIT to construct 'fortname' outside of PARALLEL construct is not allowed + exit fortname + !$acc loop + do i = 1, N + a(i) = 3.14 + if(i == N-1) THEN + !ERROR: EXIT to construct 'name1' outside of PARALLEL construct is not allowed + exit name1 + end if + end do + + loop2: do i = 1, N + a(i) = 3.33 + !ERROR: EXIT to construct 'thisblk' outside of PARALLEL construct is not allowed + exit thisblk + end do loop2 + !$acc end parallel + end do name1 + end if fortname + end BLOCK thisblk + + !Exit branches inside OpenACC construct. + !$acc parallel + !$acc loop + do i = 1, N + a(i) = 3.14 + ifname: if (i == 2) then + ! This is allowed. + exit ifname + end if ifname + end do + !$acc end parallel + !$acc parallel !$acc loop do i = 1, N @@ -54,7 +111,6 @@ do i = 1, N a(i) = 3.14 if(i == N-1) THEN - !ERROR: EXIT statement is not allowed in a KERNELS construct exit end if end do @@ -82,12 +138,27 @@ do i = 1, N a(i) = 3.14 if(i == N-1) THEN - !ERROR: EXIT statement is not allowed in a SERIAL construct exit end if end do !$acc end serial + name2: do k=1, N + !$acc serial + do i = 1, N + ifname: if (.true.) then + print *, "LGTM" + a(i) = 3.14 + if(i == N-1) THEN + !ERROR: EXIT to construct 'name2' outside of SERIAL construct is not allowed + exit name2 + exit ifname + end if + end if ifname + end do + !$acc end serial + end do name2 + !$acc serial do i = 1, N a(i) = 3.14