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