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