llvm-project/flang/lib/Semantics/assignment.cpp

//===-- lib/Semantics/assignment.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 "assignment.h"
#include "pointer-assignment.h"
#include "flang/Common/idioms.h"
#include "flang/Common/restorer.h"
#include "flang/Evaluate/characteristics.h"
#include "flang/Evaluate/expression.h"
#include "flang/Evaluate/fold.h"
#include "flang/Evaluate/tools.h"
#include "flang/Parser/message.h"
#include "flang/Parser/parse-tree-visitor.h"
#include "flang/Parser/parse-tree.h"
#include "flang/Semantics/expression.h"
#include "flang/Semantics/symbol.h"
#include "flang/Semantics/tools.h"
#include <optional>
#include <set>
#include <string>
#include <type_traits>

using namespace Fortran::parser::literals;

namespace Fortran::semantics {

class AssignmentContext {
public:
  explicit AssignmentContext(SemanticsContext &context) : context_{context} {}
  AssignmentContext(AssignmentContext &&) = default;
  AssignmentContext(const AssignmentContext &) = delete;
  bool operator==(const AssignmentContext &x) const { return this == &x; }

  template <typename A> void PushWhereContext(const A &);
  void PopWhereContext();
  void Analyze(const parser::AssignmentStmt &);
  void Analyze(const parser::PointerAssignmentStmt &);
  void Analyze(const parser::ConcurrentControl &);

private:
  bool CheckForPureContext(const SomeExpr &lhs, const SomeExpr &rhs,
      parser::CharBlock rhsSource, bool isPointerAssignment);
  void CheckShape(parser::CharBlock, const SomeExpr *);
  template <typename... A>
  parser::Message *Say(parser::CharBlock at, A &&...args) {
    return &context_.Say(at, std::forward<A>(args)...);
  }
  evaluate::FoldingContext &foldingContext() {
    return context_.foldingContext();
  }

  SemanticsContext &context_;
  int whereDepth_{0}; // number of WHEREs currently nested in
  // shape of masks in LHS of assignments in current WHERE:
  std::vector<std::optional<std::int64_t>> whereExtents_;
};

void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
  if (const evaluate::Assignment * assignment{GetAssignment(stmt)}) {
    const SomeExpr &lhs{assignment->lhs};
    const SomeExpr &rhs{assignment->rhs};
    auto lhsLoc{std::get<parser::Variable>(stmt.t).GetSource()};
    auto rhsLoc{std::get<parser::Expr>(stmt.t).source};
    if (CheckForPureContext(lhs, rhs, rhsLoc, false)) {
      const Scope &scope{context_.FindScope(lhsLoc)};
      if (auto whyNot{WhyNotModifiable(lhsLoc, lhs, scope, true)}) {
        if (auto *msg{Say(lhsLoc,
                "Left-hand side of assignment is not modifiable"_err_en_US)}) {
          msg->Attach(*whyNot);
        }
      }
    }
    if (whereDepth_ > 0) {
      CheckShape(lhsLoc, &lhs);
    }
  }
}

void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &stmt) {
  CHECK(whereDepth_ == 0);
  if (const evaluate::Assignment * assignment{GetAssignment(stmt)}) {
    const SomeExpr &lhs{assignment->lhs};
    const SomeExpr &rhs{assignment->rhs};
    CheckForPureContext(lhs, rhs, std::get<parser::Expr>(stmt.t).source, true);
    auto restorer{
        foldingContext().messages().SetLocation(context_.location().value())};
    CheckPointerAssignment(foldingContext(), *assignment);
  }
}

// C1594 checks
static bool IsPointerDummyOfPureFunction(const Symbol &x) {
  return IsPointerDummy(x) && FindPureProcedureContaining(x.owner()) &&
      x.owner().symbol() && IsFunction(*x.owner().symbol());
}

static const char *WhyBaseObjectIsSuspicious(
    const Symbol &x, const Scope &scope) {
  // See C1594, first paragraph.  These conditions enable checks on both
  // left-hand and right-hand sides in various circumstances.
  if (IsHostAssociated(x, scope)) {
    return "host-associated";
  } else if (IsUseAssociated(x, scope)) {
    return "USE-associated";
  } else if (IsPointerDummyOfPureFunction(x)) {
    return "a POINTER dummy argument of a pure function";
  } else if (IsIntentIn(x)) {
    return "an INTENT(IN) dummy argument";
  } else if (FindCommonBlockContaining(x)) {
    return "in a COMMON block";
  } else {
    return nullptr;
  }
}

// Checks C1594(1,2); false if check fails
bool CheckDefinabilityInPureScope(parser::ContextualMessages &messages,
    const Symbol &lhs, const Scope &context, const Scope &pure) {
  if (pure.symbol()) {
    if (const char *why{WhyBaseObjectIsSuspicious(lhs, context)}) {
      evaluate::SayWithDeclaration(messages, lhs,
          "Pure subprogram '%s' may not define '%s' because it is %s"_err_en_US,
          pure.symbol()->name(), lhs.name(), why);
      return false;
    }
  }
  return true;
}

static std::optional<std::string> GetPointerComponentDesignatorName(
    const SomeExpr &expr) {
  if (const auto *derived{
          evaluate::GetDerivedTypeSpec(evaluate::DynamicType::From(expr))}) {
    UltimateComponentIterator ultimates{*derived};
    if (auto pointer{
            std::find_if(ultimates.begin(), ultimates.end(), IsPointer)}) {
      return pointer.BuildResultDesignatorName();
    }
  }
  return std::nullopt;
}

// Checks C1594(5,6); false if check fails
bool CheckCopyabilityInPureScope(parser::ContextualMessages &messages,
    const SomeExpr &expr, const Scope &scope) {
  if (const Symbol * base{GetFirstSymbol(expr)}) {
    if (const char *why{WhyBaseObjectIsSuspicious(*base, scope)}) {
      if (auto pointer{GetPointerComponentDesignatorName(expr)}) {
        evaluate::SayWithDeclaration(messages, *base,
            "A pure subprogram may not copy the value of '%s' because it is %s"
            " and has the POINTER component '%s'"_err_en_US,
            base->name(), why, *pointer);
        return false;
      }
    }
  }
  return true;
}

bool AssignmentContext::CheckForPureContext(const SomeExpr &lhs,
    const SomeExpr &rhs, parser::CharBlock source, bool isPointerAssignment) {
  const Scope &scope{context_.FindScope(source)};
  if (const Scope * pure{FindPureProcedureContaining(scope)}) {
    parser::ContextualMessages messages{
        context_.location().value(), &context_.messages()};
    if (evaluate::ExtractCoarrayRef(lhs)) {
      messages.Say(
          "A pure subprogram may not define a coindexed object"_err_en_US);
    } else if (const Symbol * base{GetFirstSymbol(lhs)}) {
      if (const auto *assoc{base->detailsIf<AssocEntityDetails>()}) {
        auto dataRef{ExtractDataRef(assoc->expr(), true)};
        // ASSOCIATE(a=>x) -- check x, not a, for "a=..."
        base = dataRef ? &dataRef->GetFirstSymbol() : nullptr;
      }
      if (base &&
          !CheckDefinabilityInPureScope(messages, *base, scope, *pure)) {
        return false;
      }
    }
    if (isPointerAssignment) {
      if (const Symbol * base{GetFirstSymbol(rhs)}) {
        if (const char *why{
                WhyBaseObjectIsSuspicious(*base, scope)}) { // C1594(3)
          evaluate::SayWithDeclaration(messages, *base,
              "A pure subprogram may not use '%s' as the target of pointer assignment because it is %s"_err_en_US,
              base->name(), why);
          return false;
        }
      }
    } else if (auto type{evaluate::DynamicType::From(lhs)}) {
      // C1596 checks for polymorphic deallocation in a pure subprogram
      // due to automatic reallocation on assignment
      if (type->IsPolymorphic()) {
        context_.Say(
            "Deallocation of polymorphic object is not permitted in a pure subprogram"_err_en_US);
        return false;
      }
      if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(type)}) {
        if (auto bad{FindPolymorphicAllocatableNonCoarrayUltimateComponent(
                *derived)}) {
          evaluate::SayWithDeclaration(messages, *bad,
              "Deallocation of polymorphic non-coarray component '%s' is not permitted in a pure subprogram"_err_en_US,
              bad.BuildResultDesignatorName());
          return false;
        } else {
          return CheckCopyabilityInPureScope(messages, rhs, scope);
        }
      }
    }
  }
  return true;
}

// 10.2.3.1(2) The masks and LHS of assignments must all have the same shape
void AssignmentContext::CheckShape(parser::CharBlock at, const SomeExpr *expr) {
  if (auto shape{evaluate::GetShape(foldingContext(), expr)}) {
    std::size_t size{shape->size()};
    if (whereDepth_ == 0) {
      whereExtents_.resize(size);
    } else if (whereExtents_.size() != size) {
      Say(at,
          "Must have rank %zd to match prior mask or assignment of"
          " WHERE construct"_err_en_US,
          whereExtents_.size());
      return;
    }
    for (std::size_t i{0}; i < size; ++i) {
      if (std::optional<std::int64_t> extent{evaluate::ToInt64((*shape)[i])}) {
        if (!whereExtents_[i]) {
          whereExtents_[i] = *extent;
        } else if (*whereExtents_[i] != *extent) {
          Say(at,
              "Dimension %d must have extent %jd to match prior mask or"
              " assignment of WHERE construct"_err_en_US,
              i + 1, *whereExtents_[i]);
        }
      }
    }
  }
}

template <typename A> void AssignmentContext::PushWhereContext(const A &x) {
  const auto &expr{std::get<parser::LogicalExpr>(x.t)};
  CheckShape(expr.thing.value().source, GetExpr(expr));
  ++whereDepth_;
}

void AssignmentContext::PopWhereContext() {
  --whereDepth_;
  if (whereDepth_ == 0) {
    whereExtents_.clear();
  }
}

AssignmentChecker::~AssignmentChecker() {}

AssignmentChecker::AssignmentChecker(SemanticsContext &context)
    : context_{new AssignmentContext{context}} {}
void AssignmentChecker::Enter(const parser::AssignmentStmt &x) {
  context_.value().Analyze(x);
}
void AssignmentChecker::Enter(const parser::PointerAssignmentStmt &x) {
  context_.value().Analyze(x);
}
void AssignmentChecker::Enter(const parser::WhereStmt &x) {
  context_.value().PushWhereContext(x);
}
void AssignmentChecker::Leave(const parser::WhereStmt &) {
  context_.value().PopWhereContext();
}
void AssignmentChecker::Enter(const parser::WhereConstructStmt &x) {
  context_.value().PushWhereContext(x);
}
void AssignmentChecker::Leave(const parser::EndWhereStmt &) {
  context_.value().PopWhereContext();
}
void AssignmentChecker::Enter(const parser::MaskedElsewhereStmt &x) {
  context_.value().PushWhereContext(x);
}
void AssignmentChecker::Leave(const parser::MaskedElsewhereStmt &) {
  context_.value().PopWhereContext();
}

} // namespace Fortran::semantics
template class Fortran::common::Indirection<
    Fortran::semantics::AssignmentContext>;