• Home
  • Line#
  • Scopes#
  • Navigate#
  • Raw
  • Download
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