forked from OSchip/llvm-project
[flang] Implementation of semantic checks C1135, C1167, and C1168
These constraints state that CYCLE and EXIT statements should not leave DO CONCURRENT, CRITICAL, or CHANGE TEAM constructs. I added checking code to check-do.cc and removed some superseded code from check-do.cc and semantics.cc. The new code uses the construct stack implemented in my previous pull request. I also added a new test -- dosemantics11.f90 and modified the tests dosemantics10.f90, doconcurrent05.f90, and doconcurrent06.f90 to adapt to the new error messages. I converted these latter two tests to use test_error.sh since they only reported errors. Original-commit: flang-compiler/f18@b0bea7da64 Reviewed-on: https://github.com/flang-compiler/f18/pull/756 Tree-same-pre-rewrite: false
This commit is contained in:
Pete Steinfeld
parent
505b214493
commit
ab12314514
|
|
@ -28,12 +28,34 @@ namespace Fortran::semantics {
|
|||
|
||||
using namespace parser::literals;
|
||||
|
||||
static NamePtr GetNamePtr(const std::optional<parser::Name> &name) {
|
||||
if (name.has_value()) {
|
||||
return &(name.value());
|
||||
} else {
|
||||
return nullptr;
|
||||
}
|
||||
}
|
||||
|
||||
template<typename A> static NamePtr GetConstructName(const A &a) {
|
||||
return GetNamePtr(std::get<0>(std::get<0>(a.t).statement.t));
|
||||
}
|
||||
|
||||
static NamePtr GetConstructName(const parser::BlockConstruct &blockConstruct) {
|
||||
return GetNamePtr(
|
||||
std::get<parser::Statement<parser::BlockStmt>>(blockConstruct.t)
|
||||
.statement.v);
|
||||
}
|
||||
|
||||
template<typename A> static NamePtr GetStmtName(const A &a) {
|
||||
return GetNamePtr(std::get<0>(a.t));
|
||||
}
|
||||
|
||||
// 11.1.7.5 - enforce semantics constraints on a DO CONCURRENT loop body
|
||||
class DoConcurrentBodyEnforce {
|
||||
public:
|
||||
DoConcurrentBodyEnforce(SemanticsContext &context) : context_{context} {}
|
||||
std::set<parser::Label> labels() { return labels_; }
|
||||
std::set<parser::CharBlock> names() { return names_; }
|
||||
std::set<SourceName> names() { return names_; }
|
||||
template<typename T> bool Pre(const T &) { return true; }
|
||||
template<typename T> void Post(const T &) {}
|
||||
template<typename T> bool Pre(const parser::Statement<T> &statement) {
|
||||
|
|
@ -45,53 +67,53 @@ public:
|
|||
}
|
||||
|
||||
// C1167
|
||||
bool Pre(const parser::WhereConstructStmt &s) {
|
||||
addName(std::get<std::optional<parser::Name>>(s.t));
|
||||
bool Pre(const parser::WhereConstruct &s) {
|
||||
addName(GetConstructName(s));
|
||||
return true;
|
||||
}
|
||||
|
||||
bool Pre(const parser::ForallConstructStmt &s) {
|
||||
addName(std::get<std::optional<parser::Name>>(s.t));
|
||||
bool Pre(const parser::ForallConstruct &s) {
|
||||
addName(GetConstructName(s));
|
||||
return true;
|
||||
}
|
||||
|
||||
bool Pre(const parser::ChangeTeamStmt &s) {
|
||||
addName(std::get<std::optional<parser::Name>>(s.t));
|
||||
bool Pre(const parser::ChangeTeamConstruct &s) {
|
||||
addName(GetConstructName(s));
|
||||
return true;
|
||||
}
|
||||
|
||||
bool Pre(const parser::CriticalStmt &s) {
|
||||
addName(std::get<std::optional<parser::Name>>(s.t));
|
||||
bool Pre(const parser::CriticalConstruct &s) {
|
||||
addName(GetConstructName(s));
|
||||
return true;
|
||||
}
|
||||
|
||||
bool Pre(const parser::LabelDoStmt &s) {
|
||||
addName(std::get<std::optional<parser::Name>>(s.t));
|
||||
addName(GetStmtName(s));
|
||||
return true;
|
||||
}
|
||||
|
||||
bool Pre(const parser::NonLabelDoStmt &s) {
|
||||
addName(std::get<std::optional<parser::Name>>(s.t));
|
||||
addName(GetStmtName(s));
|
||||
return true;
|
||||
}
|
||||
|
||||
bool Pre(const parser::IfThenStmt &s) {
|
||||
addName(std::get<std::optional<parser::Name>>(s.t));
|
||||
addName(GetStmtName(s));
|
||||
return true;
|
||||
}
|
||||
|
||||
bool Pre(const parser::SelectCaseStmt &s) {
|
||||
addName(std::get<std::optional<parser::Name>>(s.t));
|
||||
addName(GetStmtName(s));
|
||||
return true;
|
||||
}
|
||||
|
||||
bool Pre(const parser::SelectRankStmt &s) {
|
||||
addName(std::get<0>(s.t));
|
||||
addName(GetStmtName(s));
|
||||
return true;
|
||||
}
|
||||
|
||||
bool Pre(const parser::SelectTypeStmt &s) {
|
||||
addName(std::get<0>(s.t));
|
||||
addName(GetStmtName(s));
|
||||
return true;
|
||||
}
|
||||
|
||||
|
|
@ -213,9 +235,9 @@ private:
|
|||
return false;
|
||||
}
|
||||
|
||||
void addName(const std::optional<parser::Name> &nm) {
|
||||
if (nm.has_value()) {
|
||||
names_.insert(nm.value().source);
|
||||
void addName(NamePtr nm) {
|
||||
if (nm) {
|
||||
names_.insert(nm->source);
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -238,15 +260,8 @@ public:
|
|||
return true;
|
||||
}
|
||||
|
||||
bool Pre(const parser::DoConstruct &) {
|
||||
++do_depth_;
|
||||
return true;
|
||||
}
|
||||
|
||||
template<typename T> void Post(const T &) {}
|
||||
|
||||
// C1138: branch from within a DO CONCURRENT shall not target outside loop
|
||||
void Post(const parser::ExitStmt &exitStmt) { checkName(exitStmt.v); }
|
||||
void Post(const parser::GotoStmt &gotoStmt) { checkLabelUse(gotoStmt.v); }
|
||||
void Post(const parser::ComputedGotoStmt &computedGotoStmt) {
|
||||
for (auto &i : std::get<std::list<parser::Label>>(computedGotoStmt.t)) {
|
||||
|
|
@ -277,22 +292,6 @@ public:
|
|||
void Post(const parser::ErrLabel &errLabel) { checkLabelUse(errLabel.v); }
|
||||
void Post(const parser::EndLabel &endLabel) { checkLabelUse(endLabel.v); }
|
||||
void Post(const parser::EorLabel &eorLabel) { checkLabelUse(eorLabel.v); }
|
||||
void Post(const parser::DoConstruct &) { --do_depth_; }
|
||||
void checkName(const std::optional<parser::Name> &nm) {
|
||||
if (!nm.has_value()) {
|
||||
if (do_depth_ == 0) {
|
||||
context_.Say(currentStatementSourcePosition_,
|
||||
"exit from DO CONCURRENT construct (%s)"_err_en_US,
|
||||
doConcurrentSourcePosition_);
|
||||
}
|
||||
// nesting of named constructs is assumed to have been previously checked
|
||||
// by the name/label resolution pass
|
||||
} else if (names_.find(nm.value().source) == names_.end()) {
|
||||
context_.Say(currentStatementSourcePosition_,
|
||||
"exit from DO CONCURRENT construct (%s) to construct with name '%s'"_err_en_US,
|
||||
doConcurrentSourcePosition_, nm.value().source);
|
||||
}
|
||||
}
|
||||
|
||||
void checkLabelUse(const parser::Label &labelUsed) {
|
||||
if (labels_.find(labelUsed) == labels_.end()) {
|
||||
|
|
@ -305,7 +304,6 @@ private:
|
|||
SemanticsContext &context_;
|
||||
std::set<parser::Label> labels_;
|
||||
std::set<parser::CharBlock> names_;
|
||||
int do_depth_{0};
|
||||
parser::CharBlock currentStatementSourcePosition_{nullptr};
|
||||
parser::CharBlock doConcurrentSourcePosition_{nullptr};
|
||||
}; // class DoConcurrentLabelEnforce
|
||||
|
|
@ -647,20 +645,131 @@ void DoChecker::Leave(const parser::DoConstruct &x) {
|
|||
doContext.Check(x);
|
||||
}
|
||||
|
||||
// C1134
|
||||
void DoChecker::Enter(const parser::CycleStmt &) {
|
||||
if (!context_.InsideDoConstruct()) {
|
||||
context_.Say(
|
||||
*context_.location(), "CYCLE must be within a DO construct"_err_en_US);
|
||||
// Return the (possibly null) name of the ConstructNode
|
||||
static NamePtr MaybeGetNodeName(const ConstructNode &construct) {
|
||||
return std::visit(
|
||||
[&](const auto &x) { return GetConstructName(*x); }, construct);
|
||||
}
|
||||
|
||||
template<typename A> static parser::CharBlock GetConstructPosition(const A &a) {
|
||||
return std::get<0>(a.t).source;
|
||||
}
|
||||
|
||||
static parser::CharBlock GetNodePosition(const ConstructNode &construct) {
|
||||
return std::visit(
|
||||
[&](const auto &x) { return GetConstructPosition(*x); }, construct);
|
||||
}
|
||||
|
||||
void DoChecker::SayBadLeave(const char *stmtChecked,
|
||||
const char *enclosingStmtType, const ConstructNode &construct) const {
|
||||
context_
|
||||
.Say(*context_.location(), "%s must not leave a %s statement"_err_en_US,
|
||||
stmtChecked, enclosingStmtType)
|
||||
.Attach(GetNodePosition(construct), "The construct that was left"_en_US);
|
||||
}
|
||||
|
||||
static parser::DoConstruct const *MaybeGetDoConstruct(
|
||||
const ConstructNode &construct) {
|
||||
if (const auto doNode{std::get_if<const parser::DoConstruct *>(&construct)}) {
|
||||
return *doNode;
|
||||
}
|
||||
return nullptr;
|
||||
}
|
||||
|
||||
// Check that CYCLE and EXIT statements do not cause flow of control to
|
||||
// leave DO CONCURRENT, CRITICAL, or CHANGE TEAM constructs.
|
||||
void DoChecker::CheckForBadLeave(
|
||||
const char *stmtName, const ConstructNode &construct) const {
|
||||
// C1135 and C1167
|
||||
if (const auto doConstructPtr{MaybeGetDoConstruct(construct)}) {
|
||||
if (doConstructPtr->IsDoConcurrent()) {
|
||||
SayBadLeave(stmtName, "DO CONCURRENT", construct);
|
||||
}
|
||||
return;
|
||||
}
|
||||
// C1135 and C1168
|
||||
if (const auto criticalConstructPtr{
|
||||
std::get_if<const parser::CriticalConstruct *>(&construct)}) {
|
||||
SayBadLeave(stmtName, "CRITICAL", construct);
|
||||
return;
|
||||
}
|
||||
if (const auto changeTeamConstructPtr{
|
||||
std::get_if<const parser::ChangeTeamConstruct *>(&construct)}) {
|
||||
SayBadLeave(stmtName, "CHANGE TEAM", construct);
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
// C1166
|
||||
void DoChecker::Enter(const parser::ExitStmt &) {
|
||||
if (!context_.InsideDoConstruct()) {
|
||||
context_.Say(
|
||||
*context_.location(), "EXIT must be within a DO construct"_err_en_US);
|
||||
static bool ConstructIsDoConcurrent(const ConstructNode &construct) {
|
||||
parser::DoConstruct const *doConstruct{MaybeGetDoConstruct(construct)};
|
||||
return doConstruct && doConstruct->IsDoConcurrent();
|
||||
}
|
||||
|
||||
static bool isExitStmt(const char *stmtType) {
|
||||
return std::strncmp("EXIT", stmtType, 4) == 0;
|
||||
}
|
||||
|
||||
static bool StmtMatchesConstruct(NamePtr stmtName, const char *stmtType,
|
||||
NamePtr constructName, const ConstructNode &construct) {
|
||||
bool inDoConstruct{MaybeGetDoConstruct(construct) != nullptr};
|
||||
if (stmtName == nullptr) {
|
||||
if (inDoConstruct) {
|
||||
return true; // Unlabeled statements match all DO constructs
|
||||
} else {
|
||||
return false; // Unlabeled statements match no non-DO constructs
|
||||
}
|
||||
} else if (!constructName) {
|
||||
return false; // name on CYCLE/EXIT, but not on the construct
|
||||
} else if (constructName->source == stmtName->source) {
|
||||
if (isExitStmt(stmtType)) {
|
||||
return true; // EXIT name matches any construct name
|
||||
} else {
|
||||
if (inDoConstruct) {
|
||||
return true; // CYCLE name matches only DO construct name
|
||||
}
|
||||
}
|
||||
}
|
||||
return false;
|
||||
}
|
||||
|
||||
// C1167 Can't EXIT from a DO CONCURRENT
|
||||
void DoChecker::CheckDoConcurrentExit(
|
||||
const char *stmtType, const ConstructNode &construct) const {
|
||||
if (isExitStmt(stmtType) && ConstructIsDoConcurrent(construct)) {
|
||||
SayBadLeave("EXIT", "DO CONCURRENT", construct);
|
||||
}
|
||||
}
|
||||
|
||||
// Check nesting violations for a CYCLE or EXIT statement Loop up the nesting
|
||||
// levels looking for a construct that matches the CYCLE or EXIT statment. At
|
||||
// every construct, check for a violation. If we find a match without finding
|
||||
// a violation, the check is complete.
|
||||
void DoChecker::CheckNesting(const char *stmtType, NamePtr stmtName) const {
|
||||
const ConstructStack &stack{context_.constructStack()};
|
||||
for (ConstructStack::const_reverse_iterator riter = stack.crbegin();
|
||||
riter != stack.crend(); ++riter) {
|
||||
const ConstructNode &construct{*riter};
|
||||
NamePtr constructName{MaybeGetNodeName(construct)};
|
||||
if (StmtMatchesConstruct(stmtName, stmtType, constructName, construct)) {
|
||||
CheckDoConcurrentExit(stmtType, construct);
|
||||
return; // We got a match, so we're finished checking
|
||||
}
|
||||
CheckForBadLeave(stmtType, construct);
|
||||
}
|
||||
|
||||
// We haven't found a match in the enclosing constructs
|
||||
context_.Say(*context_.location(),
|
||||
"No matching construct for %s statement"_err_en_US, stmtType);
|
||||
}
|
||||
|
||||
// C1135
|
||||
void DoChecker::Enter(const parser::CycleStmt &cycleStmt) {
|
||||
CheckNesting("CYCLE", GetNamePtr(cycleStmt.v));
|
||||
}
|
||||
|
||||
// C1167 and C1168
|
||||
void DoChecker::Enter(const parser::ExitStmt &exitStmt) {
|
||||
CheckNesting("EXIT", GetNamePtr(exitStmt.v));
|
||||
}
|
||||
|
||||
} // namespace Fortran::semantics
|
||||
|
|
|
|||
|
|
@ -25,6 +25,8 @@ struct ExitStmt;
|
|||
|
||||
namespace Fortran::semantics {
|
||||
|
||||
using NamePtr = parser::Name const *;
|
||||
|
||||
class DoChecker : public virtual BaseChecker {
|
||||
public:
|
||||
explicit DoChecker(SemanticsContext &context) : context_{context} {}
|
||||
|
|
@ -34,6 +36,12 @@ public:
|
|||
|
||||
private:
|
||||
SemanticsContext &context_;
|
||||
|
||||
void SayBadLeave(const char *stmtChecked, const char *enclosingStmt,
|
||||
const ConstructNode &) const;
|
||||
void CheckDoConcurrentExit(const char *s, const ConstructNode &) const;
|
||||
void CheckForBadLeave(const char *, const ConstructNode &) const;
|
||||
void CheckNesting(const char *, NamePtr) const;
|
||||
};
|
||||
}
|
||||
#endif // FORTRAN_SEMANTICS_CHECK_DO_H_
|
||||
|
|
|
|||
|
|
@ -206,15 +206,6 @@ void SemanticsContext::PopConstruct() {
|
|||
constructStack_.pop_back();
|
||||
}
|
||||
|
||||
bool SemanticsContext::InsideDoConstruct() const {
|
||||
for (const ConstructNode construct : constructStack_) {
|
||||
if (std::holds_alternative<const parser::DoConstruct *>(construct)) {
|
||||
return true;
|
||||
}
|
||||
}
|
||||
return false;
|
||||
}
|
||||
|
||||
bool Semantics::Perform() {
|
||||
return ValidateLabels(context_, program_) &&
|
||||
parser::CanonicalizeDo(program_) && // force line break
|
||||
|
|
|
|||
|
|
@ -36,9 +36,9 @@ struct AssociateConstruct;
|
|||
struct BlockConstruct;
|
||||
struct CaseConstruct;
|
||||
struct DoConstruct;
|
||||
struct CriticalConstruct;
|
||||
struct ChangeTeamConstruct;
|
||||
struct ForAllConstruct;
|
||||
struct CriticalConstruct;
|
||||
struct ForallConstruct;
|
||||
struct IfConstruct;
|
||||
struct SelectRankConstruct;
|
||||
struct SelectTypeConstruct;
|
||||
|
|
@ -52,7 +52,7 @@ class Symbol;
|
|||
using ConstructNode = std::variant<const parser::AssociateConstruct *,
|
||||
const parser::BlockConstruct *, const parser::CaseConstruct *,
|
||||
const parser::ChangeTeamConstruct *, const parser::CriticalConstruct *,
|
||||
const parser::DoConstruct *, const parser::ForAllConstruct *,
|
||||
const parser::DoConstruct *, const parser::ForallConstruct *,
|
||||
const parser::IfConstruct *, const parser::SelectRankConstruct *,
|
||||
const parser::SelectTypeConstruct *, const parser::WhereConstruct *>;
|
||||
using ConstructStack = std::vector<ConstructNode>;
|
||||
|
|
@ -144,7 +144,6 @@ public:
|
|||
constructStack_.emplace_back(&node);
|
||||
}
|
||||
void PopConstruct();
|
||||
bool InsideDoConstruct() const;
|
||||
|
||||
private:
|
||||
const common::IntrinsicTypeDefaultKinds &defaultKinds_;
|
||||
|
|
|
|||
|
|
@ -137,16 +137,17 @@ set(ERROR_TESTS
|
|||
allocate12.f90
|
||||
allocate13.f90
|
||||
doconcurrent01.f90
|
||||
dosemantics05.f90
|
||||
dosemantics06.f90
|
||||
dosemantics01.f90
|
||||
dosemantics02.f90
|
||||
dosemantics03.f90
|
||||
dosemantics04.f90
|
||||
dosemantics05.f90
|
||||
dosemantics06.f90
|
||||
dosemantics07.f90
|
||||
dosemantics08.f90
|
||||
dosemantics09.f90
|
||||
dosemantics10.f90
|
||||
dosemantics11.f90
|
||||
expr-errors01.f90
|
||||
null01.f90
|
||||
omp-clause-validity01.f90
|
||||
|
|
|
|||
|
|
@ -11,14 +11,9 @@
|
|||
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
! See the License for the specific language governing permissions and
|
||||
! limitations under the License.
|
||||
|
||||
! RUN: ${F18} -funparse-with-symbols %s 2>&1 | ${FileCheck} %s
|
||||
! CHECK: exit from DO CONCURRENT construct \\(mydoc: do concurrent\\(j=1:n\\)\\) to construct with name 'mydoc'
|
||||
! CHECK: exit from DO CONCURRENT construct \\(mydoc: do concurrent\\(j=1:n\\)\\)
|
||||
! CHECK: exit from DO CONCURRENT construct \\(mydoc: do concurrent\\(j=1:n\\)\\) to construct with name 'mytest3'
|
||||
! CHECK: exit from DO CONCURRENT construct \\(do concurrent\\(k=1:n\\)\\)
|
||||
! CHECK: exit from DO CONCURRENT construct \\(do concurrent\\(k=1:n\\)\\) to construct with name 'mytest4'
|
||||
! CHECK: exit from DO CONCURRENT construct \\(mydoc: do concurrent\\(j=1:n\\)\\) to construct with name 'mytest4'
|
||||
!
|
||||
! C1167 -- An exit-stmt shall not appear within a DO CONCURRENT construct if
|
||||
! it belongs to that construct or an outer construct.
|
||||
|
||||
subroutine do_concurrent_test1(n)
|
||||
implicit none
|
||||
|
|
@ -26,6 +21,7 @@ subroutine do_concurrent_test1(n)
|
|||
integer :: j,k
|
||||
mydoc: do concurrent(j=1:n)
|
||||
mydo: do k=1,n
|
||||
!ERROR: EXIT must not leave a DO CONCURRENT statement
|
||||
if (k==5) exit mydoc
|
||||
if (j==10) exit mydo
|
||||
end do mydo
|
||||
|
|
@ -36,6 +32,7 @@ subroutine do_concurrent_test2(n)
|
|||
implicit none
|
||||
integer :: j,k,n
|
||||
mydoc: do concurrent(j=1:n)
|
||||
!ERROR: EXIT must not leave a DO CONCURRENT statement
|
||||
if (k==5) exit
|
||||
end do mydoc
|
||||
end subroutine do_concurrent_test2
|
||||
|
|
@ -46,6 +43,7 @@ subroutine do_concurrent_test3(n)
|
|||
mytest3: if (n>0) then
|
||||
mydoc: do concurrent(j=1:n)
|
||||
do k=1,n
|
||||
!ERROR: EXIT must not leave a DO CONCURRENT statement
|
||||
if (j==10) exit mytest3
|
||||
end do
|
||||
end do mydoc
|
||||
|
|
@ -58,7 +56,10 @@ subroutine do_concurrent_test4(n)
|
|||
mytest4: if (n>0) then
|
||||
mydoc: do concurrent(j=1:n)
|
||||
do concurrent(k=1:n)
|
||||
!ERROR: EXIT must not leave a DO CONCURRENT statement
|
||||
if (k==5) exit
|
||||
!ERROR: EXIT must not leave a DO CONCURRENT statement
|
||||
!ERROR: EXIT must not leave a DO CONCURRENT statement
|
||||
if (j==10) exit mytest4
|
||||
end do
|
||||
end do mydoc
|
||||
|
|
|
|||
|
|
@ -11,14 +11,9 @@
|
|||
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
! See the License for the specific language governing permissions and
|
||||
! limitations under the License.
|
||||
|
||||
! RUN: ${F18} -funparse-with-symbols %s 2>&1 | ${FileCheck} %s
|
||||
! CHECK: exit from DO CONCURRENT construct \\(nc5: do concurrent\\(i5=1:n\\)\\) to construct with name 'mytest1'
|
||||
! CHECK: exit from DO CONCURRENT construct \\(nc3: do concurrent\\(i3=1:n\\)\\) to construct with name 'mytest1'
|
||||
! CHECK: exit from DO CONCURRENT construct \\(nc1: do concurrent\\(i1=1:n\\)\\) to construct with name 'mytest1'
|
||||
! CHECK: exit from DO CONCURRENT construct \\(nc5: do concurrent\\(i5=1:n\\)\\) to construct with name 'nc3'
|
||||
! CHECK: exit from DO CONCURRENT construct \\(nc3: do concurrent\\(i3=1:n\\)\\) to construct with name 'nc3'
|
||||
! CHECK: exit from DO CONCURRENT construct \\(nc3: do concurrent\\(i3=1:n\\)\\) to construct with name 'nc2'
|
||||
!
|
||||
! C1167 -- An exit-stmt shall not appear within a DO CONCURRENT construct if
|
||||
! it belongs to that construct or an outer construct.
|
||||
|
||||
subroutine do_concurrent_test1(n)
|
||||
implicit none
|
||||
|
|
@ -30,6 +25,9 @@ subroutine do_concurrent_test1(n)
|
|||
nc4: do i4=1,n
|
||||
nc5: do concurrent(i5=1:n)
|
||||
nc6: do i6=1,n
|
||||
!ERROR: EXIT must not leave a DO CONCURRENT statement
|
||||
!ERROR: EXIT must not leave a DO CONCURRENT statement
|
||||
!ERROR: EXIT must not leave a DO CONCURRENT statement
|
||||
if (i6==10) exit mytest1
|
||||
end do nc6
|
||||
end do nc5
|
||||
|
|
@ -50,6 +48,8 @@ subroutine do_concurrent_test2(n)
|
|||
nc4: do i4=1,n
|
||||
nc5: do concurrent(i5=1:n)
|
||||
nc6: do i6=1,n
|
||||
!ERROR: EXIT must not leave a DO CONCURRENT statement
|
||||
!ERROR: EXIT must not leave a DO CONCURRENT statement
|
||||
if (i6==10) exit nc3
|
||||
end do nc6
|
||||
end do nc5
|
||||
|
|
@ -67,6 +67,7 @@ subroutine do_concurrent_test3(n)
|
|||
nc1: do concurrent(i1=1:n)
|
||||
nc2: do i2=1,n
|
||||
nc3: do concurrent(i3=1:n)
|
||||
!ERROR: EXIT must not leave a DO CONCURRENT statement
|
||||
if (i3==4) exit nc2
|
||||
nc4: do i4=1,n
|
||||
nc5: do concurrent(i5=1:n)
|
||||
|
|
|
|||
|
|
@ -36,16 +36,16 @@ subroutine s1()
|
|||
cycle
|
||||
end do outer
|
||||
|
||||
!ERROR: CYCLE must be within a DO construct
|
||||
!ERROR: No matching construct for CYCLE statement
|
||||
cycle
|
||||
|
||||
!ERROR: EXIT must be within a DO construct
|
||||
!ERROR: No matching construct for EXIT statement
|
||||
exit
|
||||
|
||||
!ERROR: CYCLE must be within a DO construct
|
||||
!ERROR: No matching construct for CYCLE statement
|
||||
if(.true.) cycle
|
||||
|
||||
!ERROR: EXIT must be within a DO construct
|
||||
!ERROR: No matching construct for EXIT statement
|
||||
if(.true.) exit
|
||||
|
||||
end subroutine s1
|
||||
|
|
|
|||
|
|
@ -0,0 +1,341 @@
|
|||
! Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
|
||||
!
|
||||
! Licensed under the Apache License, Version 2.0 (the "License");
|
||||
! you may not use this file except in compliance with the License.
|
||||
! You may obtain a copy of the License at
|
||||
!
|
||||
! http://www.apache.org/licenses/LICENSE-2.0
|
||||
!
|
||||
! Unless required by applicable law or agreed to in writing, software
|
||||
! distributed under the License is distributed on an "AS IS" BASIS,
|
||||
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
! See the License for the specific language governing permissions and
|
||||
! limitations under the License.
|
||||
!
|
||||
! C1135 A cycle-stmt shall not appear within a CHANGE TEAM, CRITICAL, or DO
|
||||
! CONCURRENT construct if it belongs to an outer construct.
|
||||
!
|
||||
! C1167 -- An exit-stmt shall not appear within a DO CONCURRENT construct if
|
||||
! it belongs to that construct or an outer construct.
|
||||
!
|
||||
! C1168 -- An exit-stmt shall not appear within a CHANGE TEAM or CRITICAL
|
||||
! construct if it belongs to an outer construct.
|
||||
|
||||
subroutine s1()
|
||||
!ERROR: No matching construct for CYCLE statement
|
||||
cycle
|
||||
end subroutine s1
|
||||
|
||||
subroutine s2()
|
||||
!ERROR: No matching construct for EXIT statement
|
||||
exit
|
||||
end subroutine s2
|
||||
|
||||
subroutine s3()
|
||||
level0: block
|
||||
!ERROR: No matching construct for CYCLE statement
|
||||
cycle level0
|
||||
end block level0
|
||||
end subroutine s3
|
||||
|
||||
subroutine s4()
|
||||
level0: do i = 1, 10
|
||||
level1: do concurrent (j = 1:20)
|
||||
!ERROR: CYCLE must not leave a DO CONCURRENT statement
|
||||
cycle level0
|
||||
end do level1
|
||||
end do level0
|
||||
end subroutine s4
|
||||
|
||||
subroutine s5()
|
||||
level0: do i = 1, 10
|
||||
level1: do concurrent (j = 1:20)
|
||||
!ERROR: EXIT must not leave a DO CONCURRENT statement
|
||||
exit level0
|
||||
end do level1
|
||||
end do level0
|
||||
end subroutine s5
|
||||
|
||||
subroutine s6()
|
||||
level0: do i = 1, 10
|
||||
level1: critical
|
||||
!ERROR: CYCLE must not leave a CRITICAL statement
|
||||
cycle level0
|
||||
end critical level1
|
||||
end do level0
|
||||
end subroutine s6
|
||||
|
||||
subroutine s7()
|
||||
level0: do i = 1, 10
|
||||
level1: critical
|
||||
!ERROR: EXIT must not leave a CRITICAL statement
|
||||
exit level0
|
||||
end critical level1
|
||||
end do level0
|
||||
end subroutine s7
|
||||
|
||||
subroutine s8()
|
||||
use :: iso_fortran_env
|
||||
type(team_type) team_var
|
||||
|
||||
level0: do i = 1, 10
|
||||
level1: change team(team_var)
|
||||
!ERROR: CYCLE must not leave a CHANGE TEAM statement
|
||||
cycle level0
|
||||
end team level1
|
||||
end do level0
|
||||
end subroutine s8
|
||||
|
||||
subroutine s9()
|
||||
use :: iso_fortran_env
|
||||
type(team_type) team_var
|
||||
|
||||
level0: do i = 1, 10
|
||||
level1: change team(team_var)
|
||||
!ERROR: EXIT must not leave a CHANGE TEAM statement
|
||||
exit level0
|
||||
end team level1
|
||||
end do level0
|
||||
end subroutine s9
|
||||
|
||||
subroutine s10(table)
|
||||
! A complex, but all legal example
|
||||
|
||||
integer :: table(..)
|
||||
|
||||
type point
|
||||
real :: x, y
|
||||
end type point
|
||||
|
||||
type, extends(point) :: color_point
|
||||
integer :: color
|
||||
end type color_point
|
||||
|
||||
type(point), target :: target_var
|
||||
class(point), pointer :: p_or_c
|
||||
|
||||
p_or_c => target_var
|
||||
level0: do i = 1, 10
|
||||
level1: associate (avar => ivar)
|
||||
level2: block
|
||||
level3: select case (l)
|
||||
case default
|
||||
print*, "default"
|
||||
case (1)
|
||||
level4: if (.true.) then
|
||||
level5: select rank(table)
|
||||
rank default
|
||||
level6: select type ( a => p_or_c )
|
||||
type is ( point )
|
||||
cycle level0
|
||||
end select level6
|
||||
end select level5
|
||||
end if level4
|
||||
end select level3
|
||||
end block level2
|
||||
end associate level1
|
||||
end do level0
|
||||
end subroutine s10
|
||||
|
||||
subroutine s11(table)
|
||||
! A complex, but all legal example with a CYCLE statement
|
||||
|
||||
integer :: table(..)
|
||||
|
||||
type point
|
||||
real :: x, y
|
||||
end type point
|
||||
|
||||
type, extends(point) :: color_point
|
||||
integer :: color
|
||||
end type color_point
|
||||
|
||||
type(point), target :: target_var
|
||||
class(point), pointer :: p_or_c
|
||||
|
||||
p_or_c => target_var
|
||||
level0: do i = 1, 10
|
||||
level1: associate (avar => ivar)
|
||||
level2: block
|
||||
level3: select case (l)
|
||||
case default
|
||||
print*, "default"
|
||||
case (1)
|
||||
level4: if (.true.) then
|
||||
level5: select rank(table)
|
||||
rank default
|
||||
level6: select type ( a => p_or_c )
|
||||
type is ( point )
|
||||
cycle level0
|
||||
end select level6
|
||||
end select level5
|
||||
end if level4
|
||||
end select level3
|
||||
end block level2
|
||||
end associate level1
|
||||
end do level0
|
||||
end subroutine s11
|
||||
|
||||
subroutine s12(table)
|
||||
! A complex, but all legal example with an EXIT statement
|
||||
|
||||
integer :: table(..)
|
||||
|
||||
type point
|
||||
real :: x, y
|
||||
end type point
|
||||
|
||||
type, extends(point) :: color_point
|
||||
integer :: color
|
||||
end type color_point
|
||||
|
||||
type(point), target :: target_var
|
||||
class(point), pointer :: p_or_c
|
||||
|
||||
p_or_c => target_var
|
||||
level0: do i = 1, 10
|
||||
level1: associate (avar => ivar)
|
||||
level2: block
|
||||
level3: select case (l)
|
||||
case default
|
||||
print*, "default"
|
||||
case (1)
|
||||
level4: if (.true.) then
|
||||
level5: select rank(table)
|
||||
rank default
|
||||
level6: select type ( a => p_or_c )
|
||||
type is ( point )
|
||||
exit level0
|
||||
end select level6
|
||||
end select level5
|
||||
end if level4
|
||||
end select level3
|
||||
end block level2
|
||||
end associate level1
|
||||
end do level0
|
||||
end subroutine s12
|
||||
|
||||
subroutine s13(table)
|
||||
! Similar example without construct names
|
||||
|
||||
integer :: table(..)
|
||||
|
||||
type point
|
||||
real :: x, y
|
||||
end type point
|
||||
|
||||
type, extends(point) :: color_point
|
||||
integer :: color
|
||||
end type color_point
|
||||
|
||||
type(point), target :: target_var
|
||||
class(point), pointer :: p_or_c
|
||||
|
||||
p_or_c => target_var
|
||||
do i = 1, 10
|
||||
associate (avar => ivar)
|
||||
block
|
||||
select case (l)
|
||||
case default
|
||||
print*, "default"
|
||||
case (1)
|
||||
if (.true.) then
|
||||
select rank(table)
|
||||
rank default
|
||||
select type ( a => p_or_c )
|
||||
type is ( point )
|
||||
cycle
|
||||
end select
|
||||
end select
|
||||
end if
|
||||
end select
|
||||
end block
|
||||
end associate
|
||||
end do
|
||||
end subroutine s13
|
||||
|
||||
subroutine s14(table)
|
||||
|
||||
integer :: table(..)
|
||||
|
||||
type point
|
||||
real :: x, y
|
||||
end type point
|
||||
|
||||
type, extends(point) :: color_point
|
||||
integer :: color
|
||||
end type color_point
|
||||
|
||||
type(point), target :: target_var
|
||||
class(point), pointer :: p_or_c
|
||||
|
||||
p_or_c => target_var
|
||||
do i = 1, 10
|
||||
associate (avar => ivar)
|
||||
block
|
||||
critical
|
||||
select case (l)
|
||||
case default
|
||||
print*, "default"
|
||||
case (1)
|
||||
if (.true.) then
|
||||
select rank(table)
|
||||
rank default
|
||||
select type ( a => p_or_c )
|
||||
type is ( point )
|
||||
!ERROR: CYCLE must not leave a CRITICAL statement
|
||||
cycle
|
||||
!ERROR: EXIT must not leave a CRITICAL statement
|
||||
exit
|
||||
end select
|
||||
end select
|
||||
end if
|
||||
end select
|
||||
end critical
|
||||
end block
|
||||
end associate
|
||||
end do
|
||||
end subroutine s14
|
||||
|
||||
subroutine s15(table)
|
||||
! Illegal EXIT to an intermediated construct
|
||||
|
||||
integer :: table(..)
|
||||
|
||||
type point
|
||||
real :: x, y
|
||||
end type point
|
||||
|
||||
type, extends(point) :: color_point
|
||||
integer :: color
|
||||
end type color_point
|
||||
|
||||
type(point), target :: target_var
|
||||
class(point), pointer :: p_or_c
|
||||
|
||||
p_or_c => target_var
|
||||
level0: do i = 1, 10
|
||||
level1: associate (avar => ivar)
|
||||
level2: block
|
||||
level3: select case (l)
|
||||
case default
|
||||
print*, "default"
|
||||
case (1)
|
||||
level4: if (.true.) then
|
||||
level5: critical
|
||||
level6: select rank(table)
|
||||
rank default
|
||||
level7: select type ( a => p_or_c )
|
||||
type is ( point )
|
||||
exit level6
|
||||
!ERROR: EXIT must not leave a CRITICAL statement
|
||||
exit level4
|
||||
end select level7
|
||||
end select level6
|
||||
end critical level5
|
||||
end if level4
|
||||
end select level3
|
||||
end block level2
|
||||
end associate level1
|
||||
end do level0
|
||||
end subroutine s15
|
||||
Loading…
Reference in New Issue