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