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>; 232