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