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 int deviceConstructDepth_{0};
46 SemanticsContext &context() { return context_; }
47
48private:
49 bool CheckForPureContext(const SomeExpr &rhs, parser::CharBlock rhsSource);
50 void CheckShape(parser::CharBlock, const SomeExpr *);
51 template <typename... A>
52 parser::Message *Say(parser::CharBlock at, A &&...args) {
53 return &context_.Say(at, std::forward<A>(args)...);
54 }
55 evaluate::FoldingContext &foldingContext() {
56 return context_.foldingContext();
57 }
58
59 SemanticsContext &context_;
60 int whereDepth_{0}; // number of WHEREs currently nested in
61 // shape of masks in LHS of assignments in current WHERE:
62 std::vector<std::optional<std::int64_t>> whereExtents_;
63};
64
65void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
66 if (const evaluate::Assignment * assignment{GetAssignment(stmt)}) {
67 const SomeExpr &lhs{assignment->lhs};
68 const SomeExpr &rhs{assignment->rhs};
69 auto lhsLoc{std::get<parser::Variable>(stmt.t).GetSource()};
70 const Scope &scope{context_.FindScope(lhsLoc)};
71 DefinabilityFlags flags{DefinabilityFlag::VectorSubscriptIsOk};
72 bool isDefinedAssignment{
73 std::holds_alternative<evaluate::ProcedureRef>(assignment->u)};
74 if (isDefinedAssignment) {
75 flags.set(DefinabilityFlag::AllowEventLockOrNotifyType);
76 } else if (const Symbol *
77 whole{evaluate::UnwrapWholeSymbolOrComponentDataRef(lhs)}) {
78 if (IsAllocatable(whole->GetUltimate())) {
79 flags.set(DefinabilityFlag::PotentialDeallocation);
80 }
81 }
82 if (auto whyNot{WhyNotDefinable(lhsLoc, scope, flags, lhs)}) {
83 if (whyNot->IsFatal()) {
84 if (auto *msg{Say(lhsLoc,
85 "Left-hand side of assignment is not definable"_err_en_US)}) {
86 msg->Attach(
87 std::move(whyNot->set_severity(parser::Severity::Because)));
88 }
89 } else {
90 context_.Say(std::move(*whyNot));
91 }
92 }
93 auto rhsLoc{std::get<parser::Expr>(stmt.t).source};
94 if (!isDefinedAssignment) {
95 CheckForPureContext(rhs, rhsLoc);
96 }
97 if (whereDepth_ > 0) {
98 CheckShape(lhsLoc, &lhs);
99 }
100 if (context_.foldingContext().languageFeatures().IsEnabled(
101 common::LanguageFeature::CUDA)) {
102 const auto &scope{context_.FindScope(lhsLoc)};
103 const Scope &progUnit{GetProgramUnitContaining(scope)};
104 if (!IsCUDADeviceContext(&progUnit) && deviceConstructDepth_ == 0) {
105 if (Fortran::evaluate::HasCUDADeviceAttrs(lhs) &&
106 Fortran::evaluate::HasCUDAImplicitTransfer(rhs)) {
107 if (GetNbOfCUDAManagedOrUnifiedSymbols(lhs) == 1 &&
108 GetNbOfCUDAManagedOrUnifiedSymbols(rhs) == 1 &&
109 GetNbOfCUDADeviceSymbols(rhs) == 1)
110 return; // This is a special case handled on the host.
111 context_.Say(lhsLoc, "Unsupported CUDA data transfer"_err_en_US);
112 }
113 }
114 }
115 }
116}
117
118void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &stmt) {
119 CHECK(whereDepth_ == 0);
120 if (const evaluate::Assignment * assignment{GetAssignment(stmt)}) {
121 parser::CharBlock at{context_.location().value()};
122 auto restorer{foldingContext().messages().SetLocation(at)};
123 CheckPointerAssignment(context_, *assignment, context_.FindScope(at));
124 }
125}
126
127static std::optional<std::string> GetPointerComponentDesignatorName(
128 const SomeExpr &expr) {
129 if (const auto *derived{
130 evaluate::GetDerivedTypeSpec(evaluate::DynamicType::From(expr))}) {
131 PotentialAndPointerComponentIterator potentials{*derived};
132 if (auto pointer{
133 std::find_if(potentials.begin(), potentials.end(), IsPointer)}) {
134 return pointer.BuildResultDesignatorName();
135 }
136 }
137 return std::nullopt;
138}
139
140// Checks C1594(5,6); false if check fails
141bool CheckCopyabilityInPureScope(parser::ContextualMessages &messages,
142 const SomeExpr &expr, const Scope &scope) {
143 if (auto pointer{GetPointerComponentDesignatorName(expr)}) {
144 if (const Symbol * base{GetFirstSymbol(expr)}) {
145 const char *why{WhyBaseObjectIsSuspicious(base->GetUltimate(), scope)};
146 if (!why) {
147 if (auto coarray{evaluate::ExtractCoarrayRef(expr)}) {
148 base = &coarray->GetLastSymbol();
149 why = "coindexed";
150 }
151 }
152 if (why) {
153 evaluate::SayWithDeclaration(messages, *base,
154 "A pure subprogram may not copy the value of '%s' because it is %s"
155 " and has the POINTER potential subobject component '%s'"_err_en_US,
156 base->name(), why, *pointer);
157 return false;
158 }
159 }
160 }
161 return true;
162}
163
164bool AssignmentContext::CheckForPureContext(
165 const SomeExpr &rhs, parser::CharBlock rhsSource) {
166 const Scope &scope{context_.FindScope(rhsSource)};
167 if (FindPureProcedureContaining(scope)) {
168 parser::ContextualMessages messages{
169 context_.location().value(), &context_.messages()};
170 return CheckCopyabilityInPureScope(messages, rhs, scope);
171 } else {
172 return true;
173 }
174}
175
176// 10.2.3.1(2) The masks and LHS of assignments must be arrays of the same shape
177void AssignmentContext::CheckShape(parser::CharBlock at, const SomeExpr *expr) {
178 if (auto shape{evaluate::GetShape(foldingContext(), expr)}) {
179 std::size_t size{shape->size()};
180 if (size == 0) {
181 Say(at, "The mask or variable must not be scalar"_err_en_US);
182 }
183 if (whereDepth_ == 0) {
184 whereExtents_.resize(size);
185 } else if (whereExtents_.size() != size) {
186 Say(at,
187 "Must have rank %zd to match prior mask or assignment of"
188 " WHERE construct"_err_en_US,
189 whereExtents_.size());
190 return;
191 }
192 for (std::size_t i{0}; i < size; ++i) {
193 if (std::optional<std::int64_t> extent{evaluate::ToInt64((*shape)[i])}) {
194 if (!whereExtents_[i]) {
195 whereExtents_[i] = *extent;
196 } else if (*whereExtents_[i] != *extent) {
197 Say(at,
198 "Dimension %d must have extent %jd to match prior mask or"
199 " assignment of WHERE construct"_err_en_US,
200 i + 1, *whereExtents_[i]);
201 }
202 }
203 }
204 }
205}
206
207template <typename A> void AssignmentContext::PushWhereContext(const A &x) {
208 const auto &expr{std::get<parser::LogicalExpr>(x.t)};
209 CheckShape(expr.thing.value().source, GetExpr(context_, expr));
210 ++whereDepth_;
211}
212
213void AssignmentContext::PopWhereContext() {
214 --whereDepth_;
215 if (whereDepth_ == 0) {
216 whereExtents_.clear();
217 }
218}
219
220AssignmentChecker::~AssignmentChecker() {}
221
222SemanticsContext &AssignmentChecker::context() {
223 return context_.value().context();
224}
225
226AssignmentChecker::AssignmentChecker(SemanticsContext &context)
227 : context_{new AssignmentContext{context}} {}
228
229void AssignmentChecker::Enter(
230 const parser::OpenMPDeclareReductionConstruct &x) {
231 context().set_location(x.source);
232}
233void AssignmentChecker::Enter(const parser::AssignmentStmt &x) {
234 context_.value().Analyze(x);
235}
236void AssignmentChecker::Enter(const parser::PointerAssignmentStmt &x) {
237 context_.value().Analyze(x);
238}
239void AssignmentChecker::Enter(const parser::WhereStmt &x) {
240 context_.value().PushWhereContext(x);
241}
242void AssignmentChecker::Leave(const parser::WhereStmt &) {
243 context_.value().PopWhereContext();
244}
245void AssignmentChecker::Enter(const parser::WhereConstructStmt &x) {
246 context_.value().PushWhereContext(x);
247}
248void AssignmentChecker::Leave(const parser::EndWhereStmt &) {
249 context_.value().PopWhereContext();
250}
251void AssignmentChecker::Enter(const parser::MaskedElsewhereStmt &x) {
252 context_.value().PushWhereContext(x);
253}
254void AssignmentChecker::Leave(const parser::MaskedElsewhereStmt &) {
255 context_.value().PopWhereContext();
256}
257void AssignmentChecker::Enter(const parser::CUFKernelDoConstruct &x) {
258 ++context_.value().deviceConstructDepth_;
259}
260void AssignmentChecker::Leave(const parser::CUFKernelDoConstruct &) {
261 --context_.value().deviceConstructDepth_;
262}
263static bool IsOpenACCComputeConstruct(const parser::OpenACCBlockConstruct &x) {
264 const auto &beginBlockDirective =
265 std::get<Fortran::parser::AccBeginBlockDirective>(x.t);
266 const auto &blockDirective =
267 std::get<Fortran::parser::AccBlockDirective>(beginBlockDirective.t);
268 if (blockDirective.v == llvm::acc::ACCD_parallel ||
269 blockDirective.v == llvm::acc::ACCD_serial ||
270 blockDirective.v == llvm::acc::ACCD_kernels) {
271 return true;
272 }
273 return false;
274}
275void AssignmentChecker::Enter(const parser::OpenACCBlockConstruct &x) {
276 if (IsOpenACCComputeConstruct(x)) {
277 ++context_.value().deviceConstructDepth_;
278 }
279}
280void AssignmentChecker::Leave(const parser::OpenACCBlockConstruct &x) {
281 if (IsOpenACCComputeConstruct(x)) {
282 --context_.value().deviceConstructDepth_;
283 }
284}
285void AssignmentChecker::Enter(const parser::OpenACCCombinedConstruct &) {
286 ++context_.value().deviceConstructDepth_;
287}
288void AssignmentChecker::Leave(const parser::OpenACCCombinedConstruct &) {
289 --context_.value().deviceConstructDepth_;
290}
291void AssignmentChecker::Enter(const parser::OpenACCLoopConstruct &) {
292 ++context_.value().deviceConstructDepth_;
293}
294void AssignmentChecker::Leave(const parser::OpenACCLoopConstruct &) {
295 --context_.value().deviceConstructDepth_;
296}
297
298} // namespace Fortran::semantics
299template class Fortran::common::Indirection<
300 Fortran::semantics::AssignmentContext>;
301

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