namespace Fortran::semantics {
+class CriticalBodyEnforce {
+public:
+ CriticalBodyEnforce(
+ SemanticsContext &context, parser::CharBlock criticalSourcePosition)
+ : context_{context}, criticalSourcePosition_{criticalSourcePosition} {}
+ std::set<parser::Label> labels() { return labels_; }
+ 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) {
+ currentStatementSourcePosition_ = statement.source;
+ if (statement.label.has_value()) {
+ labels_.insert(*statement.label);
+ }
+ return true;
+ }
+
+ // C1118
+ void Post(const parser::ReturnStmt &) {
+ context_
+ .Say(currentStatementSourcePosition_,
+ "RETURN statement is not allowed in a CRITICAL construct"_err_en_US)
+ .Attach(criticalSourcePosition_, GetEnclosingMsg());
+ }
+ void Post(const parser::ExecutableConstruct &construct) {
+ if (IsImageControlStmt(construct)) {
+ context_
+ .Say(currentStatementSourcePosition_,
+ "An image control statement is not allowed in a CRITICAL"
+ " construct"_err_en_US)
+ .Attach(criticalSourcePosition_, GetEnclosingMsg());
+ }
+ }
+
+private:
+ parser::MessageFixedText GetEnclosingMsg() {
+ return "Enclosing CRITICAL statement"_en_US;
+ }
+
+ SemanticsContext &context_;
+ std::set<parser::Label> labels_;
+ parser::CharBlock currentStatementSourcePosition_;
+ parser::CharBlock criticalSourcePosition_;
+};
+
template<typename T>
static void CheckTeamType(SemanticsContext &context, const T &x) {
if (const auto *expr{GetExpr(x)}) {
CheckTeamType(context_, std::get<parser::TeamVariable>(x.t));
}
+void CoarrayChecker::Enter(const parser::CriticalConstruct &x) {
+ auto &criticalStmt{std::get<parser::Statement<parser::CriticalStmt>>(x.t)};
+
+ const parser::Block &block{std::get<parser::Block>(x.t)};
+ CriticalBodyEnforce criticalBodyEnforce{context_, criticalStmt.source};
+ parser::Walk(block, criticalBodyEnforce);
+
+ // C1119
+ LabelEnforce criticalLabelEnforce{
+ context_, criticalBodyEnforce.labels(), criticalStmt.source, "CRITICAL"};
+ parser::Walk(block, criticalLabelEnforce);
+}
+
// Check that coarray names and selector names are all distinct.
void CoarrayChecker::CheckNamesAreDistinct(
const std::list<parser::CoarrayAssociation> &list) {
context_.Say(name1, std::move(msg1), name1)
.Attach(name2, std::move(msg2), name2);
}
-
}
void Leave(const parser::ImageSelectorSpec &);
void Leave(const parser::FormTeamStmt &);
+ void Enter(const parser::CriticalConstruct &);
+
private:
SemanticsContext &context_;
void Say2(const parser::CharBlock &, parser::MessageFixedText &&,
const parser::CharBlock &, parser::MessageFixedText &&);
};
-
}
#endif // FORTRAN_SEMANTICS_CHECK_COARRAY_H_
: 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 &) {}
}
}
- // C1167 -- EXIT statements can't exit a DO CONCURRENT
- bool Pre(const parser::WhereConstruct &s) {
- AddName(MaybeGetConstructName(s));
- return true;
- }
-
- bool Pre(const parser::ForallConstruct &s) {
- AddName(MaybeGetConstructName(s));
- return true;
- }
-
- bool Pre(const parser::ChangeTeamConstruct &s) {
- AddName(MaybeGetConstructName(s));
- return true;
- }
-
- bool Pre(const parser::CriticalConstruct &s) {
- AddName(MaybeGetConstructName(s));
- return true;
- }
-
- bool Pre(const parser::LabelDoStmt &s) {
- AddName(MaybeGetStmtName(s));
- return true;
- }
-
- bool Pre(const parser::NonLabelDoStmt &s) {
- AddName(MaybeGetStmtName(s));
- return true;
- }
-
- bool Pre(const parser::IfThenStmt &s) {
- AddName(MaybeGetStmtName(s));
- return true;
- }
-
- bool Pre(const parser::SelectCaseStmt &s) {
- AddName(MaybeGetStmtName(s));
- return true;
- }
-
- bool Pre(const parser::SelectRankStmt &s) {
- AddName(MaybeGetStmtName(s));
- return true;
- }
-
- bool Pre(const parser::SelectTypeStmt &s) {
- AddName(MaybeGetStmtName(s));
- return true;
- }
-
// C1136 -- No RETURN statements in a DO CONCURRENT
void Post(const parser::ReturnStmt &) {
context_
return false;
}
- void AddName(const parser::Name *nm) {
- if (nm) {
- names_.insert(nm->source);
- }
- }
-
- std::set<parser::CharBlock> names_;
std::set<parser::Label> labels_;
parser::CharBlock currentStatementSourcePosition_;
SemanticsContext &context_;
parser::CharBlock doConcurrentSourcePosition_;
}; // class DoConcurrentBodyEnforce
-class DoConcurrentLabelEnforce {
-public:
- DoConcurrentLabelEnforce(SemanticsContext &context,
- std::set<parser::Label> &&labels, std::set<parser::CharBlock> &&names,
- parser::CharBlock doConcurrentSourcePosition)
- : context_{context}, labels_{labels}, names_{names},
- doConcurrentSourcePosition_{doConcurrentSourcePosition} {}
- template<typename T> bool Pre(const T &) { return true; }
- template<typename T> bool Pre(const parser::Statement<T> &statement) {
- currentStatementSourcePosition_ = statement.source;
- return true;
- }
-
- template<typename T> void Post(const T &) {}
-
- 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)) {
- checkLabelUse(i);
- }
- }
-
- void Post(const parser::ArithmeticIfStmt &arithmeticIfStmt) {
- checkLabelUse(std::get<1>(arithmeticIfStmt.t));
- checkLabelUse(std::get<2>(arithmeticIfStmt.t));
- checkLabelUse(std::get<3>(arithmeticIfStmt.t));
- }
-
- void Post(const parser::AssignStmt &assignStmt) {
- checkLabelUse(std::get<parser::Label>(assignStmt.t));
- }
-
- void Post(const parser::AssignedGotoStmt &assignedGotoStmt) {
- for (auto &i : std::get<std::list<parser::Label>>(assignedGotoStmt.t)) {
- checkLabelUse(i);
- }
- }
-
- void Post(const parser::AltReturnSpec &altReturnSpec) {
- checkLabelUse(altReturnSpec.v);
- }
-
- 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 checkLabelUse(const parser::Label &labelUsed) {
- if (labels_.find(labelUsed) == labels_.end()) {
- SayWithDo(context_, currentStatementSourcePosition_,
- "Control flow escapes from DO CONCURRENT"_err_en_US,
- doConcurrentSourcePosition_);
- }
- }
-
-private:
- SemanticsContext &context_;
- std::set<parser::Label> labels_;
- std::set<parser::CharBlock> names_;
- parser::CharBlock currentStatementSourcePosition_{nullptr};
- parser::CharBlock doConcurrentSourcePosition_{nullptr};
-}; // class DoConcurrentLabelEnforce
-
// Class for enforcing C1130 -- in a DO CONCURRENT with DEFAULT(NONE),
// variables from enclosing scopes must have their locality specified
class DoConcurrentVariableEnforce {
DoConcurrentBodyEnforce doConcurrentBodyEnforce{context_, doStmt.source};
parser::Walk(block, doConcurrentBodyEnforce);
- DoConcurrentLabelEnforce doConcurrentLabelEnforce{context_,
- doConcurrentBodyEnforce.labels(), doConcurrentBodyEnforce.names(),
- currentStatementSourcePosition_};
+ LabelEnforce doConcurrentLabelEnforce{context_,
+ doConcurrentBodyEnforce.labels(), currentStatementSourcePosition_,
+ "DO CONCURRENT"};
parser::Walk(block, doConcurrentLabelEnforce);
const auto &loopControl{
}
return false;
}
+
+void LabelEnforce::Post(const parser::GotoStmt &gotoStmt) {
+ checkLabelUse(gotoStmt.v);
+}
+void LabelEnforce::Post(const parser::ComputedGotoStmt &computedGotoStmt) {
+ for (auto &i : std::get<std::list<parser::Label>>(computedGotoStmt.t)) {
+ checkLabelUse(i);
+ }
+}
+
+void LabelEnforce::Post(const parser::ArithmeticIfStmt &arithmeticIfStmt) {
+ checkLabelUse(std::get<1>(arithmeticIfStmt.t));
+ checkLabelUse(std::get<2>(arithmeticIfStmt.t));
+ checkLabelUse(std::get<3>(arithmeticIfStmt.t));
+}
+
+void LabelEnforce::Post(const parser::AssignStmt &assignStmt) {
+ checkLabelUse(std::get<parser::Label>(assignStmt.t));
+}
+
+void LabelEnforce::Post(const parser::AssignedGotoStmt &assignedGotoStmt) {
+ for (auto &i : std::get<std::list<parser::Label>>(assignedGotoStmt.t)) {
+ checkLabelUse(i);
+ }
+}
+
+void LabelEnforce::Post(const parser::AltReturnSpec &altReturnSpec) {
+ checkLabelUse(altReturnSpec.v);
+}
+
+void LabelEnforce::Post(const parser::ErrLabel &errLabel) {
+ checkLabelUse(errLabel.v);
+}
+void LabelEnforce::Post(const parser::EndLabel &endLabel) {
+ checkLabelUse(endLabel.v);
+}
+void LabelEnforce::Post(const parser::EorLabel &eorLabel) {
+ checkLabelUse(eorLabel.v);
+}
+
+void LabelEnforce::checkLabelUse(const parser::Label &labelUsed) {
+ if (labels_.find(labelUsed) == labels_.end()) {
+ SayWithConstruct(context_, currentStatementSourcePosition_,
+ parser::MessageFormattedText{
+ "Control flow escapes from %s"_err_en_US, construct_},
+ constructSourcePosition_);
+ }
+}
+
+parser::MessageFormattedText LabelEnforce::GetEnclosingConstructMsg() {
+ return {"Enclosing %s statement"_en_US, construct_};
+}
+
+void LabelEnforce::SayWithConstruct(SemanticsContext &context,
+ parser::CharBlock stmtLocation, parser::MessageFormattedText &&message,
+ parser::CharBlock constructLocation) {
+ context.Say(stmtLocation, message)
+ .Attach(constructLocation, GetEnclosingConstructMsg());
+}
+
}
UltimateComponentIterator::const_iterator
FindPolymorphicAllocatableNonCoarrayUltimateComponent(const DerivedTypeSpec &);
+// The LabelEnforce class (given a set of labels) provides an error message if
+// there is a branch to a label which is not in the given set.
+class LabelEnforce {
+public:
+ LabelEnforce(SemanticsContext &context, std::set<parser::Label> &&labels,
+ parser::CharBlock constructSourcePosition, const char *construct)
+ : context_{context}, labels_{labels},
+ constructSourcePosition_{constructSourcePosition}, construct_{construct} {
+ }
+ template<typename T> bool Pre(const T &) { return true; }
+ template<typename T> bool Pre(const parser::Statement<T> &statement) {
+ currentStatementSourcePosition_ = statement.source;
+ return true;
+ }
+
+ template<typename T> void Post(const T &) {}
+
+ void Post(const parser::GotoStmt &gotoStmt);
+ void Post(const parser::ComputedGotoStmt &computedGotoStmt);
+ void Post(const parser::ArithmeticIfStmt &arithmeticIfStmt);
+ void Post(const parser::AssignStmt &assignStmt);
+ void Post(const parser::AssignedGotoStmt &assignedGotoStmt);
+ void Post(const parser::AltReturnSpec &altReturnSpec);
+ void Post(const parser::ErrLabel &errLabel);
+ void Post(const parser::EndLabel &endLabel);
+ void Post(const parser::EorLabel &eorLabel);
+ void checkLabelUse(const parser::Label &labelUsed);
+
+private:
+ SemanticsContext &context_;
+ std::set<parser::Label> labels_;
+ parser::CharBlock currentStatementSourcePosition_{nullptr};
+ parser::CharBlock constructSourcePosition_{nullptr};
+ const char *construct_{nullptr};
+
+ parser::MessageFormattedText GetEnclosingConstructMsg();
+ void SayWithConstruct(SemanticsContext &context,
+ parser::CharBlock stmtLocation, parser::MessageFormattedText &&message,
+ parser::CharBlock constructLocation);
+};
}
#endif // FORTRAN_SEMANTICS_TOOLS_H_
bindings01.f90
bad-forward-type.f90
c_f_pointer.f90
+ critical01.f90
+ critical02.f90
+ critical03.f90
)
# These test files have expected symbols in the source
canondo*.[Ff]90
)
+set(CRITICAL_TESTS
+ critical04.f90
+)
+
set(GETSYMBOLS_TESTS
getsymbols01.f90
getsymbols02-*.f90
endforeach()
foreach(test ${LABEL_TESTS} ${CANONDO_TESTS} ${DOCONCURRENT_TESTS}
- ${GETSYMBOLS_TESTS} ${GETDEFINITION_TESTS})
+ ${CRITICAL_TESTS} ${GETSYMBOLS_TESTS} ${GETDEFINITION_TESTS})
add_test(NAME ${test}
COMMAND ${CMAKE_CURRENT_SOURCE_DIR}/test_any.sh ${test} ${F18})
endforeach()
--- /dev/null
+!C1117
+
+subroutine test1(a, i)
+ integer i
+ real a(10)
+ one: critical
+ if (a(i) < 0.0) then
+ a(i) = 20.20
+ end if
+ !ERROR: CRITICAL construct name mismatch
+ end critical two
+end subroutine test1
+
+subroutine test2(a, i)
+ integer i
+ real a(10)
+ critical
+ if (a(i) < 0.0) then
+ a(i) = 20.20
+ end if
+ !ERROR: CRITICAL construct name unexpected
+ end critical two
+end subroutine test2
--- /dev/null
+!C1118
+
+subroutine test1
+ critical
+ !ERROR: RETURN statement is not allowed in a CRITICAL construct
+ return
+ end critical
+end subroutine test1
+
+subroutine test2()
+ implicit none
+ critical
+ !ERROR: An image control statement is not allowed in a CRITICAL construct
+ SYNC ALL
+ end critical
+end subroutine test2
+
+subroutine test3()
+ use iso_fortran_env, only: team_type
+ implicit none
+ type(team_type) :: j
+ critical
+ !ERROR: An image control statement is not allowed in a CRITICAL construct
+ sync team (j)
+ end critical
+end subroutine test3
+
+subroutine test4()
+ integer, allocatable, codimension[:] :: ca
+
+ critical
+ !ERROR: An image control statement is not allowed in a CRITICAL construct
+ allocate(ca[*])
+ end critical
+
+ critical
+ !ERROR: An image control statement is not allowed in a CRITICAL construct
+ deallocate(ca)
+ end critical
+end subroutine test4
+
+subroutine test5()
+ use iso_fortran_env, only: team_type
+ implicit none
+ type(team_type) :: j
+ critical
+ change team (j)
+ !ERROR: An image control statement is not allowed in a CRITICAL construct
+ end team
+ end critical
+end subroutine test5
+
+subroutine test6
+ critical
+ critical
+ !ERROR: An image control statement is not allowed in a CRITICAL construct
+ end critical
+ end critical
+end subroutine test6
+
+subroutine test7()
+ use iso_fortran_env
+ type(event_type) :: x, y
+ critical
+ !ERROR: An image control statement is not allowed in a CRITICAL construct
+ event post (x)
+ !ERROR: An image control statement is not allowed in a CRITICAL construct
+ event wait (y)
+ end critical
+end subroutine test7
+
+subroutine test8()
+ use iso_fortran_env
+ type(team_type) :: t
+
+ critical
+ !ERROR: An image control statement is not allowed in a CRITICAL construct
+ form team(1, t)
+ end critical
+end subroutine test8
+
+subroutine test9()
+ use iso_fortran_env
+ type(lock_type) :: l
+
+ critical
+ !ERROR: An image control statement is not allowed in a CRITICAL construct
+ lock(l)
+ !ERROR: An image control statement is not allowed in a CRITICAL construct
+ unlock(l)
+ end critical
+end subroutine test9
+
+subroutine test10()
+ use iso_fortran_env
+ integer, allocatable, codimension[:] :: ca
+ allocate(ca[*])
+
+ critical
+ block
+ integer, allocatable, codimension[:] :: cb
+ cb = ca
+ !TODO: Deallocation of this coarray is not currently caught
+ end block
+ end critical
+end subroutine test10
+
+subroutine test11()
+ integer, allocatable, codimension[:] :: ca, cb
+ critical
+ !ERROR: An image control statement is not allowed in a CRITICAL construct
+ call move_alloc(cb, ca)
+ end critical
+end subroutine test11
+
+subroutine test12()
+ critical
+ !ERROR: An image control statement is not allowed in a CRITICAL construct
+ stop
+ end critical
+end subroutine test12
--- /dev/null
+!C1119
+
+subroutine test1(a, i)
+ integer i
+ real a(10)
+ critical
+ if (a(i) < 0.0) then
+ a(i) = 20.20
+ !ERROR: Control flow escapes from CRITICAL
+ goto 20
+ end if
+ end critical
+20 a(i) = -a(i)
+end subroutine test1
+
+subroutine test2(i)
+ integer i
+ critical
+ !ERROR: Control flow escapes from CRITICAL
+ if (i) 10, 10, 20
+ 10 i = i + 1
+ end critical
+20 i = i - 1
+end subroutine test2
+
+subroutine test3(i)
+ integer i
+ critical
+ !ERROR: Control flow escapes from CRITICAL
+ goto (10, 10, 20) i
+ 10 i = i + 1
+ end critical
+20 i = i - 1
+end subroutine test3
--- /dev/null
+! RUN: ${F18} -funparse-with-symbols %s 2>&1 | ${FileCheck} %s
+! CHECK-NOT: Control flow escapes from CRITICAL
+
+subroutine test1(a, i)
+ integer i
+ real a(10)
+ critical
+ if (a(i) < 0.0) then
+ a(i) = 20.20
+ goto 20
+ end if
+20 a(i) = -a(i)
+ end critical
+end subroutine test1
+
+subroutine test2(i)
+ integer i
+ critical
+ if (i) 10, 10, 20
+10 i = i + 1
+20 i = i - 1
+ end critical
+end subroutine test2
+
+subroutine test3(i)
+ integer i
+ critical
+ goto (10, 10, 20) i
+10 i = i + 1
+20 i = i - 1
+ end critical
+end subroutine test3
projects / platform / upstream / llvm.git / commitdiff