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

source code of flang/lib/Semantics/pointer-assignment.cpp