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

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