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 "pointer-assignment.h" 11 #include "flang/Common/idioms.h" 12 #include "flang/Common/restorer.h" 13 #include "flang/Evaluate/characteristics.h" 14 #include "flang/Evaluate/expression.h" 15 #include "flang/Evaluate/fold.h" 16 #include "flang/Evaluate/tools.h" 17 #include "flang/Parser/message.h" 18 #include "flang/Parser/parse-tree-visitor.h" 19 #include "flang/Parser/parse-tree.h" 20 #include "flang/Semantics/expression.h" 21 #include "flang/Semantics/symbol.h" 22 #include "flang/Semantics/tools.h" 23 #include <optional> 24 #include <set> 25 #include <string> 26 #include <type_traits> 27 28 using namespace Fortran::parser::literals; 29 30 namespace Fortran::semantics { 31 32 class AssignmentContext { 33 public: 34 explicit AssignmentContext(SemanticsContext &context) : context_{context} {} 35 AssignmentContext(AssignmentContext &&) = default; 36 AssignmentContext(const AssignmentContext &) = delete; 37 bool operator==(const AssignmentContext &x) const { return this == &x; } 38 39 template <typename A> void PushWhereContext(const A &); 40 void PopWhereContext(); 41 void Analyze(const parser::AssignmentStmt &); 42 void Analyze(const parser::PointerAssignmentStmt &); 43 void Analyze(const parser::ConcurrentControl &); 44 45 private: 46 bool CheckForPureContext(const SomeExpr &lhs, const SomeExpr &rhs, 47 parser::CharBlock rhsSource, bool isPointerAssignment); 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 auto rhsLoc{std::get<parser::Expr>(stmt.t).source}; 69 if (CheckForPureContext(lhs, rhs, rhsLoc, false)) { 70 const Scope &scope{context_.FindScope(lhsLoc)}; 71 if (auto whyNot{WhyNotModifiable(lhsLoc, lhs, scope, true)}) { 72 if (auto *msg{Say(lhsLoc, 73 "Left-hand side of assignment is not modifiable"_err_en_US)}) { 74 msg->Attach(*whyNot); 75 } 76 } 77 } 78 if (whereDepth_ > 0) { 79 CheckShape(lhsLoc, &lhs); 80 } 81 } 82 } 83 84 void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &stmt) { 85 CHECK(whereDepth_ == 0); 86 if (const evaluate::Assignment * assignment{GetAssignment(stmt)}) { 87 const SomeExpr &lhs{assignment->lhs}; 88 const SomeExpr &rhs{assignment->rhs}; 89 CheckForPureContext(lhs, rhs, std::get<parser::Expr>(stmt.t).source, true); 90 auto restorer{ 91 foldingContext().messages().SetLocation(context_.location().value())}; 92 CheckPointerAssignment(foldingContext(), *assignment); 93 } 94 } 95 96 // C1594 checks 97 static bool IsPointerDummyOfPureFunction(const Symbol &x) { 98 return IsPointerDummy(x) && FindPureProcedureContaining(x.owner()) && 99 x.owner().symbol() && IsFunction(*x.owner().symbol()); 100 } 101 102 static const char *WhyBaseObjectIsSuspicious( 103 const Symbol &x, const Scope &scope) { 104 // See C1594, first paragraph. These conditions enable checks on both 105 // left-hand and right-hand sides in various circumstances. 106 if (IsHostAssociatedIntoSubprogram(x, scope)) { 107 return "host-associated"; 108 } else if (IsUseAssociated(x, scope)) { 109 return "USE-associated"; 110 } else if (IsPointerDummyOfPureFunction(x)) { 111 return "a POINTER dummy argument of a pure function"; 112 } else if (IsIntentIn(x)) { 113 return "an INTENT(IN) dummy argument"; 114 } else if (FindCommonBlockContaining(x)) { 115 return "in a COMMON block"; 116 } else { 117 return nullptr; 118 } 119 } 120 121 // Checks C1594(1,2); false if check fails 122 bool CheckDefinabilityInPureScope(parser::ContextualMessages &messages, 123 const Symbol &lhs, const Scope &context, const Scope &pure) { 124 if (pure.symbol()) { 125 if (const char *why{WhyBaseObjectIsSuspicious(lhs, context)}) { 126 evaluate::SayWithDeclaration(messages, lhs, 127 "Pure subprogram '%s' may not define '%s' because it is %s"_err_en_US, 128 pure.symbol()->name(), lhs.name(), why); 129 return false; 130 } 131 } 132 return true; 133 } 134 135 static std::optional<std::string> GetPointerComponentDesignatorName( 136 const SomeExpr &expr) { 137 if (const auto *derived{ 138 evaluate::GetDerivedTypeSpec(evaluate::DynamicType::From(expr))}) { 139 UltimateComponentIterator ultimates{*derived}; 140 if (auto pointer{ 141 std::find_if(ultimates.begin(), ultimates.end(), IsPointer)}) { 142 return pointer.BuildResultDesignatorName(); 143 } 144 } 145 return std::nullopt; 146 } 147 148 // Checks C1594(5,6); false if check fails 149 bool CheckCopyabilityInPureScope(parser::ContextualMessages &messages, 150 const SomeExpr &expr, const Scope &scope) { 151 if (const Symbol * base{GetFirstSymbol(expr)}) { 152 if (const char *why{WhyBaseObjectIsSuspicious(*base, scope)}) { 153 if (auto pointer{GetPointerComponentDesignatorName(expr)}) { 154 evaluate::SayWithDeclaration(messages, *base, 155 "A pure subprogram may not copy the value of '%s' because it is %s" 156 " and has the POINTER component '%s'"_err_en_US, 157 base->name(), why, *pointer); 158 return false; 159 } 160 } 161 } 162 return true; 163 } 164 165 bool AssignmentContext::CheckForPureContext(const SomeExpr &lhs, 166 const SomeExpr &rhs, parser::CharBlock source, bool isPointerAssignment) { 167 const Scope &scope{context_.FindScope(source)}; 168 if (const Scope * pure{FindPureProcedureContaining(scope)}) { 169 parser::ContextualMessages messages{ 170 context_.location().value(), &context_.messages()}; 171 if (evaluate::ExtractCoarrayRef(lhs)) { 172 messages.Say( 173 "A pure subprogram may not define a coindexed object"_err_en_US); 174 } else if (const Symbol * base{GetFirstSymbol(lhs)}) { 175 if (const auto *assoc{base->detailsIf<AssocEntityDetails>()}) { 176 auto dataRef{ExtractDataRef(assoc->expr(), true)}; 177 // ASSOCIATE(a=>x) -- check x, not a, for "a=..." 178 base = dataRef ? &dataRef->GetFirstSymbol() : nullptr; 179 } 180 if (base && 181 !CheckDefinabilityInPureScope(messages, *base, scope, *pure)) { 182 return false; 183 } 184 } 185 if (isPointerAssignment) { 186 if (const Symbol * base{GetFirstSymbol(rhs)}) { 187 if (const char *why{ 188 WhyBaseObjectIsSuspicious(*base, scope)}) { // C1594(3) 189 evaluate::SayWithDeclaration(messages, *base, 190 "A pure subprogram may not use '%s' as the target of pointer assignment because it is %s"_err_en_US, 191 base->name(), why); 192 return false; 193 } 194 } 195 } else if (auto type{evaluate::DynamicType::From(lhs)}) { 196 // C1596 checks for polymorphic deallocation in a pure subprogram 197 // due to automatic reallocation on assignment 198 if (type->IsPolymorphic()) { 199 context_.Say( 200 "Deallocation of polymorphic object is not permitted in a pure subprogram"_err_en_US); 201 return false; 202 } 203 if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(type)}) { 204 if (auto bad{FindPolymorphicAllocatableNonCoarrayUltimateComponent( 205 *derived)}) { 206 evaluate::SayWithDeclaration(messages, *bad, 207 "Deallocation of polymorphic non-coarray component '%s' is not permitted in a pure subprogram"_err_en_US, 208 bad.BuildResultDesignatorName()); 209 return false; 210 } else { 211 return CheckCopyabilityInPureScope(messages, rhs, scope); 212 } 213 } 214 } 215 } 216 return true; 217 } 218 219 // 10.2.3.1(2) The masks and LHS of assignments must be arrays of the same shape 220 void AssignmentContext::CheckShape(parser::CharBlock at, const SomeExpr *expr) { 221 if (auto shape{evaluate::GetShape(foldingContext(), expr)}) { 222 std::size_t size{shape->size()}; 223 if (size == 0) { 224 Say(at, "The mask or variable must not be scalar"_err_en_US); 225 } 226 if (whereDepth_ == 0) { 227 whereExtents_.resize(size); 228 } else if (whereExtents_.size() != size) { 229 Say(at, 230 "Must have rank %zd to match prior mask or assignment of" 231 " WHERE construct"_err_en_US, 232 whereExtents_.size()); 233 return; 234 } 235 for (std::size_t i{0}; i < size; ++i) { 236 if (std::optional<std::int64_t> extent{evaluate::ToInt64((*shape)[i])}) { 237 if (!whereExtents_[i]) { 238 whereExtents_[i] = *extent; 239 } else if (*whereExtents_[i] != *extent) { 240 Say(at, 241 "Dimension %d must have extent %jd to match prior mask or" 242 " assignment of WHERE construct"_err_en_US, 243 i + 1, *whereExtents_[i]); 244 } 245 } 246 } 247 } 248 } 249 250 template <typename A> void AssignmentContext::PushWhereContext(const A &x) { 251 const auto &expr{std::get<parser::LogicalExpr>(x.t)}; 252 CheckShape(expr.thing.value().source, GetExpr(context_, expr)); 253 ++whereDepth_; 254 } 255 256 void AssignmentContext::PopWhereContext() { 257 --whereDepth_; 258 if (whereDepth_ == 0) { 259 whereExtents_.clear(); 260 } 261 } 262 263 AssignmentChecker::~AssignmentChecker() {} 264 265 AssignmentChecker::AssignmentChecker(SemanticsContext &context) 266 : context_{new AssignmentContext{context}} {} 267 void AssignmentChecker::Enter(const parser::AssignmentStmt &x) { 268 context_.value().Analyze(x); 269 } 270 void AssignmentChecker::Enter(const parser::PointerAssignmentStmt &x) { 271 context_.value().Analyze(x); 272 } 273 void AssignmentChecker::Enter(const parser::WhereStmt &x) { 274 context_.value().PushWhereContext(x); 275 } 276 void AssignmentChecker::Leave(const parser::WhereStmt &) { 277 context_.value().PopWhereContext(); 278 } 279 void AssignmentChecker::Enter(const parser::WhereConstructStmt &x) { 280 context_.value().PushWhereContext(x); 281 } 282 void AssignmentChecker::Leave(const parser::EndWhereStmt &) { 283 context_.value().PopWhereContext(); 284 } 285 void AssignmentChecker::Enter(const parser::MaskedElsewhereStmt &x) { 286 context_.value().PushWhereContext(x); 287 } 288 void AssignmentChecker::Leave(const parser::MaskedElsewhereStmt &) { 289 context_.value().PopWhereContext(); 290 } 291 292 } // namespace Fortran::semantics 293 template class Fortran::common::Indirection< 294 Fortran::semantics::AssignmentContext>; 295