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