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:
AssignmentContext(SemanticsContext & context)34 explicit AssignmentContext(SemanticsContext &context) : context_{context} {}
35 AssignmentContext(AssignmentContext &&) = default;
36 AssignmentContext(const AssignmentContext &) = delete;
operator ==(const AssignmentContext & x) const37 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>
Say(parser::CharBlock at,A &&...args)50 parser::Message *Say(parser::CharBlock at, A &&...args) {
51 return &context_.Say(at, std::forward<A>(args)...);
52 }
foldingContext()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
Analyze(const parser::AssignmentStmt & stmt)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)}) { // C1158
74 msg->Attach(*whyNot);
75 }
76 }
77 }
78 if (whereDepth_ > 0) {
79 CheckShape(lhsLoc, &lhs);
80 }
81 }
82 }
83
Analyze(const parser::PointerAssignmentStmt & stmt)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
IsPointerDummyOfPureFunction(const Symbol & x)97 static bool IsPointerDummyOfPureFunction(const Symbol &x) {
98 return IsPointerDummy(x) && FindPureProcedureContaining(x.owner()) &&
99 x.owner().symbol() && IsFunction(*x.owner().symbol());
100 }
101
WhyBaseObjectIsSuspicious(const Symbol & x,const Scope & scope)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 (IsHostAssociated(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
CheckDefinabilityInPureScope(parser::ContextualMessages & messages,const Symbol & lhs,const Scope & context,const Scope & pure)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
GetPointerComponentDesignatorName(const SomeExpr & expr)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
CheckCopyabilityInPureScope(parser::ContextualMessages & messages,const SomeExpr & expr,const Scope & scope)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
CheckForPureContext(const SomeExpr & lhs,const SomeExpr & rhs,parser::CharBlock source,bool isPointerAssignment)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 all have the same shape
CheckShape(parser::CharBlock at,const SomeExpr * expr)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 (whereDepth_ == 0) {
224 whereExtents_.resize(size);
225 } else if (whereExtents_.size() != size) {
226 Say(at,
227 "Must have rank %zd to match prior mask or assignment of"
228 " WHERE construct"_err_en_US,
229 whereExtents_.size());
230 return;
231 }
232 for (std::size_t i{0}; i < size; ++i) {
233 if (std::optional<std::int64_t> extent{evaluate::ToInt64((*shape)[i])}) {
234 if (!whereExtents_[i]) {
235 whereExtents_[i] = *extent;
236 } else if (*whereExtents_[i] != *extent) {
237 Say(at,
238 "Dimension %d must have extent %jd to match prior mask or"
239 " assignment of WHERE construct"_err_en_US,
240 i + 1, *whereExtents_[i]);
241 }
242 }
243 }
244 }
245 }
246
PushWhereContext(const A & x)247 template <typename A> void AssignmentContext::PushWhereContext(const A &x) {
248 const auto &expr{std::get<parser::LogicalExpr>(x.t)};
249 CheckShape(expr.thing.value().source, GetExpr(expr));
250 ++whereDepth_;
251 }
252
PopWhereContext()253 void AssignmentContext::PopWhereContext() {
254 --whereDepth_;
255 if (whereDepth_ == 0) {
256 whereExtents_.clear();
257 }
258 }
259
~AssignmentChecker()260 AssignmentChecker::~AssignmentChecker() {}
261
AssignmentChecker(SemanticsContext & context)262 AssignmentChecker::AssignmentChecker(SemanticsContext &context)
263 : context_{new AssignmentContext{context}} {}
Enter(const parser::AssignmentStmt & x)264 void AssignmentChecker::Enter(const parser::AssignmentStmt &x) {
265 context_.value().Analyze(x);
266 }
Enter(const parser::PointerAssignmentStmt & x)267 void AssignmentChecker::Enter(const parser::PointerAssignmentStmt &x) {
268 context_.value().Analyze(x);
269 }
Enter(const parser::WhereStmt & x)270 void AssignmentChecker::Enter(const parser::WhereStmt &x) {
271 context_.value().PushWhereContext(x);
272 }
Leave(const parser::WhereStmt &)273 void AssignmentChecker::Leave(const parser::WhereStmt &) {
274 context_.value().PopWhereContext();
275 }
Enter(const parser::WhereConstructStmt & x)276 void AssignmentChecker::Enter(const parser::WhereConstructStmt &x) {
277 context_.value().PushWhereContext(x);
278 }
Leave(const parser::EndWhereStmt &)279 void AssignmentChecker::Leave(const parser::EndWhereStmt &) {
280 context_.value().PopWhereContext();
281 }
Enter(const parser::MaskedElsewhereStmt & x)282 void AssignmentChecker::Enter(const parser::MaskedElsewhereStmt &x) {
283 context_.value().PushWhereContext(x);
284 }
Leave(const parser::MaskedElsewhereStmt &)285 void AssignmentChecker::Leave(const parser::MaskedElsewhereStmt &) {
286 context_.value().PopWhereContext();
287 }
288
289 } // namespace Fortran::semantics
290 template class Fortran::common::Indirection<
291 Fortran::semantics::AssignmentContext>;
292