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