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