xref: /llvm-project/flang/lib/Semantics/assignment.cpp (revision 1fa9ef620ba61c800040091b97acc26cbaa6d2f4)
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