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 @@ -528,5 +528,11 @@ parser::CharBlock constructLocation); }; +template const parser::Name *MaybeGetStmtName(const A &a); +template const parser::Name *MaybeGetConstructName(const A &a); +const parser::Name *MaybeGetConstructName( + const parser::BlockConstruct &blockConstruct); +const parser::Name *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" @@ -60,15 +59,20 @@ } void Post(const parser::ReturnStmt &) { emitBranchOutError("RETURN"); } - void Post(const parser::ExitStmt &) { emitBranchOutError("EXIT"); } + 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 +81,47 @@ .Attach(sourcePosition_, GetEnclosingMsg()); } + void emitBranchOutErrorWithLabel( + const char *stmt, const parser::Name &toLabel) const { + const std::string labelName{toLabel.ToString()}; + const auto upperCaseConstructName{parser::ToUpperCaseLetters( + llvm::acc::getOpenACCDirectiveName(currentDirective_).str())}; + context_ + .Say(currentStatementSourcePosition_, + "%s to a label '%s' outside of %s construct is not allowed"_err_en_US, + stmt, labelName, upperCaseConstructName) + .Attach(sourcePosition_, GetEnclosingMsg()); + } + + bool stmtNameMatchesConstructName( + const parser::Name &stmtName, const parser::Name &constructName) const { + if ((constructName.ToString().compare(stmtName.ToString()) == 0)) { + return true; + } else { + return false; + } + } + // 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}; + if (const parser::Name * + constructName{semantics::MaybeGetNodeName(construct)}) { + if (stmtNameMatchesConstructName(stmtName, *constructName)) { + emitBranchOutErrorWithLabel(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; @@ -939,7 +914,7 @@ const ConstructStack &stack{context_.constructStack()}; for (auto iter{stack.cend()}; iter-- != stack.cbegin();) { const ConstructNode &construct{*iter}; - const parser::Name *constructName{MaybeGetNodeName(construct)}; + const parser::Name *constructName{semantics::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 @@ -1321,4 +1321,27 @@ return details && details->commonBlock(); } +// Return the (possibly null) name of the statement +template const parser::Name *MaybeGetStmtName(const A &a) { + return common::GetPtrFromOptional(std::get<0>(a.t)); +} + +// Return the (possibly null) name of the construct +template const parser::Name *MaybeGetConstructName(const A &a) { + return common::GetPtrFromOptional(std::get<0>(std::get<0>(a.t).statement.t)); +} + +const parser::Name *MaybeGetConstructName( + const parser::BlockConstruct &blockConstruct) { + return common::GetPtrFromOptional( + std::get>(blockConstruct.t) + .statement.v); +} + +// Return the (possibly null) name of the ConstructNode +const parser::Name *MaybeGetNodeName(const ConstructNode &construct) { + return std::visit( + [&](const auto &x) { return MaybeGetConstructName(*x); }, 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,74 @@ 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 + ! There are 3 sets: + ! label is out of parallel construct, labelled block is attached to an OpenACC parallel construct. + ! label is out of parallel construct, labelled block is not attached to an OpenACC parallel construct. + ! label is inside OpenACC construct. + + label1: do k=1, N + !$acc parallel + !$acc loop + outer: do i=1, N + inner: do j=1, N + iflabel: if (j == 2) then + ! These are allowed. + exit + exit inner + exit outer + !ERROR: EXIT to a label 'label1' outside of PARALLEL construct is not allowed + exit label1 + ! Exit to construct other than loops. + exit iflabel + end if iflabel + end do inner + end do outer + !$acc end parallel + end do label1 + + !Attached to parallel. + thisblk: BLOCK + fortlabel: if (.true.) then + label1: do k = 1, N + !$acc parallel + !ERROR: EXIT to a label 'fortlabel' outside of PARALLEL construct is not allowed + exit fortlabel + !$acc loop + do i = 1, N + a(i) = 3.14 + if(i == N-1) THEN + !ERROR: EXIT to a label 'label1' outside of PARALLEL construct is not allowed + exit label1 + end if + end do + + loop2: do i = 1, N + a(i) = 3.33 + !ERROR: EXIT to a label 'thisblk' outside of PARALLEL construct is not allowed + exit thisblk + end do loop2 + !$acc end parallel + end do label1 + end if fortlabel + end BLOCK thisblk + + !label is inside OpenACC construct. + !$acc parallel + !$acc loop + do i = 1, N + a(i) = 3.14 + iflabel: if (i == 2) then + ! This is allowed. + exit iflabel + end if iflabel + end do + !$acc end parallel + !$acc parallel !$acc loop do i = 1, N @@ -54,7 +115,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 +142,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 + label2: do k=1, N + !$acc serial + do i = 1, N + iflabel: if (.true.) then + print *, "LGTM" + a(i) = 3.14 + if(i == N-1) THEN + !ERROR: EXIT to a label 'label2' outside of SERIAL construct is not allowed + exit label2 + exit iflabel + end if + end if iflabel + end do + !$acc end serial + end do label2 + !$acc serial do i = 1, N a(i) = 3.14