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