xref: /llvm-project/flang/lib/Semantics/pointer-assignment.cpp (revision c757418869c01f5ee08f05661debabbba92edcf9) 
1 //===-- lib/Semantics/pointer-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 "pointer-assignment.h"
10 #include "flang/Common/idioms.h"
11 #include "flang/Common/restorer.h"
12 #include "flang/Evaluate/characteristics.h"
13 #include "flang/Evaluate/expression.h"
14 #include "flang/Evaluate/fold.h"
15 #include "flang/Evaluate/tools.h"
16 #include "flang/Parser/message.h"
17 #include "flang/Parser/parse-tree-visitor.h"
18 #include "flang/Parser/parse-tree.h"
19 #include "flang/Semantics/expression.h"
20 #include "flang/Semantics/symbol.h"
21 #include "flang/Semantics/tools.h"
22 #include "llvm/Support/raw_ostream.h"
23 #include <optional>
24 #include <set>
25 #include <string>
26 #include <type_traits>
27 
28 // Semantic checks for pointer assignment.
29 
30 namespace Fortran::semantics {
31 
32 using namespace parser::literals;
33 using evaluate::characteristics::DummyDataObject;
34 using evaluate::characteristics::FunctionResult;
35 using evaluate::characteristics::Procedure;
36 using evaluate::characteristics::TypeAndShape;
37 using parser::MessageFixedText;
38 using parser::MessageFormattedText;
39 
40 class PointerAssignmentChecker {
41 public:
42   PointerAssignmentChecker(evaluate::FoldingContext &context,
43       parser::CharBlock source, const std::string &description)
44       : context_{context}, source_{source}, description_{description} {}
45   PointerAssignmentChecker(evaluate::FoldingContext &context, const Symbol &lhs)
46       : context_{context}, source_{lhs.name()},
47         description_{"pointer '"s + lhs.name().ToString() + '\''}, lhs_{&lhs},
48         procedure_{Procedure::Characterize(lhs, context.intrinsics())} {
49     set_lhsType(TypeAndShape::Characterize(lhs, context));
50     set_isContiguous(lhs.attrs().test(Attr::CONTIGUOUS));
51     set_isVolatile(lhs.attrs().test(Attr::VOLATILE));
52   }
53   PointerAssignmentChecker &set_lhsType(std::optional<TypeAndShape> &&);
54   PointerAssignmentChecker &set_isContiguous(bool);
55   PointerAssignmentChecker &set_isVolatile(bool);
56   PointerAssignmentChecker &set_isBoundsRemapping(bool);
57   bool Check(const SomeExpr &);
58 
59 private:
60   template <typename T> bool Check(const T &);
61   template <typename T> bool Check(const evaluate::Expr<T> &);
62   template <typename T> bool Check(const evaluate::FunctionRef<T> &);
63   template <typename T> bool Check(const evaluate::Designator<T> &);
64   bool Check(const evaluate::NullPointer &);
65   bool Check(const evaluate::ProcedureDesignator &);
66   bool Check(const evaluate::ProcedureRef &);
67   // Target is a procedure
68   bool Check(
69       parser::CharBlock rhsName, bool isCall, const Procedure * = nullptr);
70   bool LhsOkForUnlimitedPoly() const;
71   template <typename... A> parser::Message *Say(A &&...);
72 
73   evaluate::FoldingContext &context_;
74   const parser::CharBlock source_;
75   const std::string description_;
76   const Symbol *lhs_{nullptr};
77   std::optional<TypeAndShape> lhsType_;
78   std::optional<Procedure> procedure_;
79   bool isContiguous_{false};
80   bool isVolatile_{false};
81   bool isBoundsRemapping_{false};
82 };
83 
84 PointerAssignmentChecker &PointerAssignmentChecker::set_lhsType(
85     std::optional<TypeAndShape> &&lhsType) {
86   lhsType_ = std::move(lhsType);
87   return *this;
88 }
89 
90 PointerAssignmentChecker &PointerAssignmentChecker::set_isContiguous(
91     bool isContiguous) {
92   isContiguous_ = isContiguous;
93   return *this;
94 }
95 
96 PointerAssignmentChecker &PointerAssignmentChecker::set_isVolatile(
97     bool isVolatile) {
98   isVolatile_ = isVolatile;
99   return *this;
100 }
101 
102 PointerAssignmentChecker &PointerAssignmentChecker::set_isBoundsRemapping(
103     bool isBoundsRemapping) {
104   isBoundsRemapping_ = isBoundsRemapping;
105   return *this;
106 }
107 
108 template <typename T> bool PointerAssignmentChecker::Check(const T &) {
109   // Catch-all case for really bad target expression
110   Say("Target associated with %s must be a designator or a call to a"
111       " pointer-valued function"_err_en_US,
112       description_);
113   return false;
114 }
115 
116 template <typename T>
117 bool PointerAssignmentChecker::Check(const evaluate::Expr<T> &x) {
118   return std::visit([&](const auto &x) { return Check(x); }, x.u);
119 }
120 
121 bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
122   if (HasVectorSubscript(rhs)) { // C1025
123     Say("An array section with a vector subscript may not be a pointer target"_err_en_US);
124     return false;
125   } else if (ExtractCoarrayRef(rhs)) { // C1026
126     Say("A coindexed object may not be a pointer target"_err_en_US);
127     return false;
128   } else {
129     return std::visit([&](const auto &x) { return Check(x); }, rhs.u);
130   }
131 }
132 
133 bool PointerAssignmentChecker::Check(const evaluate::NullPointer &) {
134   return true; // P => NULL() without MOLD=; always OK
135 }
136 
137 template <typename T>
138 bool PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
139   std::string funcName;
140   const auto *symbol{f.proc().GetSymbol()};
141   if (symbol) {
142     funcName = symbol->name().ToString();
143   } else if (const auto *intrinsic{f.proc().GetSpecificIntrinsic()}) {
144     funcName = intrinsic->name;
145   }
146   auto proc{Procedure::Characterize(f.proc(), context_.intrinsics())};
147   if (!proc) {
148     return false;
149   }
150   std::optional<MessageFixedText> msg;
151   const auto &funcResult{proc->functionResult}; // C1025
152   if (!funcResult) {
153     msg = "%s is associated with the non-existent result of reference to"
154           " procedure"_err_en_US;
155   } else if (procedure_) {
156     // Shouldn't be here in this function unless lhs is an object pointer.
157     msg = "Procedure %s is associated with the result of a reference to"
158           " function '%s' that does not return a procedure pointer"_err_en_US;
159   } else if (funcResult->IsProcedurePointer()) {
160     msg = "Object %s is associated with the result of a reference to"
161           " function '%s' that is a procedure pointer"_err_en_US;
162   } else if (!funcResult->attrs.test(FunctionResult::Attr::Pointer)) {
163     msg = "%s is associated with the result of a reference to function '%s'"
164           " that is a not a pointer"_err_en_US;
165   } else if (isContiguous_ &&
166       !funcResult->attrs.test(FunctionResult::Attr::Contiguous)) {
167     msg = "CONTIGUOUS %s is associated with the result of reference to"
168           " function '%s' that is not contiguous"_err_en_US;
169   } else if (lhsType_) {
170     const auto *frTypeAndShape{funcResult->GetTypeAndShape()};
171     CHECK(frTypeAndShape);
172     if (!lhsType_->IsCompatibleWith(context_.messages(), *frTypeAndShape)) {
173       msg = "%s is associated with the result of a reference to function '%s'"
174             " whose pointer result has an incompatible type or shape"_err_en_US;
175     }
176   }
177   if (msg) {
178     auto restorer{common::ScopedSet(lhs_, symbol)};
179     Say(*msg, description_, funcName);
180     return false;
181   }
182   return true;
183 }
184 
185 template <typename T>
186 bool PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
187   const Symbol *last{d.GetLastSymbol()};
188   const Symbol *base{d.GetBaseObject().symbol()};
189   if (!last || !base) {
190     // P => "character literal"(1:3)
191     context_.messages().Say("Pointer target is not a named entity"_err_en_US);
192     return false;
193   }
194   std::optional<std::variant<MessageFixedText, MessageFormattedText>> msg;
195   if (procedure_) {
196     // Shouldn't be here in this function unless lhs is an object pointer.
197     msg = "In assignment to procedure %s, the target is not a procedure or"
198           " procedure pointer"_err_en_US;
199   } else if (!evaluate::GetLastTarget(GetSymbolVector(d))) { // C1025
200     msg = "In assignment to object %s, the target '%s' is not an object with"
201           " POINTER or TARGET attributes"_err_en_US;
202   } else if (auto rhsType{TypeAndShape::Characterize(d, context_)}) {
203     if (!lhsType_) {
204       msg = "%s associated with object '%s' with incompatible type or"
205             " shape"_err_en_US;
206     } else if (rhsType->corank() > 0 &&
207         (isVolatile_ != last->attrs().test(Attr::VOLATILE))) { // C1020
208       // TODO: what if A is VOLATILE in A%B%C?  need a better test here
209       if (isVolatile_) {
210         msg = "Pointer may not be VOLATILE when target is a"
211               " non-VOLATILE coarray"_err_en_US;
212       } else {
213         msg = "Pointer must be VOLATILE when target is a"
214               " VOLATILE coarray"_err_en_US;
215       }
216     } else if (rhsType->type().IsUnlimitedPolymorphic()) {
217       if (!LhsOkForUnlimitedPoly()) {
218         msg = "Pointer type must be unlimited polymorphic or non-extensible"
219               " derived type when target is unlimited polymorphic"_err_en_US;
220       }
221     } else {
222       if (!lhsType_->type().IsTkCompatibleWith(rhsType->type())) {
223         msg = MessageFormattedText{
224             "Target type %s is not compatible with pointer type %s"_err_en_US,
225             rhsType->type().AsFortran(), lhsType_->type().AsFortran()};
226 
227       } else if (!isBoundsRemapping_) {
228         int lhsRank{evaluate::GetRank(lhsType_->shape())};
229         int rhsRank{evaluate::GetRank(rhsType->shape())};
230         if (lhsRank != rhsRank) {
231           msg = MessageFormattedText{
232               "Pointer has rank %d but target has rank %d"_err_en_US, lhsRank,
233               rhsRank};
234         }
235       }
236     }
237   }
238   if (msg) {
239     auto restorer{common::ScopedSet(lhs_, last)};
240     if (auto *m{std::get_if<MessageFixedText>(&*msg)}) {
241       std::string buf;
242       llvm::raw_string_ostream ss{buf};
243       d.AsFortran(ss);
244       Say(*m, description_, ss.str());
245     } else {
246       Say(std::get<MessageFormattedText>(*msg));
247     }
248     return false;
249   }
250   return true;
251 }
252 
253 // Common handling for procedure pointer right-hand sides
254 bool PointerAssignmentChecker::Check(
255     parser::CharBlock rhsName, bool isCall, const Procedure *rhsProcedure) {
256   if (std::optional<MessageFixedText> msg{
257           evaluate::CheckProcCompatibility(isCall, procedure_, rhsProcedure)}) {
258     Say(std::move(*msg), description_, rhsName);
259     return false;
260   }
261   return true;
262 }
263 
264 bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
265   if (auto chars{Procedure::Characterize(d, context_.intrinsics())}) {
266     return Check(d.GetName(), false, &*chars);
267   } else {
268     return Check(d.GetName(), false);
269   }
270 }
271 
272 bool PointerAssignmentChecker::Check(const evaluate::ProcedureRef &ref) {
273   const Procedure *procedure{nullptr};
274   auto chars{Procedure::Characterize(ref, context_.intrinsics())};
275   if (chars) {
276     procedure = &*chars;
277     if (chars->functionResult) {
278       if (const auto *proc{chars->functionResult->IsProcedurePointer()}) {
279         procedure = proc;
280       }
281     }
282   }
283   return Check(ref.proc().GetName(), true, procedure);
284 }
285 
286 // The target can be unlimited polymorphic if the pointer is, or if it is
287 // a non-extensible derived type.
288 bool PointerAssignmentChecker::LhsOkForUnlimitedPoly() const {
289   const auto &type{lhsType_->type()};
290   if (type.category() != TypeCategory::Derived || type.IsAssumedType()) {
291     return false;
292   } else if (type.IsUnlimitedPolymorphic()) {
293     return true;
294   } else {
295     return !IsExtensibleType(&type.GetDerivedTypeSpec());
296   }
297 }
298 
299 template <typename... A>
300 parser::Message *PointerAssignmentChecker::Say(A &&...x) {
301   auto *msg{context_.messages().Say(std::forward<A>(x)...)};
302   if (lhs_) {
303     return evaluate::AttachDeclaration(msg, *lhs_);
304   } else if (!source_.empty()) {
305     msg->Attach(source_, "Declaration of %s"_en_US, description_);
306   }
307   return msg;
308 }
309 
310 // Verify that any bounds on the LHS of a pointer assignment are valid.
311 // Return true if it is a bound-remapping so we can perform further checks.
312 static bool CheckPointerBounds(
313     evaluate::FoldingContext &context, const evaluate::Assignment &assignment) {
314   auto &messages{context.messages()};
315   const SomeExpr &lhs{assignment.lhs};
316   const SomeExpr &rhs{assignment.rhs};
317   bool isBoundsRemapping{false};
318   std::size_t numBounds{std::visit(
319       common::visitors{
320           [&](const evaluate::Assignment::BoundsSpec &bounds) {
321             return bounds.size();
322           },
323           [&](const evaluate::Assignment::BoundsRemapping &bounds) {
324             isBoundsRemapping = true;
325             evaluate::ExtentExpr lhsSizeExpr{1};
326             for (const auto &bound : bounds) {
327               lhsSizeExpr = std::move(lhsSizeExpr) *
328                   (common::Clone(bound.second) - common::Clone(bound.first) +
329                       evaluate::ExtentExpr{1});
330             }
331             if (std::optional<std::int64_t> lhsSize{evaluate::ToInt64(
332                     evaluate::Fold(context, std::move(lhsSizeExpr)))}) {
333               if (auto shape{evaluate::GetShape(context, rhs)}) {
334                 if (std::optional<std::int64_t> rhsSize{
335                         evaluate::ToInt64(evaluate::Fold(
336                             context, evaluate::GetSize(std::move(*shape))))}) {
337                   if (*lhsSize > *rhsSize) {
338                     messages.Say(
339                         "Pointer bounds require %d elements but target has"
340                         " only %d"_err_en_US,
341                         *lhsSize, *rhsSize); // 10.2.2.3(9)
342                   }
343                 }
344               }
345             }
346             return bounds.size();
347           },
348           [](const auto &) -> std::size_t {
349             DIE("not valid for pointer assignment");
350           },
351       },
352       assignment.u)};
353   if (numBounds > 0) {
354     if (lhs.Rank() != static_cast<int>(numBounds)) {
355       messages.Say("Pointer '%s' has rank %d but the number of bounds specified"
356                    " is %d"_err_en_US,
357           lhs.AsFortran(), lhs.Rank(), numBounds); // C1018
358     }
359   }
360   if (isBoundsRemapping && rhs.Rank() != 1 &&
361       !evaluate::IsSimplyContiguous(rhs, context.intrinsics())) {
362     messages.Say("Pointer bounds remapping target must have rank 1 or be"
363                  " simply contiguous"_err_en_US); // 10.2.2.3(9)
364   }
365   return isBoundsRemapping;
366 }
367 
368 bool CheckPointerAssignment(
369     evaluate::FoldingContext &context, const evaluate::Assignment &assignment) {
370   return CheckPointerAssignment(context, assignment.lhs, assignment.rhs,
371       CheckPointerBounds(context, assignment));
372 }
373 
374 bool CheckPointerAssignment(evaluate::FoldingContext &context,
375     const SomeExpr &lhs, const SomeExpr &rhs, bool isBoundsRemapping) {
376   const Symbol *pointer{GetLastSymbol(lhs)};
377   if (!pointer) {
378     return false; // error was reported
379   }
380   if (!IsPointer(*pointer)) {
381     evaluate::SayWithDeclaration(context.messages(), *pointer,
382         "'%s' is not a pointer"_err_en_US, pointer->name());
383     return false;
384   }
385   if (pointer->has<ProcEntityDetails>() && evaluate::ExtractCoarrayRef(lhs)) {
386     context.messages().Say( // C1027
387         "Procedure pointer may not be a coindexed object"_err_en_US);
388     return false;
389   }
390   return PointerAssignmentChecker{context, *pointer}
391       .set_isBoundsRemapping(isBoundsRemapping)
392       .Check(rhs);
393 }
394 
395 bool CheckPointerAssignment(
396     evaluate::FoldingContext &context, const Symbol &lhs, const SomeExpr &rhs) {
397   CHECK(IsPointer(lhs));
398   return PointerAssignmentChecker{context, lhs}.Check(rhs);
399 }
400 
401 bool CheckPointerAssignment(evaluate::FoldingContext &context,
402     parser::CharBlock source, const std::string &description,
403     const DummyDataObject &lhs, const SomeExpr &rhs) {
404   return PointerAssignmentChecker{context, source, description}
405       .set_lhsType(common::Clone(lhs.type))
406       .set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous))
407       .set_isVolatile(lhs.attrs.test(DummyDataObject::Attr::Volatile))
408       .Check(rhs);
409 }
410 
411 bool CheckInitialTarget(evaluate::FoldingContext &context,
412     const SomeExpr &pointer, const SomeExpr &init) {
413   return evaluate::IsInitialDataTarget(init, &context.messages()) &&
414       CheckPointerAssignment(context, pointer, init);
415 }
416 
417 } // namespace Fortran::semantics
418