flang/lib/Semantics/check-coarray.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-exception
   6 //
   7 //===----------------------------------------------------------------------===//
   8
   9 #include "check-coarray.h"
  10 #include "flang/Common/indirection.h"
  11 #include "flang/Evaluate/expression.h"
  12 #include "flang/Parser/message.h"
  13 #include "flang/Parser/parse-tree.h"
  14 #include "flang/Parser/tools.h"
  15 #include "flang/Semantics/expression.h"
  16 #include "flang/Semantics/tools.h"
  17
  18 namespace Fortran::semantics {
  19
  20 class CriticalBodyEnforce {
  21 public:
  22   CriticalBodyEnforce(
  23       SemanticsContext &context, parser::CharBlock criticalSourcePosition)
  24       : context_{context}, criticalSourcePosition_{criticalSourcePosition} {}
  25   std::set<parser::Label> labels() { return labels_; }
  26   template <typename T> bool Pre(const T &) { return true; }
  27   template <typename T> void Post(const T &) {}
  28
  29   template <typename T> bool Pre(const parser::Statement<T> &statement) {
  30     currentStatementSourcePosition_ = statement.source;
  31     if (statement.label.has_value()) {
  32       labels_.insert(*statement.label);
  33     }
  34     return true;
  35   }
  36
  37   // C1118
  38   void Post(const parser::ReturnStmt &) {
  39     context_
  40         .Say(currentStatementSourcePosition_,
  41             "RETURN statement is not allowed in a CRITICAL construct"_err_en_US)
  42         .Attach(criticalSourcePosition_, GetEnclosingMsg());
  43   }
  44   void Post(const parser::ExecutableConstruct &construct) {
  45     if (IsImageControlStmt(construct)) {
  46       context_
  47           .Say(currentStatementSourcePosition_,
  48               "An image control statement is not allowed in a CRITICAL"
  49               " construct"_err_en_US)
  50           .Attach(criticalSourcePosition_, GetEnclosingMsg());
  51     }
  52   }
  53
  54 private:
  55   parser::MessageFixedText GetEnclosingMsg() {
  56     return "Enclosing CRITICAL statement"_en_US;
  57   }
  58
  59   SemanticsContext &context_;
  60   std::set<parser::Label> labels_;
  61   parser::CharBlock currentStatementSourcePosition_;
  62   parser::CharBlock criticalSourcePosition_;
  63 };
  64
  65 template <typename T>
  66 static void CheckTeamType(SemanticsContext &context, const T &x) {
  67   if (const auto *expr{GetExpr(context, x)}) {
  68     if (!IsTeamType(evaluate::GetDerivedTypeSpec(expr->GetType()))) {
  69       context.Say(parser::FindSourceLocation(x), // C1114
  70           "Team value must be of type TEAM_TYPE from module ISO_FORTRAN_ENV"_err_en_US);
  71     }
  72   }
  73 }
  74
  75 static void CheckTeamStat(
  76     SemanticsContext &context, const parser::ImageSelectorSpec::Stat &stat) {
  77   const parser::Variable &var{stat.v.thing.thing.value()};
  78   if (parser::GetCoindexedNamedObject(var)) {
  79     context.Say(parser::FindSourceLocation(var), // C931
  80         "Image selector STAT variable must not be a coindexed "
  81         "object"_err_en_US);
  82   }
  83 }
  84
  85 static void CheckCoindexedStatOrErrmsg(SemanticsContext &context,
  86     const parser::StatOrErrmsg &statOrErrmsg, const std::string &listName) {
  87   auto CoindexedCheck{[&](const auto &statOrErrmsg) {
  88     if (const auto *expr{GetExpr(context, statOrErrmsg)}) {
  89       if (ExtractCoarrayRef(expr)) {
  90         context.Say(parser::FindSourceLocation(statOrErrmsg), // C1173
  91             "The stat-variable or errmsg-variable in a %s may not be a coindexed object"_err_en_US,
  92             listName);
  93       }
  94     }
  95   }};
  96   Fortran::common::visit(CoindexedCheck, statOrErrmsg.u);
  97 }
  98
  99 static void CheckSyncStatList(
 100     SemanticsContext &context, const std::list<parser::StatOrErrmsg> &list) {
 101   bool gotStat{false}, gotMsg{false};
 102
 103   for (const parser::StatOrErrmsg &statOrErrmsg : list) {
 104     common::visit(
 105         common::visitors{
 106             [&](const parser::StatVariable &stat) {
 107               if (gotStat) {
 108                 context.Say( // C1172
 109                     "The stat-variable in a sync-stat-list may not be repeated"_err_en_US);
 110               }
 111               gotStat = true;
 112             },
 113             [&](const parser::MsgVariable &var) {
 114               WarnOnDeferredLengthCharacterScalar(context,
 115                   GetExpr(context, var), var.v.thing.thing.GetSource(),
 116                   "ERRMSG=");
 117               if (gotMsg) {
 118                 context.Say( // C1172
 119                     "The errmsg-variable in a sync-stat-list may not be repeated"_err_en_US);
 120               }
 121               gotMsg = true;
 122             },
 123         },
 124         statOrErrmsg.u);
 125
 126     CheckCoindexedStatOrErrmsg(context, statOrErrmsg, "sync-stat-list");
 127   }
 128 }
 129
 130 static void CheckEventVariable(
 131     SemanticsContext &context, const parser::EventVariable &eventVar) {
 132   if (const auto *expr{GetExpr(context, eventVar)}) {
 133     if (!IsEventType(evaluate::GetDerivedTypeSpec(expr->GetType()))) { // C1176
 134       context.Say(parser::FindSourceLocation(eventVar),
 135           "The event-variable must be of type EVENT_TYPE from module ISO_FORTRAN_ENV"_err_en_US);
 136     }
 137   }
 138 }
 139
 140 void CoarrayChecker::Leave(const parser::ChangeTeamStmt &x) {
 141   CheckNamesAreDistinct(std::get<std::list<parser::CoarrayAssociation>>(x.t));
 142   CheckTeamType(context_, std::get<parser::TeamValue>(x.t));
 143   CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
 144 }
 145
 146 void CoarrayChecker::Leave(const parser::EndChangeTeamStmt &x) {
 147   CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
 148 }
 149
 150 void CoarrayChecker::Leave(const parser::SyncAllStmt &x) {
 151   CheckSyncStatList(context_, x.v);
 152 }
 153
 154 void CoarrayChecker::Leave(const parser::SyncImagesStmt &x) {
 155   CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
 156
 157   const auto &imageSet{std::get<parser::SyncImagesStmt::ImageSet>(x.t)};
 158   if (const auto *intExpr{std::get_if<parser::IntExpr>(&imageSet.u)}) {
 159     if (const auto *expr{GetExpr(context_, *intExpr)}) {
 160       if (expr->Rank() > 1) {
 161         context_.Say(parser::FindSourceLocation(imageSet), // C1174
 162             "An image-set that is an int-expr must be a scalar or a rank-one array"_err_en_US);
 163       }
 164     }
 165   }
 166 }
 167
 168 void CoarrayChecker::Leave(const parser::SyncMemoryStmt &x) {
 169   CheckSyncStatList(context_, x.v);
 170 }
 171
 172 void CoarrayChecker::Leave(const parser::SyncTeamStmt &x) {
 173   CheckTeamType(context_, std::get<parser::TeamValue>(x.t));
 174   CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
 175 }
 176
 177 static void CheckEventWaitSpecList(SemanticsContext &context,
 178     const std::list<parser::EventWaitSpec> &eventWaitSpecList) {
 179   bool gotStat{false}, gotMsg{false}, gotUntil{false};
 180   for (const parser::EventWaitSpec &eventWaitSpec : eventWaitSpecList) {
 181     common::visit(
 182         common::visitors{
 183             [&](const parser::ScalarIntExpr &untilCount) {
 184               if (gotUntil) {
 185                 context.Say( // C1178
 186                     "Until-spec in a event-wait-spec-list may not be repeated"_err_en_US);
 187               }
 188               gotUntil = true;
 189             },
 190             [&](const parser::StatOrErrmsg &statOrErrmsg) {
 191               common::visit(
 192                   common::visitors{
 193                       [&](const parser::StatVariable &stat) {
 194                         if (gotStat) {
 195                           context.Say( // C1178
 196                               "A stat-variable in a event-wait-spec-list may not be repeated"_err_en_US);
 197                         }
 198                         gotStat = true;
 199                       },
 200                       [&](const parser::MsgVariable &var) {
 201                         WarnOnDeferredLengthCharacterScalar(context,
 202                             GetExpr(context, var),
 203                             var.v.thing.thing.GetSource(), "ERRMSG=");
 204                         if (gotMsg) {
 205                           context.Say( // C1178
 206                               "A errmsg-variable in a event-wait-spec-list may not be repeated"_err_en_US);
 207                         }
 208                         gotMsg = true;
 209                       },
 210                   },
 211                   statOrErrmsg.u);
 212               CheckCoindexedStatOrErrmsg(
 213                   context, statOrErrmsg, "event-wait-spec-list");
 214             },
 215
 216         },
 217         eventWaitSpec.u);
 218   }
 219 }
 220
 221 void CoarrayChecker::Leave(const parser::NotifyWaitStmt &x) {
 222   const auto &notifyVar{std::get<parser::Scalar<parser::Variable>>(x.t)};
 223
 224   if (const auto *expr{GetExpr(context_, notifyVar)}) {
 225     if (ExtractCoarrayRef(expr)) {
 226       context_.Say(parser::FindSourceLocation(notifyVar), // F2023 - C1178
 227           "A notify-variable in a NOTIFY WAIT statement may not be a coindexed object"_err_en_US);
 228     } else if (!IsNotifyType(evaluate::GetDerivedTypeSpec(
 229                    expr->GetType()))) { // F2023 - C1177
 230       context_.Say(parser::FindSourceLocation(notifyVar),
 231           "The notify-variable must be of type NOTIFY_TYPE from module ISO_FORTRAN_ENV"_err_en_US);
 232     } else if (!evaluate::IsCoarray(*expr)) { // F2023 - C1612
 233       context_.Say(parser::FindSourceLocation(notifyVar),
 234           "The notify-variable must be a coarray"_err_en_US);
 235     }
 236   }
 237
 238   CheckEventWaitSpecList(
 239       context_, std::get<std::list<parser::EventWaitSpec>>(x.t));
 240 }
 241
 242 void CoarrayChecker::Leave(const parser::EventPostStmt &x) {
 243   CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
 244   CheckEventVariable(context_, std::get<parser::EventVariable>(x.t));
 245 }
 246
 247 void CoarrayChecker::Leave(const parser::EventWaitStmt &x) {
 248   const auto &eventVar{std::get<parser::EventVariable>(x.t)};
 249
 250   if (const auto *expr{GetExpr(context_, eventVar)}) {
 251     if (ExtractCoarrayRef(expr)) {
 252       context_.Say(parser::FindSourceLocation(eventVar), // C1177
 253           "A event-variable in a EVENT WAIT statement may not be a coindexed object"_err_en_US);
 254     } else {
 255       CheckEventVariable(context_, eventVar);
 256     }
 257   }
 258
 259   CheckEventWaitSpecList(
 260       context_, std::get<std::list<parser::EventWaitSpec>>(x.t));
 261 }
 262
 263 void CoarrayChecker::Leave(const parser::UnlockStmt &x) {
 264   CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
 265 }
 266
 267 void CoarrayChecker::Leave(const parser::CriticalStmt &x) {
 268   CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
 269 }
 270
 271 void CoarrayChecker::Leave(const parser::ImageSelector &imageSelector) {
 272   haveStat_ = false;
 273   haveTeam_ = false;
 274   haveTeamNumber_ = false;
 275   for (const auto &imageSelectorSpec :
 276       std::get<std::list<parser::ImageSelectorSpec>>(imageSelector.t)) {
 277     if (const auto *team{
 278             std::get_if<parser::TeamValue>(&imageSelectorSpec.u)}) {
 279       if (haveTeam_) {
 280         context_.Say(parser::FindSourceLocation(imageSelectorSpec), // C929
 281             "TEAM value can only be specified once"_err_en_US);
 282       }
 283       CheckTeamType(context_, *team);
 284       haveTeam_ = true;
 285     }
 286     if (const auto *stat{std::get_if<parser::ImageSelectorSpec::Stat>(
 287             &imageSelectorSpec.u)}) {
 288       if (haveStat_) {
 289         context_.Say(parser::FindSourceLocation(imageSelectorSpec), // C929
 290             "STAT variable can only be specified once"_err_en_US);
 291       }
 292       CheckTeamStat(context_, *stat);
 293       haveStat_ = true;
 294     }
 295     if (std::get_if<parser::ImageSelectorSpec::Team_Number>(
 296             &imageSelectorSpec.u)) {
 297       if (haveTeamNumber_) {
 298         context_.Say(parser::FindSourceLocation(imageSelectorSpec), // C929
 299             "TEAM_NUMBER value can only be specified once"_err_en_US);
 300       }
 301       haveTeamNumber_ = true;
 302     }
 303   }
 304   if (haveTeam_ && haveTeamNumber_) {
 305     context_.Say(parser::FindSourceLocation(imageSelector), // C930
 306         "Cannot specify both TEAM and TEAM_NUMBER"_err_en_US);
 307   }
 308 }
 309
 310 void CoarrayChecker::Leave(const parser::FormTeamStmt &x) {
 311   CheckTeamType(context_, std::get<parser::TeamVariable>(x.t));
 312 }
 313
 314 void CoarrayChecker::Enter(const parser::CriticalConstruct &x) {
 315   auto &criticalStmt{std::get<parser::Statement<parser::CriticalStmt>>(x.t)};
 316
 317   const parser::Block &block{std::get<parser::Block>(x.t)};
 318   CriticalBodyEnforce criticalBodyEnforce{context_, criticalStmt.source};
 319   parser::Walk(block, criticalBodyEnforce);
 320
 321   // C1119
 322   LabelEnforce criticalLabelEnforce{
 323       context_, criticalBodyEnforce.labels(), criticalStmt.source, "CRITICAL"};
 324   parser::Walk(block, criticalLabelEnforce);
 325 }
 326
 327 // Check that coarray names and selector names are all distinct.
 328 void CoarrayChecker::CheckNamesAreDistinct(
 329     const std::list<parser::CoarrayAssociation> &list) {
 330   std::set<parser::CharBlock> names;
 331   auto getPreviousUse{
 332       [&](const parser::Name &name) -> const parser::CharBlock * {
 333         auto pair{names.insert(name.source)};
 334         return !pair.second ? &*pair.first : nullptr;
 335       }};
 336   for (const auto &assoc : list) {
 337     const auto &decl{std::get<parser::CodimensionDecl>(assoc.t)};
 338     const auto &selector{std::get<parser::Selector>(assoc.t)};
 339     const auto &declName{std::get<parser::Name>(decl.t)};
 340     if (context_.HasError(declName)) {
 341       continue; // already reported an error about this name
 342     }
 343     if (auto *prev{getPreviousUse(declName)}) {
 344       Say2(declName.source, // C1113
 345           "Coarray '%s' was already used as a selector or coarray in this statement"_err_en_US,
 346           *prev, "Previous use of '%s'"_en_US);
 347     }
 348     // ResolveNames verified the selector is a simple name
 349     const parser::Name *name{parser::Unwrap<parser::Name>(selector)};
 350     if (name) {
 351       if (auto *prev{getPreviousUse(*name)}) {
 352         Say2(name->source, // C1113, C1115
 353             "Selector '%s' was already used as a selector or coarray in this statement"_err_en_US,
 354             *prev, "Previous use of '%s'"_en_US);
 355       }
 356     }
 357   }
 358 }
 359
 360 void CoarrayChecker::Say2(const parser::CharBlock &name1,
 361     parser::MessageFixedText &&msg1, const parser::CharBlock &name2,
 362     parser::MessageFixedText &&msg2) {
 363   context_.Say(name1, std::move(msg1), name1)
 364       .Attach(name2, std::move(msg2), name2);
 365 }
 366 } // namespace Fortran::semantics