diff --git a/flang/lib/semantics/check-do-concurrent.cc b/flang/lib/semantics/check-do-concurrent.cc index 2ee8b923e757..c66b63fea8f6 100644 --- a/flang/lib/semantics/check-do-concurrent.cc +++ b/flang/lib/semantics/check-do-concurrent.cc @@ -20,7 +20,7 @@ namespace Fortran::semantics { using namespace parser::literals; -// 11.1.7.5 +// 11.1.7.5 - enforce semantics constraints on a DO CONCURRENT loop body class DoConcurrentEnforcement { public: DoConcurrentEnforcement(parser::Messages &messages) : messages_{messages} {} @@ -85,8 +85,11 @@ public: } // C1141 void Post(const parser::ProcedureDesignator &procedureDesignator) { - if (auto *name = std::get_if(&procedureDesignator.u)) { +#if 0 + if (auto *name{std::get_if(&procedureDesignator.u)}) { auto upperName{parser::ToUpperCaseLetters(name->ToString())}; + // FIXME: These names need to resolve to symbols imported from the + // intrinsic module IEEE_EXCEPTIONS. Do some symbol lookup here? if (upperName == "IEEE_GET_FLAG"s) { messages_.Say(charBlock_, parser::MessageFormattedText{ @@ -101,14 +104,15 @@ public: " in DO CONCURRENT"_err_en_US}); } } +#endif } // C1138: extended ranges in DOs should be errors, not warnings // 11.1.7.5 void Post(const parser::IoControlSpec &ioControlSpec) { - if (auto *charExpr = - std::get_if(&ioControlSpec.u)) { + if (auto *charExpr{ + std::get_if(&ioControlSpec.u)}) { if (std::get(charExpr->t) == parser::IoControlSpec::CharExpr::Kind::Advance) { messages_.Say(charBlock_, @@ -119,87 +123,49 @@ public: } private: - bool ObjectIsCoarray() { return false; } // placeholder - bool EndTDeallocatesCoarray() { return false; } // placeholder + bool ObjectIsCoarray() { return false; } // placeholder + bool EndTDeallocatesCoarray() { return false; } // placeholder parser::CharBlock charBlock_; parser::Messages &messages_; }; -class DoConcurrentCollection { +// Find a canonical DO CONCURRENT and enforce semantics checks on its body +class FindDoConcurrentLoops { public: - DoConcurrentCollection(parser::Messages &messages) : messages_{messages} {} + FindDoConcurrentLoops(parser::Messages &messages) : messages_{messages} {} template constexpr bool Pre(const T &) { return true; } template constexpr void Post(const T &) {} - bool Pre(const parser::ExecutionPart &executionPart) { - const auto &cend{executionPart.v.cend()}; - for (auto iter{executionPart.v.cbegin()}; iter != cend; ++iter) { - CheckDoConcurrent(iter); - currentIter_ = iter; + template constexpr bool Pre(const parser::Statement &) { + return false; + } + bool Pre(const parser::DoConstruct &doConstruct) { + if (std::get>( + std::get>(doConstruct.t) + .statement.t) + .has_value() && + std::holds_alternative( + std::get>( + std::get>( + doConstruct.t) + .statement.t) + ->u)) { + DoConcurrentEnforcement doConcurrentEnforcement{messages_}; + parser::Walk( + std::get(doConstruct.t), doConcurrentEnforcement); } return true; } - template void Post(const parser::Statement &statement) { - if (!labels_.empty() && statement.label.has_value() && - labels_.back() == *statement.label) { - CheckConstraints(++labelDoIters_.back(), currentIter_); - labels_.pop_back(); - labelDoIters_.pop_back(); - } - } private: - void CheckConstraints(const parser::Block::const_iterator &begin, - const parser::Block::const_iterator &end) { - DoConcurrentEnforcement doConcurrentEnforcement{messages_}; - for (auto iter = begin; iter != end; ++iter) { - Walk(*iter, doConcurrentEnforcement); - } - } - void CheckDoConcurrent( - const std::list::const_iterator &iter) { - const parser::ExecutionPartConstruct &executionPartConstruct{*iter}; - if (auto *executableConstruct = std::get_if( - &executionPartConstruct.u)) { - if (auto *doConstruct = - std::get_if>( - &executableConstruct->u)) { - if (std::get>( - std::get>( - (*doConstruct)->t) - .statement.t) - .has_value()) { - CheckConstraints(std::get((*doConstruct)->t).cbegin(), - std::get((*doConstruct)->t).cend()); - } - } else if (auto *labelDoLoop = std::get_if>>( - &executableConstruct->u)) { - if (std::get>( - labelDoLoop->statement->t) - .has_value() && - std::holds_alternative( - std::get>( - labelDoLoop->statement->t) - ->u)) { - labelDoIters_.push_back(iter); - labels_.push_back(std::get(labelDoLoop->statement->t)); - } - } - } - } - parser::Messages &messages_; - std::vector::const_iterator> - labelDoIters_; - std::list::const_iterator currentIter_; - std::vector labels_; }; +// DO loops must be canonicalized prior to calling void CheckDoConcurrentConstraints( parser::Messages &messages, const parser::Program &program) { - DoConcurrentCollection doConcurrentCollection{messages}; - Walk(program, doConcurrentCollection); + FindDoConcurrentLoops findDoConcurrentLoops{messages}; + Walk(program, findDoConcurrentLoops); } } // namespace Fortran::semantics diff --git a/flang/test/semantics/doconcurrent01.f90 b/flang/test/semantics/doconcurrent01.f90 index 932aa194d0dd..88322bd8acb7 100644 --- a/flang/test/semantics/doconcurrent01.f90 +++ b/flang/test/semantics/doconcurrent01.f90 @@ -15,7 +15,7 @@ ! RUN: ${F18} -funparse-with-symbols %s 2>&1 | ${FileCheck} %s ! CHECK: image control statement not allowed in DO CONCURRENT ! CHECK: RETURN not allowed in DO CONCURRENT -! CHECK: IEEE_GET_FLAG not allowed in DO CONCURRENT +! XXXCHECK: IEEE_GET_FLAG not allowed in DO CONCURRENT ! CHECK: ADVANCE specifier not allowed in DO CONCURRENT ! CHECK: SYNC ALL ! CHECK: SYNC IMAGES @@ -31,6 +31,7 @@ subroutine do_concurrent_test1(i,n) end subroutine do_concurrent_test1 subroutine do_concurrent_test2(i,j,n,flag) + !use ieee_exceptions implicit none integer :: i, j, n, flag, flag2 do concurrent (i = 1:n) diff --git a/flang/test/semantics/doconcurrent02.f90 b/flang/test/semantics/doconcurrent02.f90 new file mode 100644 index 000000000000..f337c467054c --- /dev/null +++ b/flang/test/semantics/doconcurrent02.f90 @@ -0,0 +1,46 @@ +! Copyright (c) 2018, 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. + +! negative tests: we don't want DO CONCURRENT semantics constraints checked +! when the loops are not DO CONCURRENT + +! RUN: ${F18} -funparse-with-symbols %s 2>&1 | ${FileCheck} %s +! CHECK-NOT: image control statement not allowed in DO CONCURRENT +! CHECK-NOT: RETURN not allowed in DO CONCURRENT +! XXXCHECK-NOT: IEEE_GET_FLAG not allowed in DO CONCURRENT +! CHECK-NOT: ADVANCE specifier not allowed in DO CONCURRENT +! CHECK-NOT: SYNC ALL +! CHECK-NOT: SYNC IMAGES + +subroutine do_concurrent_test1(i,n) + implicit none + integer :: i, n + do 10 i = 1,n + SYNC ALL + SYNC IMAGES (*) + return +10 continue +end subroutine do_concurrent_test1 + +subroutine do_concurrent_test2(i,j,n,flag) + !use ieee_exceptions + implicit none + integer :: i, j, n, flag, flag2 + do i = 1,n + change team (j) + call ieee_get_flag(flag, flag2) + end team + write(*,'(a35)',advance='no') + end do +end subroutine do_concurrent_test2