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

source code of flang/lib/Semantics/assignment.cpp