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(
.statement.v);
}
-// Return the (possibly null) name of the statement
-template<typename A> static const parser::Name *MaybeGetStmtName(const A &a) {
- return common::GetPtrFromOptional(std::get<0>(a.t));
+static void SayWithDo(SemanticsContext &context, parser::CharBlock stmtLocation,
+ parser::MessageFixedText &&message, parser::CharBlock doLocation) {
+ context.Say(stmtLocation, message).Attach(doLocation, GetEnclosingDoMsg());
}
// 11.1.7.5 - enforce semantics constraints on a DO CONCURRENT loop body
class DoConcurrentBodyEnforce {
public:
- DoConcurrentBodyEnforce(SemanticsContext &context) : context_{context} {}
+ DoConcurrentBodyEnforce(
+ SemanticsContext &context, parser::CharBlock doConcurrentSourcePosition)
+ : context_{context}, doConcurrentSourcePosition_{
+ doConcurrentSourcePosition} {}
std::set<parser::Label> labels() { return labels_; }
std::set<SourceName> names() { return names_; }
template<typename T> bool Pre(const T &) { return true; }
template<typename T> void Post(const T &) {}
+
+ // C1137 -- No image control statements in a DO CONCURRENT
+ void Post(const parser::ExecutableConstruct &construct) {
+ if (IsImageControlStmt(construct)) {
+ const parser::CharBlock statementLocation{
+ GetImageControlStmtLocation(construct)};
+ auto &msg{context_.Say(statementLocation,
+ "An image control statement is not allowed in DO"
+ " CONCURRENT"_err_en_US)};
+ if (auto coarrayMsg{GetImageControlStmtCoarrayMsg(construct)}) {
+ msg.Attach(statementLocation, *coarrayMsg);
+ }
+ msg.Attach(doConcurrentSourcePosition_, GetEnclosingDoMsg());
+ }
+ }
+
template<typename T> bool Pre(const parser::Statement<T> &statement) {
currentStatementSourcePosition_ = statement.source;
if (statement.label.has_value()) {
return true;
}
- // C1167
+ // C1167 -- EXIT statements can't exit a DO CONCURRENT
bool Pre(const parser::WhereConstruct &s) {
AddName(MaybeGetConstructName(s));
return true;
return true;
}
- // C1136
+ // C1136 -- No RETURN statements in a DO CONCURRENT
void Post(const parser::ReturnStmt &) {
- context_.Say(currentStatementSourcePosition_,
- "RETURN not allowed in DO CONCURRENT"_err_en_US);
- }
-
- // C1137
- void NoImageControl() {
- context_.Say(currentStatementSourcePosition_,
- "image control statement not allowed in DO CONCURRENT"_err_en_US);
- }
-
- // more C1137 checks
- void Post(const parser::SyncAllStmt &) { NoImageControl(); }
- void Post(const parser::SyncImagesStmt &) { NoImageControl(); }
- void Post(const parser::SyncMemoryStmt &) { NoImageControl(); }
- void Post(const parser::SyncTeamStmt &) { NoImageControl(); }
- void Post(const parser::ChangeTeamConstruct &) { NoImageControl(); }
- void Post(const parser::CriticalConstruct &) { NoImageControl(); }
- void Post(const parser::EventPostStmt &) { NoImageControl(); }
- void Post(const parser::EventWaitStmt &) { NoImageControl(); }
- void Post(const parser::FormTeamStmt &) { NoImageControl(); }
- void Post(const parser::LockStmt &) { NoImageControl(); }
- void Post(const parser::UnlockStmt &) { NoImageControl(); }
- void Post(const parser::StopStmt &) { NoImageControl(); }
-
- // more C1137 checks
- void Post(const parser::AllocateStmt &allocateStmt) {
- CheckDoesntContainCoarray(allocateStmt);
- }
-
- void Post(const parser::DeallocateStmt &deallocateStmt) {
- CheckDoesntContainCoarray(deallocateStmt); // C1137
-
- // C1140: deallocation of polymorphic objects
- if (anyObjectIsPolymorphic()) {
- context_.Say(currentStatementSourcePosition_,
- "DEALLOCATE polymorphic object(s) not allowed"
- " in DO CONCURRENT"_err_en_US);
- }
- }
-
- template<typename T> void Post(const parser::Statement<T> &) {
- if (EndTDeallocatesCoarray()) {
- context_.Say(currentStatementSourcePosition_,
- "implicit deallocation of coarray not allowed"
- " in DO CONCURRENT"_err_en_US);
- }
+ context_
+ .Say(currentStatementSourcePosition_,
+ "RETURN is not allowed in DO CONCURRENT"_err_en_US)
+ .Attach(doConcurrentSourcePosition_, GetEnclosingDoMsg());
}
+ // C1139: call to impure procedure and ...
// C1141: cannot call ieee_get_flag, ieee_[gs]et_halting_mode
+ // It's not necessary to check the ieee_get* procedures because they're
+ // not pure, and impure procedures are caught by checks for constraint C1139
void Post(const parser::ProcedureDesignator &procedureDesignator) {
if (auto *name{std::get_if<parser::Name>(&procedureDesignator.u)}) {
- // C1137: call move_alloc with coarray arguments
- if (name->source == "move_alloc") {
- if (anyObjectIsCoarray()) {
- context_.Say(currentStatementSourcePosition_,
- "call to MOVE_ALLOC intrinsic in DO CONCURRENT with coarray"
- " argument(s) not allowed"_err_en_US);
- }
- }
- // C1139: call to impure procedure
if (name->symbol && !IsPureProcedure(*name->symbol)) {
- context_.Say(currentStatementSourcePosition_,
- "call to impure procedure in DO CONCURRENT not allowed"_err_en_US);
+ SayWithDo(context_, currentStatementSourcePosition_,
+ "Call to an impure procedure is not allowed in DO"
+ " CONCURRENT"_err_en_US,
+ doConcurrentSourcePosition_);
}
if (name->symbol && fromScope(*name->symbol, "ieee_exceptions"s)) {
- if (name->source == "ieee_get_flag") {
- context_.Say(currentStatementSourcePosition_,
- "IEEE_GET_FLAG not allowed in DO CONCURRENT"_err_en_US);
- } else if (name->source == "ieee_set_halting_mode") {
- context_.Say(currentStatementSourcePosition_,
- "IEEE_SET_HALTING_MODE not allowed in DO CONCURRENT"_err_en_US);
- } else if (name->source == "ieee_get_halting_mode") {
- context_.Say(currentStatementSourcePosition_,
- "IEEE_GET_HALTING_MODE not allowed in DO CONCURRENT"_err_en_US);
+ if (name->source == "ieee_set_halting_mode") {
+ SayWithDo(context_, currentStatementSourcePosition_,
+ "IEEE_SET_HALTING_MODE is not allowed in DO "
+ "CONCURRENT"_err_en_US,
+ doConcurrentSourcePosition_);
}
}
} else {
- // C1139: this a procedure component
+ // C1139: check for an impure procedure component
auto &component{std::get<parser::ProcComponentRef>(procedureDesignator.u)
.v.thing.component};
if (component.symbol && !IsPureProcedure(*component.symbol)) {
- context_.Say(currentStatementSourcePosition_,
- "call to impure procedure in DO CONCURRENT not allowed"_err_en_US);
+ SayWithDo(context_, currentStatementSourcePosition_,
+ "Call to an impure procedure component is not allowed"
+ " in DO CONCURRENT"_err_en_US,
+ doConcurrentSourcePosition_);
}
}
}
- // 11.1.7.5
+ // 11.1.7.5, paragraph 5, no ADVANCE specifier in a DO CONCURRENT
void Post(const parser::IoControlSpec &ioControlSpec) {
if (auto *charExpr{
std::get_if<parser::IoControlSpec::CharExpr>(&ioControlSpec.u)}) {
if (std::get<parser::IoControlSpec::CharExpr::Kind>(charExpr->t) ==
parser::IoControlSpec::CharExpr::Kind::Advance) {
- context_.Say(currentStatementSourcePosition_,
- "ADVANCE specifier not allowed in DO CONCURRENT"_err_en_US);
+ SayWithDo(context_, currentStatementSourcePosition_,
+ "ADVANCE specifier is not allowed in DO"
+ " CONCURRENT"_err_en_US,
+ doConcurrentSourcePosition_);
}
}
}
private:
- // C1137 helper functions
- void CheckAllocateObjectIsntCoarray(
- const parser::AllocateObject &allocateObject, StmtType stmtType) {
- const parser::Name &name{GetLastName(allocateObject)};
- if (name.symbol && IsCoarray(*name.symbol)) {
- context_.Say(name.source,
- "%s coarray not allowed in DO CONCURRENT"_err_en_US,
- EnumToString(stmtType));
- }
+ // Return the (possibly null) name of the statement
+ template<typename A> static const parser::Name *MaybeGetStmtName(const A &a) {
+ return common::GetPtrFromOptional(std::get<0>(a.t));
}
- void CheckDoesntContainCoarray(const parser::AllocateStmt &allocateStmt) {
- const auto &allocationList{
- std::get<std::list<parser::Allocation>>(allocateStmt.t)};
- for (const auto &allocation : allocationList) {
- const auto &allocateObject{
- std::get<parser::AllocateObject>(allocation.t)};
- CheckAllocateObjectIsntCoarray(allocateObject, StmtType::ALLOCATE);
- }
- }
-
- void CheckDoesntContainCoarray(const parser::DeallocateStmt &deallocateStmt) {
- const auto &allocateObjectList{
- std::get<std::list<parser::AllocateObject>>(deallocateStmt.t)};
- for (const auto &allocateObject : allocateObjectList) {
- CheckAllocateObjectIsntCoarray(allocateObject, StmtType::DEALLOCATE);
- }
- }
-
- bool anyObjectIsCoarray() { return false; } // FIXME placeholder
bool anyObjectIsPolymorphic() { return false; } // FIXME placeholder
- bool EndTDeallocatesCoarray() { return false; } // FIXME placeholder
bool fromScope(const Symbol &symbol, const std::string &moduleName) {
if (symbol.GetUltimate().owner().IsModule() &&
symbol.GetUltimate().owner().GetName().value().ToString() ==
std::set<parser::Label> labels_;
parser::CharBlock currentStatementSourcePosition_;
SemanticsContext &context_;
+ parser::CharBlock doConcurrentSourcePosition_;
}; // class DoConcurrentBodyEnforce
class DoConcurrentLabelEnforce {
void checkLabelUse(const parser::Label &labelUsed) {
if (labels_.find(labelUsed) == labels_.end()) {
- context_.Say(currentStatementSourcePosition_,
- "control flow escapes from DO CONCURRENT"_err_en_US);
+ SayWithDo(context_, currentStatementSourcePosition_,
+ "Control flow escapes from DO CONCURRENT"_err_en_US,
+ doConcurrentSourcePosition_);
}
}
parser::CharBlock doConcurrentSourcePosition_{nullptr};
}; // class DoConcurrentLabelEnforce
-// Class for enforcing C1130
+// Class for enforcing C1130 -- in a DO CONCURRENT with DEFAULT(NONE),
+// variables from enclosing scopes must have their locality specified
class DoConcurrentVariableEnforce {
public:
DoConcurrentVariableEnforce(
if (IsVariableName(*symbol)) {
const Scope &variableScope{symbol->owner()};
if (DoesScopeContain(&variableScope, blockScope_)) {
- context_.Say(name.source,
- "Variable '%s' from an enclosing scope referenced in a DO "
- "CONCURRENT with DEFAULT(NONE) must appear in a "
- "locality-spec"_err_en_US,
- name.source);
+ context_
+ .Say(name.source,
+ "Variable '%s' from an enclosing scope referenced in a DO "
+ "CONCURRENT with DEFAULT(NONE) must appear in a "
+ "locality-spec"_err_en_US,
+ name.source)
+ .Attach(symbol->name(), "Declaration of variable '%s'"_en_US,
+ symbol->name());
}
}
}
}
void CheckDoNormal(const parser::DoConstruct &doConstruct) {
- // C1120 extended by allowing REAL and DOUBLE PRECISION
- // Get the bounds, then check the variable, init, final, and step
+ // C1120 -- types of DO variables must be INTEGER, extended by allowing
+ // REAL and DOUBLE PRECISION
const Bounds &bounds{GetBounds(doConstruct)};
CheckDoVariable(bounds.name);
CheckDoExpression(bounds.lower);
currentStatementSourcePosition_ = doStmt.source;
const parser::Block &block{std::get<parser::Block>(doConstruct.t)};
- DoConcurrentBodyEnforce doConcurrentBodyEnforce{context_};
+ DoConcurrentBodyEnforce doConcurrentBodyEnforce{context_, doStmt.source};
parser::Walk(block, doConcurrentBodyEnforce);
DoConcurrentLabelEnforce doConcurrentLabelEnforce{context_,
const parser::CharBlock &name{ref->name()};
context_
.Say(currentStatementSourcePosition_,
- "concurrent-header mask expression cannot reference an impure"
+ "Concurrent-header mask expression cannot reference an impure"
" procedure"_err_en_US)
.Attach(name, "Declaration of impure procedure '%s'"_en_US, name);
return;
mask.thing.thing.value().source);
}
- // C1129, names in local locality-specs can't be in limit or step expressions
+ // C1129, names in local locality-specs can't be in limit or step
+ // expressions
void CheckExprDoesNotReferenceLocal(
const parser::ScalarIntExpr &expr, const SymbolSet &localVars) const {
CheckNoCollisions(GatherSymbolsFromExpression(expr.thing.thing.value()),
expr.thing.thing.value().source);
}
- // C1130, default(none) locality requires names to be in locality-specs to be
- // used in the body of the DO loop
+ // C1130, DEFAULT(NONE) locality requires names to be in locality-specs to
+ // be used in the body of the DO loop
void CheckDefaultNoneImpliesExplicitLocality(
const std::list<parser::LocalitySpec> &localitySpecs,
const parser::Block &block) const {
if (hasDefaultNone) {
// C1127, you can only have one DEFAULT(NONE)
context_.Say(currentStatementSourcePosition_,
- "only one DEFAULT(NONE) may appear"_en_US);
+ "Only one DEFAULT(NONE) may appear"_en_US);
break;
}
hasDefaultNone = true;
common::visitors{
[&](const parser::DoConstruct *doConstructPtr) {
if (doConstructPtr->IsDoConcurrent()) {
- // C1135 and C1167
+ // C1135 and C1167 -- CYCLE and EXIT statements can't leave a
+ // DO CONCURRENT
SayBadLeave(stmtType, "DO CONCURRENT", construct);
}
},
[&](const parser::CriticalConstruct *) {
- // C1135 and C1168
+ // C1135 and C1168 -- similarly, for CRITICAL
SayBadLeave(stmtType, "CRITICAL", construct);
},
[&](const parser::ChangeTeamConstruct *) {
- // C1135 and C1168
+ // C1135 and C1168 -- similarly, for CHANGE TEAM
SayBadLeave(stmtType, "CHANGE TEAM", construct);
},
[](const auto *) {},
}
}
-// 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.
+// 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(
StmtType stmtType, const parser::Name *stmtName) const {
const ConstructStack &stack{context_.constructStack()};
}
}
-// C1135
+// C1135 -- Nesting for CYCLE statements
void DoChecker::Enter(const parser::CycleStmt &cycleStmt) {
CheckNesting(StmtType::CYCLE, common::GetPtrFromOptional(cycleStmt.v));
}
-// C1167 and C1168
+// C1167 and C1168 -- Nesting for EXIT statements
void DoChecker::Enter(const parser::ExitStmt &exitStmt) {
CheckNesting(StmtType::EXIT, common::GetPtrFromOptional(exitStmt.v));
}
#include "../common/indirection.h"
#include "../parser/message.h"
#include "../parser/parse-tree.h"
+#include "../parser/tools.h"
#include <algorithm>
#include <set>
#include <variant>
return {};
}
+struct ImageControlStmtHelper {
+ using ImageControlStmts = std::variant<parser::ChangeTeamConstruct,
+ parser::CriticalConstruct, parser::EventPostStmt, parser::EventWaitStmt,
+ parser::FormTeamStmt, parser::LockStmt, parser::StopStmt,
+ parser::SyncAllStmt, parser::SyncImagesStmt, parser::SyncMemoryStmt,
+ parser::SyncTeamStmt, parser::UnlockStmt>;
+ template<typename T> bool operator()(const T &) {
+ return common::HasMember<T, ImageControlStmts>;
+ }
+ template<typename T> bool operator()(const common::Indirection<T> &x) {
+ return (*this)(x.value());
+ }
+ bool IsCoarrayObject(const parser::AllocateObject &allocateObject) {
+ const parser::Name &name{GetLastName(allocateObject)};
+ return name.symbol && IsCoarray(*name.symbol);
+ }
+ bool operator()(const parser::AllocateStmt &stmt) {
+ const auto &allocationList{std::get<std::list<parser::Allocation>>(stmt.t)};
+ for (const auto &allocation : allocationList) {
+ const auto &allocateObject{
+ std::get<parser::AllocateObject>(allocation.t)};
+ if (IsCoarrayObject(allocateObject)) {
+ return true;
+ }
+ }
+ return false;
+ }
+ bool operator()(const parser::DeallocateStmt &stmt) {
+ const auto &allocateObjectList{
+ std::get<std::list<parser::AllocateObject>>(stmt.t)};
+ for (const auto &allocateObject : allocateObjectList) {
+ if (IsCoarrayObject(allocateObject)) {
+ return true;
+ }
+ }
+ return false;
+ }
+ bool operator()(const parser::CallStmt &stmt) {
+ const auto &procedureDesignator{
+ std::get<parser::ProcedureDesignator>(stmt.v.t)};
+ if (auto *name{std::get_if<parser::Name>(&procedureDesignator.u)}) {
+ // TODO: also ensure that the procedure is, in fact, an intrinsic
+ if (name->source == "move_alloc") {
+ const auto &args{std::get<std::list<parser::ActualArgSpec>>(stmt.v.t)};
+ if (!args.empty()) {
+ const parser::ActualArg &actualArg{
+ std::get<parser::ActualArg>(args.front().t)};
+ if (const auto *argExpr{
+ std::get_if<common::Indirection<parser::Expr>>(
+ &actualArg.u)}) {
+ return HasCoarray(argExpr->value());
+ }
+ }
+ }
+ }
+ return false;
+ }
+ bool operator()(const parser::Statement<parser::ActionStmt> &stmt) {
+ return std::visit(*this, stmt.statement.u);
+ }
+};
+
+bool IsImageControlStmt(const parser::ExecutableConstruct &construct) {
+ return std::visit(ImageControlStmtHelper{}, construct.u);
+}
+
+std::optional<parser::MessageFixedText> GetImageControlStmtCoarrayMsg(
+ const parser::ExecutableConstruct &construct) {
+ if (const auto *actionStmt{
+ std::get_if<parser::Statement<parser::ActionStmt>>(&construct.u)}) {
+ return std::visit(
+ common::visitors{
+ [](const common::Indirection<parser::AllocateStmt> &)
+ -> std::optional<parser::MessageFixedText> {
+ return "ALLOCATE of a coarray is an image control"
+ " statement"_en_US;
+ },
+ [](const common::Indirection<parser::DeallocateStmt> &)
+ -> std::optional<parser::MessageFixedText> {
+ return "DEALLOCATE of a coarray is an image control"
+ " statement"_en_US;
+ },
+ [](const common::Indirection<parser::CallStmt> &)
+ -> std::optional<parser::MessageFixedText> {
+ return "MOVE_ALLOC of a coarray is an image control"
+ " statement "_en_US;
+ },
+ [](const auto &) -> std::optional<parser::MessageFixedText> {
+ return std::nullopt;
+ },
+ },
+ actionStmt->statement.u);
+ }
+ return std::nullopt;
+}
+
+const parser::CharBlock GetImageControlStmtLocation(
+ const parser::ExecutableConstruct &executableConstruct) {
+ return std::visit(
+ common::visitors{
+ [](const common::Indirection<parser::ChangeTeamConstruct>
+ &construct) {
+ return std::get<parser::Statement<parser::ChangeTeamStmt>>(
+ construct.value().t)
+ .source;
+ },
+ [](const common::Indirection<parser::CriticalConstruct> &construct) {
+ return std::get<parser::Statement<parser::CriticalStmt>>(
+ construct.value().t)
+ .source;
+ },
+ [](const parser::Statement<parser::ActionStmt> &actionStmt) {
+ return actionStmt.source;
+ },
+ [](const auto &) { return parser::CharBlock{}; },
+ },
+ executableConstruct.u);
+}
+
+bool HasCoarray(const parser::Expr &expression) {
+ if (const auto *expr{GetExpr(expression)}) {
+ for (const Symbol *symbol : evaluate::CollectSymbols(*expr)) {
+ if (const Symbol * root{GetAssociationRoot(DEREF(symbol))}) {
+ if (IsCoarray(*root)) {
+ return true;
+ }
+ }
+ }
+ }
+ return false;
+}
+
static const DeclTypeSpec &InstantiateIntrinsicType(Scope &scope,
const DeclTypeSpec &spec, SemanticsContext &semanticsContext) {
const IntrinsicTypeSpec *intrinsic{spec.AsIntrinsic()};
template<ComponentKind componentKind>
void ComponentIterator<componentKind>::const_iterator::Increment() {
std::int64_t level{static_cast<std::int64_t>(componentPath_.size()) - 1};
- // Need to know if this is the first incrementation or if the visit is resumed
- // after a user increment.
+ // Need to know if this is the first incrementation or if the visit is
+ // resumed after a user increment.
ComponentVisitState state{
level >= 0 && GetComponentSymbol(componentPath_[level])
? ComponentVisitState::Resume
! limitations under the License.
!
! C1141
-! A reference to the procedure IEEE_GET_FLAG, IEEE_SET_HALTING_MODE, or
-! IEEE_GET_HALTING_MODE from the intrinsic module IEEE_EXCEPTIONS, shall not
-! appear within a DO CONCURRENT construct.
+! A reference to the procedure IEEE_SET_HALTING_MODE ! from the intrinsic
+! module IEEE_EXCEPTIONS, shall not ! appear within a DO CONCURRENT construct.
!
! C1137
! An image control statement shall not appear within a DO CONCURRENT construct.
implicit none
integer :: i, n
do 10 concurrent (i = 1:n)
-!ERROR: image control statement not allowed in DO CONCURRENT
+!ERROR: An image control statement is not allowed in DO CONCURRENT
SYNC ALL
-!ERROR: image control statement not allowed in DO CONCURRENT
+!ERROR: An image control statement is not allowed in DO CONCURRENT
SYNC IMAGES (*)
-!ERROR: image control statement not allowed in DO CONCURRENT
+!ERROR: An image control statement is not allowed in DO CONCURRENT
SYNC MEMORY
-!ERROR: RETURN not allowed in DO CONCURRENT
+!ERROR: RETURN is not allowed in DO CONCURRENT
return
10 continue
end subroutine do_concurrent_test1
logical :: flagValue, halting
type(team_type) :: j
do concurrent (i = 1:n)
-!ERROR: image control statement not allowed in DO CONCURRENT
+!ERROR: An image control statement is not allowed in DO CONCURRENT
sync team (j)
+!ERROR: An image control statement is not allowed in DO CONCURRENT
change team (j)
+!ERROR: An image control statement is not allowed in DO CONCURRENT
critical
-!ERROR: call to impure procedure in DO CONCURRENT not allowed
-!ERROR: IEEE_GET_FLAG not allowed in DO CONCURRENT
+!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
call ieee_get_flag(flag, flagValue)
-!ERROR: call to impure procedure in DO CONCURRENT not allowed
-!ERROR: IEEE_GET_HALTING_MODE not allowed in DO CONCURRENT
+!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
call ieee_get_halting_mode(flag, halting)
-!ERROR: IEEE_SET_HALTING_MODE not allowed in DO CONCURRENT
+!ERROR: IEEE_SET_HALTING_MODE is not allowed in DO CONCURRENT
call ieee_set_halting_mode(flag, halting)
-!ERROR: image control statement not allowed in DO CONCURRENT
end critical
-!ERROR: image control statement not allowed in DO CONCURRENT
end team
-!ERROR: ADVANCE specifier not allowed in DO CONCURRENT
+!ERROR: ADVANCE specifier is not allowed in DO CONCURRENT
write(*,'(a35)',advance='no')
end do
+
+! The following is OK
+ do concurrent (i = 1:n)
+ call ieee_set_flag(flag, flagValue)
+ end do
end subroutine do_concurrent_test2
subroutine s1()
use iso_fortran_env
type(event_type) :: x
do concurrent (i = 1:n)
-!ERROR: image control statement not allowed in DO CONCURRENT
+!ERROR: An image control statement is not allowed in DO CONCURRENT
event post (x)
end do
end subroutine s1
use iso_fortran_env
type(event_type) :: x
do concurrent (i = 1:n)
-!ERROR: image control statement not allowed in DO CONCURRENT
+!ERROR: An image control statement is not allowed in DO CONCURRENT
event wait (x)
end do
end subroutine s2
type(team_type) :: t
do concurrent (i = 1:n)
-!ERROR: image control statement not allowed in DO CONCURRENT
+!ERROR: An image control statement is not allowed in DO CONCURRENT
form team(1, t)
end do
end subroutine s3
type(lock_type) :: l
do concurrent (i = 1:n)
-!ERROR: image control statement not allowed in DO CONCURRENT
+!ERROR: An image control statement is not allowed in DO CONCURRENT
lock(l)
-!ERROR: image control statement not allowed in DO CONCURRENT
+!ERROR: An image control statement is not allowed in DO CONCURRENT
unlock(l)
end do
end subroutine s4
subroutine s5()
- use iso_fortran_env
- type(lock_type) :: l
-
do concurrent (i = 1:n)
-!ERROR: image control statement not allowed in DO CONCURRENT
- lock(l)
-!ERROR: image control statement not allowed in DO CONCURRENT
- unlock(l)
+!ERROR: An image control statement is not allowed in DO CONCURRENT
+ stop
end do
end subroutine s5
type(type0) :: type1_field
end type
- type(type1), allocatable :: pvar;
- type(type1), allocatable :: qvar;
+ type(type1) :: pvar;
+ type(type1) :: qvar;
integer, allocatable, dimension(:) :: array1
integer, allocatable, dimension(:) :: array2
- integer, allocatable, codimension[*] :: ca
+ integer, allocatable, codimension[*] :: ca, cb
+ integer, allocatable :: aa, ab
! All of the following are allowable outside a DO CONCURRENT
- allocate(pvar)
allocate(array1(3), pvar%type1_field%type0_field(3), array2(9))
allocate(pvar%type1_field%coarray_type0_field(3)[*])
allocate(ca[*])
- allocate(pvar, ca[*], qvar, pvar%type1_field%coarray_type0_field(3)[*])
+ allocate(ca[*], pvar%type1_field%coarray_type0_field(3)[*])
do concurrent (i = 1:10)
- allocate(pvar%type1_field%type0_field(3))
+ allocate(pvar%type1_field%type0_field(3))
end do
do concurrent (i = 1:10)
-!ERROR: ALLOCATE coarray not allowed in DO CONCURRENT
+!ERROR: An image control statement is not allowed in DO CONCURRENT
allocate(ca[*])
end do
do concurrent (i = 1:10)
-!ERROR: DEALLOCATE coarray not allowed in DO CONCURRENT
+!ERROR: An image control statement is not allowed in DO CONCURRENT
deallocate(ca)
end do
do concurrent (i = 1:10)
-!ERROR: ALLOCATE coarray not allowed in DO CONCURRENT
- allocate(pvar%type1_field%coarray_type0_field(3)[*])
+!ERROR: An image control statement is not allowed in DO CONCURRENT
+ allocate(pvar%type1_field%coarray_type0_field(3)[*])
end do
do concurrent (i = 1:10)
-!ERROR: DEALLOCATE coarray not allowed in DO CONCURRENT
- deallocate(pvar%type1_field%coarray_type0_field)
+!ERROR: An image control statement is not allowed in DO CONCURRENT
+ deallocate(pvar%type1_field%coarray_type0_field)
end do
do concurrent (i = 1:10)
-!ERROR: ALLOCATE coarray not allowed in DO CONCURRENT
-!ERROR: ALLOCATE coarray not allowed in DO CONCURRENT
- allocate(pvar, ca[*], qvar, pvar%type1_field%coarray_type0_field(3)[*])
+!ERROR: An image control statement is not allowed in DO CONCURRENT
+ allocate(ca[*], pvar%type1_field%coarray_type0_field(3)[*])
+ end do
+
+ do concurrent (i = 1:10)
+!ERROR: An image control statement is not allowed in DO CONCURRENT
+ deallocate(ca, pvar%type1_field%coarray_type0_field)
+ end do
+
+! Call to MOVE_ALLOC of a coarray outside a DO CONCURRENT. This is OK.
+call move_alloc(ca, cb)
+
+! Note that the errors below relating to MOVE_ALLOC() bing impure are bogus.
+! They're the result of the fact that access to the move_alloc() instrinsic
+! is not yet possible.
+
+ allocate(aa)
+ do concurrent (i = 1:10)
+!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
+ call move_alloc(aa, ab)
+ end do
+
+! Call to MOVE_ALLOC with non-coarray arguments in a DO CONCURRENT. This is OK.
+
+ do concurrent (i = 1:10)
+!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
+!ERROR: An image control statement is not allowed in DO CONCURRENT
+ call move_alloc(ca, cb)
end do
do concurrent (i = 1:10)
-!ERROR: DEALLOCATE coarray not allowed in DO CONCURRENT
-!ERROR: DEALLOCATE coarray not allowed in DO CONCURRENT
- deallocate(pvar, ca, qvar, pvar%type1_field%coarray_type0_field)
+!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
+!ERROR: An image control statement is not allowed in DO CONCURRENT
+ call move_alloc(pvar%type1_field%coarray_type0_field, qvar%type1_field%coarray_type0_field)
end do
end subroutine s6
projects / platform / upstream / llvm.git / commitdiff