465 lines · cpp
1//===-- lib/Semantics/check-coarray.cpp -----------------------------------===//2//3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.4// See https://llvm.org/LICENSE.txt for license information.5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception6//7//===----------------------------------------------------------------------===//8 9#include "check-coarray.h"10#include "definable.h"11#include "flang/Common/indirection.h"12#include "flang/Evaluate/expression.h"13#include "flang/Parser/message.h"14#include "flang/Parser/parse-tree.h"15#include "flang/Parser/tools.h"16#include "flang/Semantics/expression.h"17#include "flang/Semantics/tools.h"18 19namespace Fortran::semantics {20 21class CriticalBodyEnforce {22public:23 CriticalBodyEnforce(24 SemanticsContext &context, parser::CharBlock criticalSourcePosition)25 : context_{context}, criticalSourcePosition_{criticalSourcePosition} {}26 std::set<parser::Label> labels() { return labels_; }27 template <typename T> bool Pre(const T &) { return true; }28 template <typename T> void Post(const T &) {}29 30 template <typename T> bool Pre(const parser::Statement<T> &statement) {31 currentStatementSourcePosition_ = statement.source;32 if (statement.label.has_value()) {33 labels_.insert(*statement.label);34 }35 return true;36 }37 38 // C111839 void Post(const parser::ReturnStmt &) {40 context_41 .Say(currentStatementSourcePosition_,42 "RETURN statement is not allowed in a CRITICAL construct"_err_en_US)43 .Attach(criticalSourcePosition_, GetEnclosingMsg());44 }45 void Post(const parser::ExecutableConstruct &construct) {46 if (IsImageControlStmt(construct)) {47 context_48 .Say(currentStatementSourcePosition_,49 "An image control statement is not allowed in a CRITICAL"50 " construct"_err_en_US)51 .Attach(criticalSourcePosition_, GetEnclosingMsg());52 }53 }54 55private:56 parser::MessageFixedText GetEnclosingMsg() {57 return "Enclosing CRITICAL statement"_en_US;58 }59 60 SemanticsContext &context_;61 std::set<parser::Label> labels_;62 parser::CharBlock currentStatementSourcePosition_;63 parser::CharBlock criticalSourcePosition_;64};65 66class ChangeTeamBodyEnforce {67public:68 ChangeTeamBodyEnforce(69 SemanticsContext &context, parser::CharBlock changeTeamSourcePosition)70 : context_{context}, changeTeamSourcePosition_{changeTeamSourcePosition} {71 }72 std::set<parser::Label> labels() { return labels_; }73 template <typename T> bool Pre(const T &) { return true; }74 template <typename T> void Post(const T &) {}75 76 template <typename T> bool Pre(const parser::Statement<T> &statement) {77 currentStatementSourcePosition_ = statement.source;78 if (statement.label.has_value()) {79 labels_.insert(*statement.label);80 }81 return true;82 }83 84 void Post(const parser::ReturnStmt &) {85 context_86 .Say(currentStatementSourcePosition_,87 "RETURN statement is not allowed in a CHANGE TEAM construct"_err_en_US)88 .Attach(89 changeTeamSourcePosition_, "Enclosing CHANGE TEAM construct"_en_US);90 }91 92private:93 SemanticsContext &context_;94 std::set<parser::Label> labels_;95 parser::CharBlock currentStatementSourcePosition_;96 parser::CharBlock changeTeamSourcePosition_;97};98 99template <typename T>100static void CheckTeamType(101 SemanticsContext &context, const T &x, bool mustBeVariable = false) {102 if (const auto *expr{GetExpr(context, x)}) {103 if (!IsTeamType(evaluate::GetDerivedTypeSpec(expr->GetType()))) {104 context.Say(parser::FindSourceLocation(x), // C1114105 "Team value must be of type TEAM_TYPE from module ISO_FORTRAN_ENV"_err_en_US);106 } else if (mustBeVariable && !IsVariable(*expr)) {107 context.Say(parser::FindSourceLocation(x),108 "Team must be a variable in this context"_err_en_US);109 }110 }111}112 113static void CheckTeamStat(114 SemanticsContext &context, const parser::ImageSelectorSpec::Stat &stat) {115 const auto &var{parser::UnwrapRef<parser::Variable>(stat)};116 if (parser::GetCoindexedNamedObject(var)) {117 context.Say(parser::FindSourceLocation(var), // C931118 "Image selector STAT variable must not be a coindexed "119 "object"_err_en_US);120 }121}122 123static void CheckCoindexedStatOrErrmsg(SemanticsContext &context,124 const parser::StatOrErrmsg &statOrErrmsg, const std::string &listName) {125 auto CoindexedCheck{[&](const auto &statOrErrmsg) {126 if (const auto *expr{GetExpr(context, statOrErrmsg)}) {127 if (ExtractCoarrayRef(expr)) {128 context.Say(parser::FindSourceLocation(statOrErrmsg), // C1173129 "The stat-variable or errmsg-variable in a %s may not be a coindexed object"_err_en_US,130 listName);131 }132 }133 }};134 Fortran::common::visit(CoindexedCheck, statOrErrmsg.u);135}136 137static void CheckSyncStat(SemanticsContext &context,138 const parser::StatOrErrmsg &statOrErrmsg, bool &gotStat, bool &gotMsg) {139 common::visit(140 common::visitors{141 [&](const parser::StatVariable &stat) {142 if (gotStat) {143 context.Say( // C1172144 "The stat-variable in a sync-stat-list may not be repeated"_err_en_US);145 }146 gotStat = true;147 },148 [&](const parser::MsgVariable &var) {149 WarnOnDeferredLengthCharacterScalar(context, GetExpr(context, var),150 parser::UnwrapRef<parser::Variable>(var).GetSource(),151 "ERRMSG=");152 if (gotMsg) {153 context.Say( // C1172154 "The errmsg-variable in a sync-stat-list may not be repeated"_err_en_US);155 }156 gotMsg = true;157 },158 },159 statOrErrmsg.u);160 161 CheckCoindexedStatOrErrmsg(context, statOrErrmsg, "sync-stat-list");162}163 164static void CheckSyncStatList(165 SemanticsContext &context, const std::list<parser::StatOrErrmsg> &list) {166 bool gotStat{false}, gotMsg{false};167 for (const parser::StatOrErrmsg &statOrErrmsg : list) {168 CheckSyncStat(context, statOrErrmsg, gotStat, gotMsg);169 }170}171 172static void CheckEventVariable(173 SemanticsContext &context, const parser::EventVariable &eventVar) {174 if (const auto *expr{GetExpr(context, eventVar)}) {175 if (!IsEventType(evaluate::GetDerivedTypeSpec(expr->GetType()))) { // C1176176 context.Say(parser::FindSourceLocation(eventVar),177 "The event-variable must be of type EVENT_TYPE from module ISO_FORTRAN_ENV"_err_en_US);178 }179 }180}181 182void CoarrayChecker::Leave(const parser::ChangeTeamStmt &x) {183 CheckNamesAreDistinct(std::get<std::list<parser::CoarrayAssociation>>(x.t));184 CheckTeamType(context_, std::get<parser::TeamValue>(x.t));185 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));186}187 188void CoarrayChecker::Leave(const parser::EndChangeTeamStmt &x) {189 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));190}191 192void CoarrayChecker::Leave(const parser::SyncAllStmt &x) {193 CheckSyncStatList(context_, x.v);194}195 196void CoarrayChecker::Leave(const parser::SyncImagesStmt &x) {197 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));198 const auto &imageSet{std::get<parser::SyncImagesStmt::ImageSet>(x.t)};199 if (const auto *intExpr{std::get_if<parser::IntExpr>(&imageSet.u)}) {200 if (const auto *expr{GetExpr(context_, *intExpr)}) {201 if (expr->Rank() > 1) {202 context_.Say(parser::FindSourceLocation(imageSet), // C1174203 "An image-set that is an int-expr must be a scalar or a rank-one array"_err_en_US);204 }205 if (const auto *someInt{206 std::get_if<evaluate::Expr<evaluate::SomeInteger>>(&expr->u)};207 someInt && evaluate::IsActuallyConstant(*someInt)) {208 auto converted{evaluate::Fold(context_.foldingContext(),209 evaluate::ConvertToType<evaluate::SubscriptInteger>(210 common::Clone(*someInt)))};211 if (const auto *cst{212 evaluate::UnwrapConstantValue<evaluate::SubscriptInteger>(213 converted)}) {214 for (auto elt : cst->values()) {215 auto n{elt.ToInt64()};216 if (n < 1) {217 context_.Say(parser::FindSourceLocation(imageSet),218 "Image number %jd in the image-set is not valid"_err_en_US,219 std::intmax_t{n});220 break;221 }222 }223 }224 }225 }226 }227}228 229void CoarrayChecker::Leave(const parser::SyncMemoryStmt &x) {230 CheckSyncStatList(context_, x.v);231}232 233void CoarrayChecker::Leave(const parser::SyncTeamStmt &x) {234 CheckTeamType(context_, std::get<parser::TeamValue>(x.t));235 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));236}237 238static void CheckEventWaitSpecList(SemanticsContext &context,239 const std::list<parser::EventWaitSpec> &eventWaitSpecList) {240 bool gotStat{false}, gotMsg{false}, gotUntil{false};241 for (const parser::EventWaitSpec &eventWaitSpec : eventWaitSpecList) {242 common::visit(243 common::visitors{244 [&](const parser::ScalarIntExpr &untilCount) {245 if (gotUntil) {246 context.Say( // C1178247 "Until-spec in a event-wait-spec-list may not be repeated"_err_en_US);248 }249 gotUntil = true;250 },251 [&](const parser::StatOrErrmsg &statOrErrmsg) {252 common::visit(253 common::visitors{254 [&](const parser::StatVariable &stat) {255 if (gotStat) {256 context.Say( // C1178257 "A stat-variable in a event-wait-spec-list may not be repeated"_err_en_US);258 }259 gotStat = true;260 },261 [&](const parser::MsgVariable &var) {262 WarnOnDeferredLengthCharacterScalar(context,263 GetExpr(context, var),264 parser::UnwrapRef<parser::Variable>(var)265 .GetSource(),266 "ERRMSG=");267 if (gotMsg) {268 context.Say( // C1178269 "A errmsg-variable in a event-wait-spec-list may not be repeated"_err_en_US);270 }271 gotMsg = true;272 },273 },274 statOrErrmsg.u);275 CheckCoindexedStatOrErrmsg(276 context, statOrErrmsg, "event-wait-spec-list");277 },278 279 },280 eventWaitSpec.u);281 }282}283 284void CoarrayChecker::Leave(const parser::NotifyWaitStmt &x) {285 const auto ¬ifyVar{std::get<parser::Scalar<parser::Variable>>(x.t)};286 287 if (const auto *expr{GetExpr(context_, notifyVar)}) {288 if (ExtractCoarrayRef(expr)) {289 context_.Say(parser::FindSourceLocation(notifyVar), // F2023 - C1178290 "A notify-variable in a NOTIFY WAIT statement may not be a coindexed object"_err_en_US);291 } else if (!IsNotifyType(evaluate::GetDerivedTypeSpec(292 expr->GetType()))) { // F2023 - C1177293 context_.Say(parser::FindSourceLocation(notifyVar),294 "The notify-variable must be of type NOTIFY_TYPE from module ISO_FORTRAN_ENV"_err_en_US);295 } else if (!evaluate::IsCoarray(*expr)) { // F2023 - C1612296 context_.Say(parser::FindSourceLocation(notifyVar),297 "The notify-variable must be a coarray"_err_en_US);298 }299 }300 301 CheckEventWaitSpecList(302 context_, std::get<std::list<parser::EventWaitSpec>>(x.t));303}304 305void CoarrayChecker::Leave(const parser::EventPostStmt &x) {306 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));307 CheckEventVariable(context_, std::get<parser::EventVariable>(x.t));308}309 310void CoarrayChecker::Leave(const parser::EventWaitStmt &x) {311 const auto &eventVar{std::get<parser::EventVariable>(x.t)};312 313 if (const auto *expr{GetExpr(context_, eventVar)}) {314 if (ExtractCoarrayRef(expr)) {315 context_.Say(parser::FindSourceLocation(eventVar), // C1177316 "A event-variable in a EVENT WAIT statement may not be a coindexed object"_err_en_US);317 } else {318 CheckEventVariable(context_, eventVar);319 }320 }321 322 CheckEventWaitSpecList(323 context_, std::get<std::list<parser::EventWaitSpec>>(x.t));324}325 326static void CheckLockVariable(327 SemanticsContext &context, const parser::LockVariable &lockVar) {328 if (const SomeExpr * expr{GetExpr(lockVar)}) {329 if (auto dyType{expr->GetType()}) {330 auto at{parser::FindSourceLocation(lockVar)};331 if (dyType->category() != TypeCategory::Derived ||332 dyType->IsUnlimitedPolymorphic() ||333 !IsLockType(&dyType->GetDerivedTypeSpec())) {334 context.Say(at,335 "Lock variable must have type LOCK_TYPE from ISO_FORTRAN_ENV"_err_en_US);336 } else if (auto whyNot{WhyNotDefinable(at, context.FindScope(at),337 {DefinabilityFlag::DoNotNoteDefinition,338 DefinabilityFlag::AllowEventLockOrNotifyType},339 *expr)}) {340 whyNot->set_severity(parser::Severity::Because);341 context.Say(at, "Lock variable is not definable"_err_en_US)342 .Attach(std::move(*whyNot));343 }344 }345 }346}347 348void CoarrayChecker::Leave(const parser::LockStmt &x) {349 CheckLockVariable(context_, std::get<parser::LockVariable>(x.t));350 bool gotAcquired{false}, gotStat{false}, gotMsg{false};351 for (const parser::LockStmt::LockStat &lockStat :352 std::get<std::list<parser::LockStmt::LockStat>>(x.t)) {353 if (const auto *statOrErrmsg{354 std::get_if<parser::StatOrErrmsg>(&lockStat.u)}) {355 CheckSyncStat(context_, *statOrErrmsg, gotStat, gotMsg);356 } else {357 CHECK(std::holds_alternative<358 parser::Scalar<parser::Logical<parser::Variable>>>(lockStat.u));359 if (gotAcquired) {360 context_.Say(parser::FindSourceLocation(lockStat),361 "Multiple ACQUIRED_LOCK specifiers"_err_en_US);362 } else {363 gotAcquired = true;364 }365 }366 }367}368 369void CoarrayChecker::Leave(const parser::UnlockStmt &x) {370 CheckLockVariable(context_, std::get<parser::LockVariable>(x.t));371 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));372}373 374void CoarrayChecker::Leave(const parser::CriticalStmt &x) {375 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));376}377 378void CoarrayChecker::Leave(const parser::ImageSelector &imageSelector) {379 for (const auto &imageSelectorSpec :380 std::get<std::list<parser::ImageSelectorSpec>>(imageSelector.t)) {381 if (const auto *stat{std::get_if<parser::ImageSelectorSpec::Stat>(382 &imageSelectorSpec.u)}) {383 CheckTeamStat(context_, *stat);384 }385 }386}387 388void CoarrayChecker::Leave(const parser::FormTeamStmt &x) {389 CheckTeamType(390 context_, std::get<parser::TeamVariable>(x.t), /*mustBeVariable=*/true);391 for (const auto &spec :392 std::get<std::list<parser::FormTeamStmt::FormTeamSpec>>(x.t)) {393 if (const auto *statOrErrmsg{std::get_if<parser::StatOrErrmsg>(&spec.u)}) {394 CheckCoindexedStatOrErrmsg(395 context_, *statOrErrmsg, "form-team-spec-list");396 }397 }398}399 400void CoarrayChecker::Enter(const parser::CriticalConstruct &x) {401 auto &criticalStmt{std::get<parser::Statement<parser::CriticalStmt>>(x.t)};402 const parser::Block &block{std::get<parser::Block>(x.t)};403 CriticalBodyEnforce criticalBodyEnforce{context_, criticalStmt.source};404 parser::Walk(block, criticalBodyEnforce);405 parser::Walk(std::get<parser::Statement<parser::EndCriticalStmt>>(x.t),406 criticalBodyEnforce);407 LabelEnforce criticalLabelEnforce{408 context_, criticalBodyEnforce.labels(), criticalStmt.source, "CRITICAL"};409 parser::Walk(block, criticalLabelEnforce);410}411 412void CoarrayChecker::Enter(const parser::ChangeTeamConstruct &x) {413 auto &changeTeamStmt{414 std::get<parser::Statement<parser::ChangeTeamStmt>>(x.t)};415 const parser::Block &block{std::get<parser::Block>(x.t)};416 ChangeTeamBodyEnforce changeTeamBodyEnforce{context_, changeTeamStmt.source};417 parser::Walk(block, changeTeamBodyEnforce);418 parser::Walk(std::get<parser::Statement<parser::EndChangeTeamStmt>>(x.t),419 changeTeamBodyEnforce);420 LabelEnforce changeTeamLabelEnforce{context_, changeTeamBodyEnforce.labels(),421 changeTeamStmt.source, "CHANGE TEAM"};422 parser::Walk(block, changeTeamLabelEnforce);423}424 425// Check that coarray names and selector names are all distinct.426void CoarrayChecker::CheckNamesAreDistinct(427 const std::list<parser::CoarrayAssociation> &list) {428 std::set<parser::CharBlock> names;429 auto getPreviousUse{430 [&](const parser::Name &name) -> const parser::CharBlock * {431 auto pair{names.insert(name.source)};432 return !pair.second ? &*pair.first : nullptr;433 }};434 for (const auto &assoc : list) {435 const auto &decl{std::get<parser::CodimensionDecl>(assoc.t)};436 const auto &selector{std::get<parser::Selector>(assoc.t)};437 const auto &declName{std::get<parser::Name>(decl.t)};438 if (context_.HasError(declName)) {439 continue; // already reported an error about this name440 }441 if (auto *prev{getPreviousUse(declName)}) {442 Say2(declName.source, // C1113443 "Coarray '%s' was already used as a selector or coarray in this statement"_err_en_US,444 *prev, "Previous use of '%s'"_en_US);445 }446 // ResolveNames verified the selector is a simple name447 const parser::Name *name{parser::Unwrap<parser::Name>(selector)};448 if (name) {449 if (auto *prev{getPreviousUse(*name)}) {450 Say2(name->source, // C1113, C1115451 "Selector '%s' was already used as a selector or coarray in this statement"_err_en_US,452 *prev, "Previous use of '%s'"_en_US);453 }454 }455 }456}457 458void CoarrayChecker::Say2(const parser::CharBlock &name1,459 parser::MessageFixedText &&msg1, const parser::CharBlock &name2,460 parser::MessageFixedText &&msg2) {461 context_.Say(name1, std::move(msg1), name1)462 .Attach(name2, std::move(msg2), name2);463}464} // namespace Fortran::semantics465