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