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 bool CheckLeftHandSide(const SomeExpr &);
63 bool Check(const SomeExpr &);
64
65private:
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
97PointerAssignmentChecker &PointerAssignmentChecker::set_lhsType(
98 std::optional<TypeAndShape> &&lhsType) {
99 lhsType_ = std::move(lhsType);
100 return *this;
101}
102
103PointerAssignmentChecker &PointerAssignmentChecker::set_isContiguous(
104 bool isContiguous) {
105 isContiguous_ = isContiguous;
106 return *this;
107}
108
109PointerAssignmentChecker &PointerAssignmentChecker::set_isVolatile(
110 bool isVolatile) {
111 isVolatile_ = isVolatile;
112 return *this;
113}
114
115PointerAssignmentChecker &PointerAssignmentChecker::set_isBoundsRemapping(
116 bool isBoundsRemapping) {
117 isBoundsRemapping_ = isBoundsRemapping;
118 return *this;
119}
120
121PointerAssignmentChecker &PointerAssignmentChecker::set_isAssumedRank(
122 bool isAssumedRank) {
123 isAssumedRank_ = isAssumedRank;
124 return *this;
125}
126
127PointerAssignmentChecker &PointerAssignmentChecker::set_pointerComponentLHS(
128 const Symbol *symbol) {
129 pointerComponentLHS_ = symbol;
130 return *this;
131}
132
133bool 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
143bool 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
156template <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
164template <typename T>
165bool PointerAssignmentChecker::Check(const evaluate::Expr<T> &x) {
166 return common::visit([&](const auto &x) { return Check(x); }, x.u);
167}
168
169bool 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
234bool PointerAssignmentChecker::Check(const evaluate::NullPointer &) {
235 return true; // P => NULL() without MOLD=; always OK
236}
237
238template <typename T>
239bool 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 msg = "CONTIGUOUS %s is associated with the result of reference to"
270 " function '%s' that is not known to be contiguous"_warn_en_US;
271 } else if (lhsType_) {
272 const auto *frTypeAndShape{funcResult->GetTypeAndShape()};
273 CHECK(frTypeAndShape);
274 if (!lhsType_->IsCompatibleWith(foldingContext_.messages(), *frTypeAndShape,
275 "pointer", "function result",
276 /*omitShapeConformanceCheck=*/isBoundsRemapping_ || isAssumedRank_,
277 evaluate::CheckConformanceFlags::BothDeferredShape)) {
278 return false; // IsCompatibleWith() emitted message
279 }
280 }
281 if (msg) {
282 auto restorer{common::ScopedSet(lhs_, symbol)};
283 Say(*msg, description_, funcName);
284 return false;
285 }
286 return true;
287}
288
289template <typename T>
290bool PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
291 const Symbol *last{d.GetLastSymbol()};
292 const Symbol *base{d.GetBaseObject().symbol()};
293 if (!last || !base) {
294 // P => "character literal"(1:3)
295 Say("Pointer target is not a named entity"_err_en_US);
296 return false;
297 }
298 std::optional<std::variant<MessageFixedText, MessageFormattedText>> msg;
299 if (CharacterizeProcedure()) {
300 // Shouldn't be here in this function unless lhs is an object pointer.
301 msg = "In assignment to procedure %s, the target is not a procedure or"
302 " procedure pointer"_err_en_US;
303 } else if (!evaluate::GetLastTarget(GetSymbolVector(d))) { // C1025
304 msg = "In assignment to object %s, the target '%s' is not an object with"
305 " POINTER or TARGET attributes"_err_en_US;
306 } else if (auto rhsType{TypeAndShape::Characterize(d, foldingContext_)}) {
307 if (!lhsType_) {
308 msg = "%s associated with object '%s' with incompatible type or"
309 " shape"_err_en_US;
310 } else if (rhsType->corank() > 0 &&
311 (isVolatile_ != last->attrs().test(Attr::VOLATILE))) { // C1020
312 // TODO: what if A is VOLATILE in A%B%C? need a better test here
313 if (isVolatile_) {
314 msg = "Pointer may not be VOLATILE when target is a"
315 " non-VOLATILE coarray"_err_en_US;
316 } else {
317 msg = "Pointer must be VOLATILE when target is a"
318 " VOLATILE coarray"_err_en_US;
319 }
320 } else if (rhsType->type().IsUnlimitedPolymorphic()) {
321 if (!LhsOkForUnlimitedPoly()) {
322 msg = "Pointer type must be unlimited polymorphic or non-extensible"
323 " derived type when target is unlimited polymorphic"_err_en_US;
324 }
325 } else {
326 if (!lhsType_->type().IsTkLenCompatibleWith(rhsType->type())) {
327 msg = MessageFormattedText{
328 "Target type %s is not compatible with pointer type %s"_err_en_US,
329 rhsType->type().AsFortran(), lhsType_->type().AsFortran()};
330
331 } else if (!isBoundsRemapping_ &&
332 !lhsType_->attrs().test(TypeAndShape::Attr::AssumedRank)) {
333 int lhsRank{evaluate::GetRank(lhsType_->shape())};
334 int rhsRank{evaluate::GetRank(rhsType->shape())};
335 if (lhsRank != rhsRank) {
336 msg = MessageFormattedText{
337 "Pointer has rank %d but target has rank %d"_err_en_US, lhsRank,
338 rhsRank};
339 }
340 }
341 }
342 }
343 if (msg) {
344 auto restorer{common::ScopedSet(lhs_, last)};
345 if (auto *m{std::get_if<MessageFixedText>(&*msg)}) {
346 std::string buf;
347 llvm::raw_string_ostream ss{buf};
348 d.AsFortran(ss);
349 Say(*m, description_, ss.str());
350 } else {
351 Say(std::get<MessageFormattedText>(*msg));
352 }
353 return false;
354 }
355 return true;
356}
357
358// Common handling for procedure pointer right-hand sides
359bool PointerAssignmentChecker::Check(parser::CharBlock rhsName, bool isCall,
360 const Procedure *rhsProcedure,
361 const evaluate::SpecificIntrinsic *specific) {
362 std::string whyNot;
363 std::optional<std::string> warning;
364 CharacterizeProcedure();
365 if (std::optional<MessageFixedText> msg{evaluate::CheckProcCompatibility(
366 isCall, procedure_, rhsProcedure, specific, whyNot, warning,
367 /*ignoreImplicitVsExplicit=*/isCall)}) {
368 Say(std::move(*msg), description_, rhsName, whyNot);
369 return false;
370 }
371 if (context_.ShouldWarn(common::UsageWarning::ProcDummyArgShapes) &&
372 warning) {
373 Say("%s and %s may not be completely compatible procedures: %s"_warn_en_US,
374 description_, rhsName, std::move(*warning));
375 }
376 return true;
377}
378
379bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
380 const Symbol *symbol{d.GetSymbol()};
381 if (symbol) {
382 if (const auto *subp{
383 symbol->GetUltimate().detailsIf<SubprogramDetails>()}) {
384 if (subp->stmtFunction()) {
385 evaluate::SayWithDeclaration(foldingContext_.messages(), *symbol,
386 "Statement function '%s' may not be the target of a pointer assignment"_err_en_US,
387 symbol->name());
388 return false;
389 }
390 } else if (symbol->has<ProcBindingDetails>() &&
391 context_.ShouldWarn(common::LanguageFeature::BindingAsProcedure)) {
392 evaluate::SayWithDeclaration(foldingContext_.messages(), *symbol,
393 "Procedure binding '%s' used as target of a pointer assignment"_port_en_US,
394 symbol->name());
395 }
396 }
397 if (auto chars{
398 Procedure::Characterize(d, foldingContext_, /*emitError=*/true)}) {
399 // Disregard the elemental attribute of RHS intrinsics.
400 if (symbol && symbol->GetUltimate().attrs().test(Attr::INTRINSIC)) {
401 chars->attrs.reset(Procedure::Attr::Elemental);
402 }
403 return Check(d.GetName(), false, &*chars, d.GetSpecificIntrinsic());
404 } else {
405 return Check(d.GetName(), false);
406 }
407}
408
409bool PointerAssignmentChecker::Check(const evaluate::ProcedureRef &ref) {
410 auto chars{Procedure::Characterize(ref, foldingContext_)};
411 return Check(ref.proc().GetName(), true, common::GetPtrFromOptional(chars));
412}
413
414// The target can be unlimited polymorphic if the pointer is, or if it is
415// a non-extensible derived type.
416bool PointerAssignmentChecker::LhsOkForUnlimitedPoly() const {
417 const auto &type{lhsType_->type()};
418 if (type.category() != TypeCategory::Derived || type.IsAssumedType()) {
419 return false;
420 } else if (type.IsUnlimitedPolymorphic()) {
421 return true;
422 } else {
423 return !IsExtensibleType(&type.GetDerivedTypeSpec());
424 }
425}
426
427template <typename... A>
428parser::Message *PointerAssignmentChecker::Say(A &&...x) {
429 auto *msg{foldingContext_.messages().Say(std::forward<A>(x)...)};
430 if (msg) {
431 if (lhs_) {
432 return evaluate::AttachDeclaration(msg, *lhs_);
433 }
434 if (!source_.empty()) {
435 msg->Attach(source_, "Declaration of %s"_en_US, description_);
436 }
437 }
438 return msg;
439}
440
441// Verify that any bounds on the LHS of a pointer assignment are valid.
442// Return true if it is a bound-remapping so we can perform further checks.
443static bool CheckPointerBounds(
444 evaluate::FoldingContext &context, const evaluate::Assignment &assignment) {
445 auto &messages{context.messages()};
446 const SomeExpr &lhs{assignment.lhs};
447 const SomeExpr &rhs{assignment.rhs};
448 bool isBoundsRemapping{false};
449 std::size_t numBounds{common::visit(
450 common::visitors{
451 [&](const evaluate::Assignment::BoundsSpec &bounds) {
452 return bounds.size();
453 },
454 [&](const evaluate::Assignment::BoundsRemapping &bounds) {
455 isBoundsRemapping = true;
456 evaluate::ExtentExpr lhsSizeExpr{1};
457 for (const auto &bound : bounds) {
458 lhsSizeExpr = std::move(lhsSizeExpr) *
459 (common::Clone(bound.second) - common::Clone(bound.first) +
460 evaluate::ExtentExpr{1});
461 }
462 if (std::optional<std::int64_t> lhsSize{evaluate::ToInt64(
463 evaluate::Fold(context, std::move(lhsSizeExpr)))}) {
464 if (auto shape{evaluate::GetShape(context, rhs)}) {
465 if (std::optional<std::int64_t> rhsSize{
466 evaluate::ToInt64(evaluate::Fold(
467 context, evaluate::GetSize(std::move(*shape))))}) {
468 if (*lhsSize > *rhsSize) {
469 messages.Say(
470 "Pointer bounds require %d elements but target has"
471 " only %d"_err_en_US,
472 *lhsSize, *rhsSize); // 10.2.2.3(9)
473 }
474 }
475 }
476 }
477 return bounds.size();
478 },
479 [](const auto &) -> std::size_t {
480 DIE("not valid for pointer assignment");
481 },
482 },
483 assignment.u)};
484 if (numBounds > 0) {
485 if (lhs.Rank() != static_cast<int>(numBounds)) {
486 messages.Say("Pointer '%s' has rank %d but the number of bounds specified"
487 " is %d"_err_en_US,
488 lhs.AsFortran(), lhs.Rank(), numBounds); // C1018
489 }
490 }
491 if (isBoundsRemapping && rhs.Rank() != 1 &&
492 !evaluate::IsSimplyContiguous(rhs, context)) {
493 messages.Say("Pointer bounds remapping target must have rank 1 or be"
494 " simply contiguous"_err_en_US); // 10.2.2.3(9)
495 }
496 return isBoundsRemapping;
497}
498
499bool CheckPointerAssignment(SemanticsContext &context,
500 const evaluate::Assignment &assignment, const Scope &scope) {
501 return CheckPointerAssignment(context, assignment.lhs, assignment.rhs, scope,
502 CheckPointerBounds(context.foldingContext(), assignment),
503 /*isAssumedRank=*/false);
504}
505
506bool CheckPointerAssignment(SemanticsContext &context, const SomeExpr &lhs,
507 const SomeExpr &rhs, const Scope &scope, bool isBoundsRemapping,
508 bool isAssumedRank) {
509 const Symbol *pointer{GetLastSymbol(lhs)};
510 if (!pointer) {
511 return false; // error was reported
512 }
513 PointerAssignmentChecker checker{context, scope, *pointer};
514 checker.set_isBoundsRemapping(isBoundsRemapping);
515 checker.set_isAssumedRank(isAssumedRank);
516 bool lhsOk{checker.CheckLeftHandSide(lhs)};
517 bool rhsOk{checker.Check(rhs)};
518 return lhsOk && rhsOk; // don't short-circuit
519}
520
521bool CheckStructConstructorPointerComponent(SemanticsContext &context,
522 const Symbol &lhs, const SomeExpr &rhs, const Scope &scope) {
523 return PointerAssignmentChecker{context, scope, lhs}
524 .set_pointerComponentLHS(&lhs)
525 .Check(rhs);
526}
527
528bool CheckPointerAssignment(SemanticsContext &context, parser::CharBlock source,
529 const std::string &description, const DummyDataObject &lhs,
530 const SomeExpr &rhs, const Scope &scope, bool isAssumedRank) {
531 return PointerAssignmentChecker{context, scope, source, description}
532 .set_lhsType(common::Clone(lhs.type))
533 .set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous))
534 .set_isVolatile(lhs.attrs.test(DummyDataObject::Attr::Volatile))
535 .set_isAssumedRank(isAssumedRank)
536 .Check(rhs);
537}
538
539bool CheckInitialDataPointerTarget(SemanticsContext &context,
540 const SomeExpr &pointer, const SomeExpr &init, const Scope &scope) {
541 return evaluate::IsInitialDataTarget(
542 init, &context.foldingContext().messages()) &&
543 CheckPointerAssignment(context, pointer, init, scope,
544 /*isBoundsRemapping=*/false,
545 /*isAssumedRank=*/false);
546}
547
548} // namespace Fortran::semantics
549

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