flang/lib/Semantics/assignment.cpp

   1 //===-- lib/Semantics/assignment.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 "assignment.h"
  10 #include "definable.h"
  11 #include "pointer-assignment.h"
  12 #include "flang/Common/idioms.h"
  13 #include "flang/Common/restorer.h"
  14 #include "flang/Evaluate/characteristics.h"
  15 #include "flang/Evaluate/expression.h"
  16 #include "flang/Evaluate/fold.h"
  17 #include "flang/Evaluate/tools.h"
  18 #include "flang/Parser/message.h"
  19 #include "flang/Parser/parse-tree-visitor.h"
  20 #include "flang/Parser/parse-tree.h"
  21 #include "flang/Semantics/expression.h"
  22 #include "flang/Semantics/symbol.h"
  23 #include "flang/Semantics/tools.h"
  24 #include <optional>
  25 #include <set>
  26 #include <string>
  27 #include <type_traits>
  28
  29 using namespace Fortran::parser::literals;
  30
  31 namespace Fortran::semantics {
  32
  33 class AssignmentContext {
  34 public:
  35   explicit AssignmentContext(SemanticsContext &context) : context_{context} {}
  36   AssignmentContext(AssignmentContext &&) = default;
  37   AssignmentContext(const AssignmentContext &) = delete;
  38   bool operator==(const AssignmentContext &x) const { return this == &x; }
  39
  40   template <typename A> void PushWhereContext(const A &);
  41   void PopWhereContext();
  42   void Analyze(const parser::AssignmentStmt &);
  43   void Analyze(const parser::PointerAssignmentStmt &);
  44   void Analyze(const parser::ConcurrentControl &);
  45
  46 private:
  47   bool CheckForPureContext(const SomeExpr &rhs, parser::CharBlock rhsSource,
  48       bool isPointerAssignment, bool isDefinedAssignment);
  49   void CheckShape(parser::CharBlock, const SomeExpr *);
  50   template <typename... A>
  51   parser::Message *Say(parser::CharBlock at, A &&...args) {
  52     return &context_.Say(at, std::forward<A>(args)...);
  53   }
  54   evaluate::FoldingContext &foldingContext() {
  55     return context_.foldingContext();
  56   }
  57
  58   SemanticsContext &context_;
  59   int whereDepth_{0}; // number of WHEREs currently nested in
  60   // shape of masks in LHS of assignments in current WHERE:
  61   std::vector<std::optional<std::int64_t>> whereExtents_;
  62 };
  63
  64 void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
  65   if (const evaluate::Assignment * assignment{GetAssignment(stmt)}) {
  66     const SomeExpr &lhs{assignment->lhs};
  67     const SomeExpr &rhs{assignment->rhs};
  68     auto lhsLoc{std::get<parser::Variable>(stmt.t).GetSource()};
  69     const Scope &scope{context_.FindScope(lhsLoc)};
  70     if (auto whyNot{WhyNotDefinable(lhsLoc, scope,
  71             DefinabilityFlags{DefinabilityFlag::VectorSubscriptIsOk}, lhs)}) {
  72       if (auto *msg{Say(lhsLoc,
  73               "Left-hand side of assignment is not definable"_err_en_US)}) {
  74         msg->Attach(std::move(*whyNot));
  75       }
  76     }
  77     auto rhsLoc{std::get<parser::Expr>(stmt.t).source};
  78     CheckForPureContext(rhs, rhsLoc, false /*not a pointer assignment*/,
  79         std::holds_alternative<evaluate::ProcedureRef>(assignment->u));
  80     if (whereDepth_ > 0) {
  81       CheckShape(lhsLoc, &lhs);
  82     }
  83   }
  84 }
  85
  86 void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &stmt) {
  87   CHECK(whereDepth_ == 0);
  88   if (const evaluate::Assignment * assignment{GetAssignment(stmt)}) {
  89     const SomeExpr &rhs{assignment->rhs};
  90     CheckForPureContext(rhs, std::get<parser::Expr>(stmt.t).source,
  91         true /*this is a pointer assignment*/,
  92         false /*not a defined assignment*/);
  93     parser::CharBlock at{context_.location().value()};
  94     auto restorer{foldingContext().messages().SetLocation(at)};
  95     const Scope &scope{context_.FindScope(at)};
  96     CheckPointerAssignment(foldingContext(), *assignment, scope);
  97   }
  98 }
  99
 100 static std::optional<std::string> GetPointerComponentDesignatorName(
 101     const SomeExpr &expr) {
 102   if (const auto *derived{
 103           evaluate::GetDerivedTypeSpec(evaluate::DynamicType::From(expr))}) {
 104     PotentialAndPointerComponentIterator potentials{*derived};
 105     if (auto pointer{
 106             std::find_if(potentials.begin(), potentials.end(), IsPointer)}) {
 107       return pointer.BuildResultDesignatorName();
 108     }
 109   }
 110   return std::nullopt;
 111 }
 112
 113 // Checks C1594(5,6); false if check fails
 114 bool CheckCopyabilityInPureScope(parser::ContextualMessages &messages,
 115     const SomeExpr &expr, const Scope &scope) {
 116   if (const Symbol * base{GetFirstSymbol(expr)}) {
 117     if (const char *why{
 118             WhyBaseObjectIsSuspicious(base->GetUltimate(), scope)}) {
 119       if (auto pointer{GetPointerComponentDesignatorName(expr)}) {
 120         evaluate::SayWithDeclaration(messages, *base,
 121             "A pure subprogram may not copy the value of '%s' because it is %s"
 122             " and has the POINTER potential subobject component '%s'"_err_en_US,
 123             base->name(), why, *pointer);
 124         return false;
 125       }
 126     }
 127   }
 128   return true;
 129 }
 130
 131 bool AssignmentContext::CheckForPureContext(const SomeExpr &rhs,
 132     parser::CharBlock rhsSource, bool isPointerAssignment,
 133     bool isDefinedAssignment) {
 134   const Scope &scope{context_.FindScope(rhsSource)};
 135   if (!FindPureProcedureContaining(scope)) {
 136     return true;
 137   }
 138   parser::ContextualMessages messages{
 139       context_.location().value(), &context_.messages()};
 140   if (isPointerAssignment) {
 141     if (const Symbol * base{GetFirstSymbol(rhs)}) {
 142       if (const char *why{WhyBaseObjectIsSuspicious(
 143               base->GetUltimate(), scope)}) { // C1594(3)
 144         evaluate::SayWithDeclaration(messages, *base,
 145             "A pure subprogram may not use '%s' as the target of pointer assignment because it is %s"_err_en_US,
 146             base->name(), why);
 147         return false;
 148       }
 149     }
 150   } else if (!isDefinedAssignment) {
 151     return CheckCopyabilityInPureScope(messages, rhs, scope);
 152   }
 153   return true;
 154 }
 155
 156 // 10.2.3.1(2) The masks and LHS of assignments must be arrays of the same shape
 157 void AssignmentContext::CheckShape(parser::CharBlock at, const SomeExpr *expr) {
 158   if (auto shape{evaluate::GetShape(foldingContext(), expr)}) {
 159     std::size_t size{shape->size()};
 160     if (size == 0) {
 161       Say(at, "The mask or variable must not be scalar"_err_en_US);
 162     }
 163     if (whereDepth_ == 0) {
 164       whereExtents_.resize(size);
 165     } else if (whereExtents_.size() != size) {
 166       Say(at,
 167           "Must have rank %zd to match prior mask or assignment of"
 168           " WHERE construct"_err_en_US,
 169           whereExtents_.size());
 170       return;
 171     }
 172     for (std::size_t i{0}; i < size; ++i) {
 173       if (std::optional<std::int64_t> extent{evaluate::ToInt64((*shape)[i])}) {
 174         if (!whereExtents_[i]) {
 175           whereExtents_[i] = *extent;
 176         } else if (*whereExtents_[i] != *extent) {
 177           Say(at,
 178               "Dimension %d must have extent %jd to match prior mask or"
 179               " assignment of WHERE construct"_err_en_US,
 180               i + 1, *whereExtents_[i]);
 181         }
 182       }
 183     }
 184   }
 185 }
 186
 187 template <typename A> void AssignmentContext::PushWhereContext(const A &x) {
 188   const auto &expr{std::get<parser::LogicalExpr>(x.t)};
 189   CheckShape(expr.thing.value().source, GetExpr(context_, expr));
 190   ++whereDepth_;
 191 }
 192
 193 void AssignmentContext::PopWhereContext() {
 194   --whereDepth_;
 195   if (whereDepth_ == 0) {
 196     whereExtents_.clear();
 197   }
 198 }
 199
 200 AssignmentChecker::~AssignmentChecker() {}
 201
 202 AssignmentChecker::AssignmentChecker(SemanticsContext &context)
 203     : context_{new AssignmentContext{context}} {}
 204 void AssignmentChecker::Enter(const parser::AssignmentStmt &x) {
 205   context_.value().Analyze(x);
 206 }
 207 void AssignmentChecker::Enter(const parser::PointerAssignmentStmt &x) {
 208   context_.value().Analyze(x);
 209 }
 210 void AssignmentChecker::Enter(const parser::WhereStmt &x) {
 211   context_.value().PushWhereContext(x);
 212 }
 213 void AssignmentChecker::Leave(const parser::WhereStmt &) {
 214   context_.value().PopWhereContext();
 215 }
 216 void AssignmentChecker::Enter(const parser::WhereConstructStmt &x) {
 217   context_.value().PushWhereContext(x);
 218 }
 219 void AssignmentChecker::Leave(const parser::EndWhereStmt &) {
 220   context_.value().PopWhereContext();
 221 }
 222 void AssignmentChecker::Enter(const parser::MaskedElsewhereStmt &x) {
 223   context_.value().PushWhereContext(x);
 224 }
 225 void AssignmentChecker::Leave(const parser::MaskedElsewhereStmt &) {
 226   context_.value().PopWhereContext();
 227 }
 228
 229 } // namespace Fortran::semantics
 230 template class Fortran::common::Indirection<
 231     Fortran::semantics::AssignmentContext>;