xref: /llvm-project/flang/lib/Semantics/check-coarray.cpp (revision 2625510ef8094457413661ef0ce2651844f584d2)

//===-- lib/Semantics/check-coarray.cpp -----------------------------------===//
//
// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
// See https://llvm.org/LICENSE.txt for license information.
// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
//
//===----------------------------------------------------------------------===//

#include "check-coarray.h"
#include "flang/Common/indirection.h"
#include "flang/Evaluate/expression.h"
#include "flang/Parser/message.h"
#include "flang/Parser/parse-tree.h"
#include "flang/Parser/tools.h"
#include "flang/Semantics/expression.h"
#include "flang/Semantics/tools.h"

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(context, x)}) {
    if (!IsTeamType(evaluate::GetDerivedTypeSpec(expr->GetType()))) {
      context.Say(parser::FindSourceLocation(x), // C1114
          "Team value must be of type TEAM_TYPE from module ISO_FORTRAN_ENV"_err_en_US);
    }
  }
}

static void CheckTeamStat(
    SemanticsContext &context, const parser::ImageSelectorSpec::Stat &stat) {
  const parser::Variable &var{stat.v.thing.thing.value()};
  if (parser::GetCoindexedNamedObject(var)) {
    context.Say(parser::FindSourceLocation(var), // C931
        "Image selector STAT variable must not be a coindexed "
        "object"_err_en_US);
  }
}

static void CheckCoindexedStatOrErrmsg(SemanticsContext &context,
    const parser::StatOrErrmsg &statOrErrmsg, const std::string &listName) {
  auto CoindexedCheck{[&](const auto &statOrErrmsg) {
    if (const auto *expr{GetExpr(context, statOrErrmsg)}) {
      if (ExtractCoarrayRef(expr)) {
        context.Say(parser::FindSourceLocation(statOrErrmsg), // C1173
            "The stat-variable or errmsg-variable in a %s may not be a coindexed object"_err_en_US,
            listName);
      }
    }
  }};
  Fortran::common::visit(CoindexedCheck, statOrErrmsg.u);
}

static void CheckSyncStatList(
    SemanticsContext &context, const std::list<parser::StatOrErrmsg> &list) {
  bool gotStat{false}, gotMsg{false};

  for (const parser::StatOrErrmsg &statOrErrmsg : list) {
    common::visit(
        common::visitors{
            [&](const parser::StatVariable &stat) {
              if (gotStat) {
                context.Say( // C1172
                    "The stat-variable in a sync-stat-list may not be repeated"_err_en_US);
              }
              gotStat = true;
            },
            [&](const parser::MsgVariable &var) {
              WarnOnDeferredLengthCharacterScalar(context,
                  GetExpr(context, var), var.v.thing.thing.GetSource(),
                  "ERRMSG=");
              if (gotMsg) {
                context.Say( // C1172
                    "The errmsg-variable in a sync-stat-list may not be repeated"_err_en_US);
              }
              gotMsg = true;
            },
        },
        statOrErrmsg.u);

    CheckCoindexedStatOrErrmsg(context, statOrErrmsg, "sync-stat-list");
  }
}

static void CheckEventVariable(
    SemanticsContext &context, const parser::EventVariable &eventVar) {
  if (const auto *expr{GetExpr(context, eventVar)}) {
    if (!IsEventType(evaluate::GetDerivedTypeSpec(expr->GetType()))) { // C1176
      context.Say(parser::FindSourceLocation(eventVar),
          "The event-variable must be of type EVENT_TYPE from module ISO_FORTRAN_ENV"_err_en_US);
    }
  }
}

void CoarrayChecker::Leave(const parser::ChangeTeamStmt &x) {
  CheckNamesAreDistinct(std::get<std::list<parser::CoarrayAssociation>>(x.t));
  CheckTeamType(context_, std::get<parser::TeamValue>(x.t));
  CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
}

void CoarrayChecker::Leave(const parser::EndChangeTeamStmt &x) {
  CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
}

void CoarrayChecker::Leave(const parser::SyncAllStmt &x) {
  CheckSyncStatList(context_, x.v);
}

void CoarrayChecker::Leave(const parser::SyncImagesStmt &x) {
  CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));

  const auto &imageSet{std::get<parser::SyncImagesStmt::ImageSet>(x.t)};
  if (const auto *intExpr{std::get_if<parser::IntExpr>(&imageSet.u)}) {
    if (const auto *expr{GetExpr(context_, *intExpr)}) {
      if (expr->Rank() > 1) {
        context_.Say(parser::FindSourceLocation(imageSet), // C1174
            "An image-set that is an int-expr must be a scalar or a rank-one array"_err_en_US);
      }
    }
  }
}

void CoarrayChecker::Leave(const parser::SyncMemoryStmt &x) {
  CheckSyncStatList(context_, x.v);
}

void CoarrayChecker::Leave(const parser::SyncTeamStmt &x) {
  CheckTeamType(context_, std::get<parser::TeamValue>(x.t));
  CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
}

static void CheckEventWaitSpecList(SemanticsContext &context,
    const std::list<parser::EventWaitSpec> &eventWaitSpecList) {
  bool gotStat{false}, gotMsg{false}, gotUntil{false};
  for (const parser::EventWaitSpec &eventWaitSpec : eventWaitSpecList) {
    common::visit(
        common::visitors{
            [&](const parser::ScalarIntExpr &untilCount) {
              if (gotUntil) {
                context.Say( // C1178
                    "Until-spec in a event-wait-spec-list may not be repeated"_err_en_US);
              }
              gotUntil = true;
            },
            [&](const parser::StatOrErrmsg &statOrErrmsg) {
              common::visit(
                  common::visitors{
                      [&](const parser::StatVariable &stat) {
                        if (gotStat) {
                          context.Say( // C1178
                              "A stat-variable in a event-wait-spec-list may not be repeated"_err_en_US);
                        }
                        gotStat = true;
                      },
                      [&](const parser::MsgVariable &var) {
                        WarnOnDeferredLengthCharacterScalar(context,
                            GetExpr(context, var),
                            var.v.thing.thing.GetSource(), "ERRMSG=");
                        if (gotMsg) {
                          context.Say( // C1178
                              "A errmsg-variable in a event-wait-spec-list may not be repeated"_err_en_US);
                        }
                        gotMsg = true;
                      },
                  },
                  statOrErrmsg.u);
              CheckCoindexedStatOrErrmsg(
                  context, statOrErrmsg, "event-wait-spec-list");
            },

        },
        eventWaitSpec.u);
  }
}

void CoarrayChecker::Leave(const parser::NotifyWaitStmt &x) {
  const auto &notifyVar{std::get<parser::Scalar<parser::Variable>>(x.t)};

  if (const auto *expr{GetExpr(context_, notifyVar)}) {
    if (ExtractCoarrayRef(expr)) {
      context_.Say(parser::FindSourceLocation(notifyVar), // F2023 - C1178
          "A notify-variable in a NOTIFY WAIT statement may not be a coindexed object"_err_en_US);
    } else if (!IsNotifyType(evaluate::GetDerivedTypeSpec(
                   expr->GetType()))) { // F2023 - C1177
      context_.Say(parser::FindSourceLocation(notifyVar),
          "The notify-variable must be of type NOTIFY_TYPE from module ISO_FORTRAN_ENV"_err_en_US);
    } else if (!evaluate::IsCoarray(*expr)) { // F2023 - C1612
      context_.Say(parser::FindSourceLocation(notifyVar),
          "The notify-variable must be a coarray"_err_en_US);
    }
  }

  CheckEventWaitSpecList(
      context_, std::get<std::list<parser::EventWaitSpec>>(x.t));
}

void CoarrayChecker::Leave(const parser::EventPostStmt &x) {
  CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
  CheckEventVariable(context_, std::get<parser::EventVariable>(x.t));
}

void CoarrayChecker::Leave(const parser::EventWaitStmt &x) {
  const auto &eventVar{std::get<parser::EventVariable>(x.t)};

  if (const auto *expr{GetExpr(context_, eventVar)}) {
    if (ExtractCoarrayRef(expr)) {
      context_.Say(parser::FindSourceLocation(eventVar), // C1177
          "A event-variable in a EVENT WAIT statement may not be a coindexed object"_err_en_US);
    } else {
      CheckEventVariable(context_, eventVar);
    }
  }

  CheckEventWaitSpecList(
      context_, std::get<std::list<parser::EventWaitSpec>>(x.t));
}

void CoarrayChecker::Leave(const parser::UnlockStmt &x) {
  CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
}

void CoarrayChecker::Leave(const parser::CriticalStmt &x) {
  CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
}

void CoarrayChecker::Leave(const parser::ImageSelector &imageSelector) {
  haveStat_ = false;
  haveTeam_ = false;
  haveTeamNumber_ = false;
  for (const auto &imageSelectorSpec :
      std::get<std::list<parser::ImageSelectorSpec>>(imageSelector.t)) {
    if (const auto *team{
            std::get_if<parser::TeamValue>(&imageSelectorSpec.u)}) {
      if (haveTeam_) {
        context_.Say(parser::FindSourceLocation(imageSelectorSpec), // C929
            "TEAM value can only be specified once"_err_en_US);
      }
      CheckTeamType(context_, *team);
      haveTeam_ = true;
    }
    if (const auto *stat{std::get_if<parser::ImageSelectorSpec::Stat>(
            &imageSelectorSpec.u)}) {
      if (haveStat_) {
        context_.Say(parser::FindSourceLocation(imageSelectorSpec), // C929
            "STAT variable can only be specified once"_err_en_US);
      }
      CheckTeamStat(context_, *stat);
      haveStat_ = true;
    }
    if (std::get_if<parser::ImageSelectorSpec::Team_Number>(
            &imageSelectorSpec.u)) {
      if (haveTeamNumber_) {
        context_.Say(parser::FindSourceLocation(imageSelectorSpec), // C929
            "TEAM_NUMBER value can only be specified once"_err_en_US);
      }
      haveTeamNumber_ = true;
    }
  }
  if (haveTeam_ && haveTeamNumber_) {
    context_.Say(parser::FindSourceLocation(imageSelector), // C930
        "Cannot specify both TEAM and TEAM_NUMBER"_err_en_US);
  }
}

void CoarrayChecker::Leave(const parser::FormTeamStmt &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) {
  std::set<parser::CharBlock> names;
  auto getPreviousUse{
      [&](const parser::Name &name) -> const parser::CharBlock * {
        auto pair{names.insert(name.source)};
        return !pair.second ? &*pair.first : nullptr;
      }};
  for (const auto &assoc : list) {
    const auto &decl{std::get<parser::CodimensionDecl>(assoc.t)};
    const auto &selector{std::get<parser::Selector>(assoc.t)};
    const auto &declName{std::get<parser::Name>(decl.t)};
    if (context_.HasError(declName)) {
      continue; // already reported an error about this name
    }
    if (auto *prev{getPreviousUse(declName)}) {
      Say2(declName.source, // C1113
          "Coarray '%s' was already used as a selector or coarray in this statement"_err_en_US,
          *prev, "Previous use of '%s'"_en_US);
    }
    // ResolveNames verified the selector is a simple name
    const parser::Name *name{parser::Unwrap<parser::Name>(selector)};
    if (name) {
      if (auto *prev{getPreviousUse(*name)}) {
        Say2(name->source, // C1113, C1115
            "Selector '%s' was already used as a selector or coarray in this statement"_err_en_US,
            *prev, "Previous use of '%s'"_en_US);
      }
    }
  }
}

void CoarrayChecker::Say2(const parser::CharBlock &name1,
    parser::MessageFixedText &&msg1, const parser::CharBlock &name2,
    parser::MessageFixedText &&msg2) {
  context_.Say(name1, std::move(msg1), name1)
      .Attach(name2, std::move(msg2), name2);
}
} // namespace Fortran::semantics